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

Require Export CoRN.tactics.DiffTactics2.
Require Export CoRN.ftc.MoreFunctions.

Section Rolle.

(**
* Rolle's Theorem

We now begin to work with partial functions.  We begin by stating and proving Rolle's theorem in various forms and some of its corollaries.

%\begin{convention}% Assume that:
 - [a,b:IR] with [a [<] b] and denote by [I] the interval [[a,b]];
 - [F,F'] are partial functions such that [F'] is the derivative of [F] in [I];
 - [e] is a positive real number.

%\end{convention}%
*)

(* begin hide *)
Variables a b : IR.
Hypothesis Hab' : a [<] b.

Let Hab := less_leEq _ _ _ Hab'.
Let I := Compact Hab.

Variables F F' : PartIR.

Hypothesis derF : Derivative_I Hab' F F'.
Hypothesis Ha : Dom F a.
Hypothesis Hb : Dom F b.
(* end hide *)

(* begin show *)
Hypothesis Fab : F a Ha [=] F b Hb.
(* end show *)

(* begin hide *)
Variable e : IR.
Hypothesis He : [0] [<] e.

Let contF' : Continuous_I Hab F'.
Proof.
 apply deriv_imp_contin'_I with Hab' F.
 assumption.
Qed.

Let derivF :
  forall e : IR,
  [0] [<] e ->
  {d : IR | [0] [<] d |
  forall x y : IR,
  I x ->
  I y ->
  forall Hx Hy Hx',
  AbsIR (x[-]y) [<=] d ->
  AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e[*]AbsIR (y[-]x)}.
Proof.
 elim derF.
 intros a0 b0.
 elim b0; intros H b1.
 unfold I in |- *; assumption.
Qed.

Let Rolle_lemma2 :
  {d : IR | [0] [<] d |
  forall x y : IR,
  I x ->
  I y ->
  forall Hx Hy Hx',
  AbsIR (x[-]y) [<=] d ->
  AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e [/]TwoNZ[*]AbsIR (y[-]x)}.
Proof.
 exact (derivF _ (pos_div_two _ _ He)).
Qed.

Let df := proj1_sig2T _ _ _ Rolle_lemma2.

Let Hdf : [0] [<] df := proj2a_sig2T _ _ _ Rolle_lemma2.

Let Hf :
  forall x y : IR,
  I x ->
  I y ->
  forall Hx Hy Hx',
  AbsIR (x[-]y) [<=] df ->
  AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e [/]TwoNZ[*]AbsIR (y[-]x) :=
  proj2b_sig2T _ _ _ Rolle_lemma2.

Let Rolle_lemma3 :
  {d : IR | [0] [<] d |
  forall x y : IR,
  I x ->
  I y ->
  forall Hx Hy, AbsIR (x[-]y) [<=] d -> AbsIR (F' x Hx[-]F' y Hy) [<=] e [/]TwoNZ}.
Proof.
 elim contF'; intros.
 exact (b0 _ (pos_div_two _ _ He)).
Qed.

Let df' := proj1_sig2T _ _ _ Rolle_lemma3.

Let Hdf' : [0] [<] df' := proj2a_sig2T _ _ _ Rolle_lemma3.

Let Hf' :
  forall x y : IR,
  I x ->
  I y ->
  forall Hx Hy,
  AbsIR (x[-]y) [<=] df' -> AbsIR (F' x Hx[-]F' y Hy) [<=] e [/]TwoNZ :=
  proj2b_sig2T _ _ _ Rolle_lemma3.

Let d := Min df df'.

Let Hd : [0] [<] d.
Proof.
 unfold d in |- *; apply less_Min; auto.
Qed.

Let incF : included (Compact Hab) (Dom F).
Proof.
 elim derF; intros; assumption.
Qed.

Let n := compact_nat a b d Hd.

Let fcp (i : nat) (Hi : i <= n) :=
  F (compact_part a b Hab' d Hd i Hi)
    (incF _ (compact_part_hyp a b Hab Hab' d Hd i Hi)).

Let Rolle_lemma1 :
  Sumx (fun (i : nat) (H : i < n) => fcp (S i) H[-]fcp i (lt_le_weak i n H)) [=]
  [0].
Proof.
 apply eq_transitive_unfolded with (fcp _ (le_n n) [-]fcp 0 (le_O_n n)).
  apply Mengolli_Sum with (f := fun (i : nat) (H : i <= n) => fcp _ H).
   red in |- *; do 3 intro.
   rewrite H; intros.
   unfold fcp in |- *; simpl in |- *; algebra.
  intros; algebra.
 apply eq_transitive_unfolded with (F b Hb[-]F a Ha).
  unfold fcp, compact_part, n in |- *; simpl in |- *.
  apply cg_minus_wd; apply pfwdef; rational.
 astepr (F a Ha[-]F a Ha); apply cg_minus_wd.
  apply eq_symmetric_unfolded; apply Fab.
 algebra.
Qed.

Let incF' : included (Compact Hab) (Dom F').
Proof.
 elim derF; intros.
 elim b0; intros.
 assumption.
Qed.

Let fcp' (i : nat) (Hi : i <= n) :=
  F' (compact_part a b Hab' d Hd i Hi)
    (incF' _ (compact_part_hyp a b Hab Hab' d Hd i Hi)).

Notation cp := (compact_part a b Hab' d Hd).

Let Rolle_lemma4 :
  {i : nat |
  {H : i < n |
  [0] [<]
  (fcp' _ (lt_le_weak _ _ H) [+]e) [*] (cp (S i) H[-]cp i (lt_le_weak _ _ H))}}.
Proof.
 apply positive_Sumx with (f := fun (i : nat) (H : i < n) => (fcp' _ (lt_le_weak _ _ H) [+]e) [*]
   (cp _ H[-]cp _ (lt_le_weak _ _ H))).
  red in |- *; do 3 intro.
  rewrite H; intros.
  unfold fcp' in |- *; algebra.
 apply less_wdl with (Sumx (fun (i : nat) (H : i < n) => fcp _ H[-]fcp _ (lt_le_weak _ _ H))).
  2: apply Rolle_lemma1.
 apply Sumx_resp_less.
  apply less_nring with (IR:COrdField); simpl in |- *; unfold n in |- *; apply pos_compact_nat; auto.
 intros.
 apply leEq_less_trans with ((fcp' i (lt_le_weak _ _ H) [+]e [/]TwoNZ) [*]
   (cp (S i) H[-]cp i (lt_le_weak _ _ H))).
  2: apply mult_resp_less.
   3: apply compact_less.
  2: apply plus_resp_less_lft.
  2: apply pos_div_two'; assumption.
 rstepl (fcp' i (lt_le_weak _ _ H) [*] (cp _ H[-]cp _ (lt_le_weak _ _ H)) [+]
   (fcp _ H[-]fcp _ (lt_le_weak _ _ H) [-]
     fcp' i (lt_le_weak _ _ H) [*] (cp _ H[-]cp _ (lt_le_weak _ _ H)))).
 eapply leEq_wdr.
  2: apply eq_symmetric_unfolded; apply ring_distl_unfolded.
 apply plus_resp_leEq_lft.
 apply leEq_wdr with (e [/]TwoNZ[*]AbsIR (cp (S i) H[-]cp i (lt_le_weak _ _ H))).
  2: apply mult_wd.
   2: algebra.
  2: apply AbsIR_eq_x.
  2: apply less_leEq; apply compact_less.
 eapply leEq_transitive.
  apply leEq_AbsIR.
 unfold fcp, fcp' in |- *; apply Hf.
   unfold I in |- *; apply compact_part_hyp.
  unfold I in |- *; apply compact_part_hyp.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_minus.
 apply leEq_transitive with d.
  2: unfold d in |- *; apply Min_leEq_lft.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
  apply compact_leEq.
 apply less_leEq; apply compact_less.
Qed.

Let Rolle_lemma5 : {i : nat | {H : i <= n | [--]e [<] fcp' _ H}}.
Proof.
 elim Rolle_lemma4; intros i Hi; elim Hi; clear Hi; intros Hi Hi'.
 exists i; exists (lt_le_weak _ _ Hi).
 astepl ([0][-]e); apply shift_minus_less.
 eapply mult_cancel_less.
  2: eapply less_wdl.
   2: apply Hi'.
  2: algebra.
 apply compact_less.
Qed.

Let Rolle_lemma6 :
  {i : nat |
  {H : i < n |
  (fcp' _ (lt_le_weak _ _ H) [-]e) [*] (cp (S i) H[-]cp i (lt_le_weak _ _ H)) [<]
  [0]}}.
Proof.
 apply negative_Sumx with (f := fun (i : nat) (H : i < n) => (fcp' _ (lt_le_weak _ _ H) [-]e) [*]
   (cp _ H[-]cp _ (lt_le_weak _ _ H))).
  red in |- *; do 3 intro.
  rewrite H; intros.
  unfold fcp' in |- *; algebra.
 apply less_wdr with (Sumx (fun (i : nat) (H : i < n) => fcp _ H[-]fcp _ (lt_le_weak _ _ H))).
  2: apply Rolle_lemma1.
 apply Sumx_resp_less.
  apply less_nring with (IR:COrdField); simpl in |- *; unfold n in |- *; apply pos_compact_nat; auto.
 intros.
 apply less_leEq_trans with ((fcp' _ (lt_le_weak _ _ H) [-]e [/]TwoNZ) [*]
   (cp _ H[-]cp _ (lt_le_weak _ _ H))).
  apply mult_resp_less.
   2: apply compact_less.
  unfold cg_minus in |- *; apply plus_resp_less_lft.
  apply inv_resp_less; apply pos_div_two'; assumption.
 rstepr (fcp' _ (lt_le_weak _ _ H) [*] (cp _ H[-]cp _ (lt_le_weak _ _ H)) [+] [--] [--]
   (fcp _ H[-]fcp _ (lt_le_weak _ _ H) [-]
     fcp' _ (lt_le_weak _ _ H) [*] (cp _ H[-]cp _ (lt_le_weak _ _ H)))).
 rstepl (fcp' _ (lt_le_weak _ _ H) [*] (cp _ H[-]cp _ (lt_le_weak _ _ H)) [-]
   e [/]TwoNZ[*] (cp _ H[-]cp _ (lt_le_weak _ _ H))).
 unfold cg_minus at 1 in |- *; apply plus_resp_leEq_lft.
 apply inv_resp_leEq; apply leEq_wdr with (e [/]TwoNZ[*]AbsIR (cp _ H[-]cp _ (lt_le_weak _ _ H))).
  2: apply mult_wd.
   2: algebra.
  2: apply AbsIR_eq_x.
  2: apply less_leEq; apply compact_less.
 eapply leEq_transitive.
  apply inv_leEq_AbsIR.
 unfold fcp, fcp' in |- *; apply Hf.
   unfold I in |- *; apply compact_part_hyp.
  unfold I in |- *; apply compact_part_hyp.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_minus.
 apply leEq_transitive with d.
  2: unfold d in |- *; apply Min_leEq_lft.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
  apply compact_leEq.
 apply less_leEq; apply compact_less.
Qed.

Let Rolle_lemma7 : {i : nat | {H : i <= n | fcp' _ H [<] e}}.
Proof.
 elim Rolle_lemma6; intros i Hi; elim Hi; clear Hi; intros Hi Hi'.
 exists i; exists (lt_le_weak _ _ Hi).
 astepr (e[+][0]); apply shift_less_plus'.
 eapply mult_cancel_less.
  2: eapply less_wdr.
   2: apply Hi'.
  2: algebra.
 apply shift_less_minus.
 astepl (cp _ (lt_le_weak _ _ Hi)).
 unfold compact_part in |- *.
 apply plus_resp_less_lft.
 apply mult_resp_less.
  simpl in |- *; apply less_plusOne.
 apply div_resp_pos.
  2: apply shift_less_minus; astepl a; auto.
 apply pos_compact_nat; auto.
Qed.

Let j := ProjT1 Rolle_lemma5.

Let Hj := ProjT1 (ProjT2 Rolle_lemma5).

Let Hj' : [--]e [<] fcp' _ Hj.
Proof.
 exact (ProjT2 (ProjT2 Rolle_lemma5)).
Qed.

Let k := ProjT1 Rolle_lemma7.

Let Hk := ProjT1 (ProjT2 Rolle_lemma7).

Let Hk' : fcp' _ Hk [<] e.
Proof.
 exact (ProjT2 (ProjT2 Rolle_lemma7)).
Qed.

Let Rolle_lemma8 :
  forall (i : nat) (H : i <= n),
  AbsIR (fcp' _ H) [<] e or e [/]TwoNZ [<] AbsIR (fcp' _ H).
Proof.
 intros.
 cut (e [/]TwoNZ [<] AbsIR (fcp' _ H) or AbsIR (fcp' _ H) [<] e).
  intro H0; inversion_clear H0; [ right | left ]; assumption.
 apply less_cotransitive_unfolded.
 apply pos_div_two'; assumption.
Qed.

Let Rolle_lemma9 :
  {m : nat | {Hm : m <= n | AbsIR (fcp' _ Hm) [<] e}}
  or (forall (i : nat) (H : i <= n), e [/]TwoNZ [<] AbsIR (fcp' _ H)).
Proof.
 set (P := fun (i : nat) (H : i <= n) => AbsIR (fcp' _ H) [<] e) in *.
 set (Q := fun (i : nat) (H : i <= n) => e [/]TwoNZ [<] AbsIR (fcp' _ H)) in *.
 apply finite_or_elim with (P := P) (Q := Q).
   red in |- *.
   intros i i' Hii'; rewrite Hii'; intros Hi Hi' HP.
   red in |- *; red in HP.
   eapply less_wdl.
    apply HP.
   apply AbsIR_wd; unfold fcp' in |- *; algebra.
  red in |- *.
  intros i i' Hii'; rewrite Hii'; intros Hi Hi' HQ.
  red in |- *; red in HQ.
  eapply less_wdr.
   apply HQ.
  apply AbsIR_wd; unfold fcp' in |- *; algebra.
 apply Rolle_lemma8.
Qed.

Let Rolle_lemma10 :
  {m : nat | {Hm : m <= n | AbsIR (fcp' _ Hm) [<] e}} ->
  {x : IR | I x | forall Hx, AbsIR (F' x Hx) [<=] e}.
Proof.
 intro H.
 elim H; intros m Hm; elim Hm; clear H Hm; intros Hm Hm'.
 exists (cp _ Hm).
  red in |- *; apply compact_part_hyp.
 intro; apply less_leEq; eapply less_wdl.
  apply Hm'.
 apply AbsIR_wd; unfold fcp' in |- *; algebra.
Qed.

Let Rolle_lemma11 :
  (forall (i : nat) (H : i <= n), e [/]TwoNZ [<] AbsIR (fcp' _ H)) ->
  (forall H : 0 <= n, fcp' _ H [<] [--] (e [/]TwoNZ)) ->
  forall (i : nat) (H : i <= n), fcp' _ H [<] [0].
Proof.
 intros H H0.
 cut (forall H : 0 <= n, fcp' _ H [<] [0]).
  intro.
  simple induction i.
   assumption.
  intros i' Hrec HSi'.
  astepr (e [/]TwoNZ[-]e [/]TwoNZ).
  apply shift_less_minus.
  cut (i' <= n).
   2: auto with arith.
  intro Hi'.
  apply less_leEq_trans with (fcp' _ HSi'[-]fcp' _ Hi').
   unfold cg_minus in |- *; apply plus_resp_less_lft.
   cut (e [/]TwoNZ [<] fcp' _ Hi' or fcp' _ Hi' [<] [--] (e [/]TwoNZ)).
    intro H2.
    elim H2; clear H2; intro H3.
     exfalso.
     cut (e [/]TwoNZ [<] [0]).
      apply less_antisymmetric_unfolded.
      apply pos_div_two; assumption.
     eapply less_transitive_unfolded; [ apply H3 | apply Hrec ].
    astepl ( [--][--] (e [/]TwoNZ)); apply inv_resp_less; assumption.
   cut (e [/]TwoNZ [<] AbsIR (fcp' _ Hi')).
    2: exact (H i' Hi').
   intro H2.
   apply less_AbsIR.
    apply pos_div_two; assumption.
   assumption.
  eapply leEq_transitive.
   apply leEq_AbsIR.
  unfold fcp' in |- *; apply Hf'.
    red in |- *; apply compact_part_hyp.
   red in |- *; apply compact_part_hyp.
  apply leEq_transitive with d.
   2: unfold d in |- *; apply Min_leEq_rht.
  eapply leEq_wdl.
   2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
   apply compact_leEq.
  apply less_leEq; apply compact_less.
 intro.
 eapply less_transitive_unfolded.
  apply (H0 H1).
 astepr ( [--]ZeroR); apply inv_resp_less; apply pos_div_two; assumption.
Qed.

Let Rolle_lemma12 :
  (forall (i : nat) (H : i <= n), e [/]TwoNZ [<] AbsIR (fcp' _ H)) ->
  (forall H : 0 <= n, e [/]TwoNZ [<] fcp' _ H) ->
  forall (i : nat) (H : i <= n), [0] [<] fcp' _ H.
Proof.
 intros H H0.
 cut (forall H : 0 <= n, [0] [<] fcp' _ H).
  intro.
  simple induction i.
   assumption.
  intros i' Hrec HSi'.
  astepl ( [--]ZeroR); astepr ( [--][--] (fcp' _ HSi')); apply inv_resp_less.
  astepr (e [/]TwoNZ[-]e [/]TwoNZ).
  apply shift_less_minus'.
  astepl (e [/]TwoNZ[-]fcp' _ HSi').
  cut (i' <= n).
   2: auto with arith.
  intro Hi'.
  apply less_leEq_trans with (fcp' _ Hi'[-]fcp' _ HSi').
   unfold cg_minus in |- *; apply plus_resp_less_rht.
   cut (e [/]TwoNZ [<] fcp' _ Hi' or fcp' _ Hi' [<] [--] (e [/]TwoNZ)).
    intro H2; elim H2; clear H2; intro H3.
     assumption.
    exfalso.
    cut ([0] [<] [--] (e [/]TwoNZ)).
     apply less_antisymmetric_unfolded.
     astepr ( [--]ZeroR); apply inv_resp_less; apply pos_div_two; assumption.
    eapply less_transitive_unfolded; [ apply (Hrec Hi') | apply H3 ].
   cut (e [/]TwoNZ [<] AbsIR (fcp' _ Hi')).
    2: exact (H i' Hi').
   intro.
   apply less_AbsIR.
    apply pos_div_two; assumption.
   assumption.
  eapply leEq_transitive.
   apply leEq_AbsIR.
  unfold fcp' in |- *; apply Hf'.
    red in |- *; apply compact_part_hyp.
   red in |- *; apply compact_part_hyp.
  apply leEq_transitive with d.
   2: unfold d in |- *; apply Min_leEq_rht.
  eapply leEq_wdl.
   2: apply eq_symmetric_unfolded; apply AbsIR_minus.
  eapply leEq_wdl.
   2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
   apply compact_leEq.
  apply less_leEq; apply compact_less.
 intro.
 eapply less_transitive_unfolded.
  2: apply (H0 H1).
 apply pos_div_two; assumption.
Qed.

Let Rolle_lemma13 :
  (forall (i : nat) (H : i <= n), fcp' _ H [<] [0])
  or (forall (i : nat) (H : i <= n), [0] [<] fcp' _ H) ->
  {x : IR | I x | forall Hx, AbsIR (F' x Hx) [<=] e}.
Proof.
 intro H; elim H; clear H; intro H0.
  exists (cp _ Hj).
   red in |- *; apply compact_part_hyp.
  intro; simpl in |- *; unfold ABSIR in |- *; apply Max_leEq.
   apply less_leEq; apply less_transitive_unfolded with ZeroR.
    eapply less_wdl.
     apply (H0 _ Hj).
    unfold fcp' in |- *; algebra.
   assumption.
  astepr ( [--][--]e); apply inv_resp_leEq.
  apply less_leEq; eapply less_wdr.
   apply Hj'.
  unfold fcp' in |- *; algebra.
 exists (cp _ Hk).
  red in |- *; apply compact_part_hyp.
 intros.
 simpl in |- *; unfold ABSIR in |- *; apply Max_leEq.
  apply less_leEq; eapply less_wdl.
   apply Hk'.
  unfold fcp' in |- *; algebra.
 apply less_leEq; apply less_transitive_unfolded with ZeroR.
  astepr ( [--]ZeroR); apply inv_resp_less; eapply less_wdr.
   apply (H0 _ Hk).
  unfold fcp' in |- *; rational.
 assumption.
Qed.

Let Rolle_lemma15 :
  (forall (i : nat) (H : i <= n), e [/]TwoNZ [<] AbsIR (fcp' _ H)) ->
  fcp' _ (le_O_n n) [<] [--] (e [/]TwoNZ) or e [/]TwoNZ [<] fcp' _ (le_O_n n).
Proof.
 intro H.
 cut (e [/]TwoNZ [<] fcp' _ (le_O_n n) or fcp' _ (le_O_n n) [<] [--] (e [/]TwoNZ)).
  intro H0; inversion_clear H0; [ right | left ]; assumption.
 apply less_AbsIR.
  apply pos_div_two; assumption.
 apply H.
Qed.
(* end hide *)

Theorem Rolle : {x : IR | I x | forall Hx, AbsIR (F' x Hx) [<=] e}.
Proof.
 elim Rolle_lemma9.
  exact Rolle_lemma10.
 intro.
 apply Rolle_lemma13.
 elim (Rolle_lemma15 b0).
  left; apply Rolle_lemma11.
   assumption.
  intro.
  eapply less_wdl.
   apply a0.
  unfold fcp' in |- *; algebra.
 right; apply Rolle_lemma12.
  assumption.
 intro.
 eapply less_wdr.
  apply b1.
 unfold fcp' in |- *; algebra.
Qed.

End Rolle.

Section Law_of_the_Mean.

(**
The following is a simple corollary:
*)

Variables a b : IR.
Hypothesis Hab' : a [<] b.

(* begin hide *)
Let Hab := less_leEq _ _ _ Hab'.
Let I := Compact Hab.
(* end hide *)

Variables F F' : PartIR.

Hypothesis HF : Derivative_I Hab' F F'.

(* begin show *)
Hypothesis HA : Dom F a.
Hypothesis HB : Dom F b.
(* end show *)

Lemma Law_of_the_Mean_I : forall e, [0] [<] e ->
 {x : IR | I x | forall Hx, AbsIR (F b HB[-]F a HA[-]F' x Hx[*] (b[-]a)) [<=] e}.
Proof.
 intros e H.
 set (h := (FId{-} [-C-]a) {*} [-C-] (F b HB[-]F a HA) {-}F{*} [-C-] (b[-]a)) in *.
 set (h' := [-C-] (F b HB[-]F a HA) {-}F'{*} [-C-] (b[-]a)) in *.
 cut (Derivative_I Hab' h h').
  intro H0.
  cut {x : IR | I x | forall Hx, AbsIR (h' x Hx) [<=] e}.
   intro H1.
   elim H1; intros x Ix Hx.
   exists x.
    assumption.
   intro.
   eapply leEq_wdl.
    apply (Hx (derivative_imp_inc' _ _ _ _ _ H0 x Ix)).
   apply AbsIR_wd; simpl in |- *; rational.
  unfold I, Hab in |- *; eapply Rolle with h
    (derivative_imp_inc _ _ _ _ _ H0 _ (compact_inc_lft _ _ _))
      (derivative_imp_inc _ _ _ _ _ H0 _ (compact_inc_rht _ _ _)).
    assumption.
   simpl in |- *; rational.
  assumption.
 unfold h, h' in |- *; clear h h'.
 New_Deriv.
  apply Feq_reflexive.
  apply included_FMinus; Included.
 apply eq_imp_Feq.
   apply included_FMinus.
    apply included_FPlus; Included.
   Included.
  Included.
 intros.
 simpl in |- *; rational.
Qed.

End Law_of_the_Mean.

Section Corollaries.

(**
We can also state these theorems without expliciting the derivative of [F].
*)

Variables a b : IR.
Hypothesis Hab' : a [<] b.

(* begin hide *)
Let Hab := less_leEq _ _ _ Hab'.
(* end hide *)
Variable F : PartIR.

(* begin show *)
Hypothesis HF : Diffble_I Hab' F.
(* end show *)

Theorem Rolle' : (forall Ha Hb, F a Ha [=] F b Hb) -> forall e, [0] [<] e ->
 {x : IR | Compact Hab x | forall Hx, AbsIR (PartInt (ProjT1 HF) x Hx) [<=] e}.
Proof.
 intros.
 unfold Hab in |- *.
 apply Rolle with F (diffble_imp_inc _ _ _ _ HF _ (compact_inc_lft a b Hab))
   (diffble_imp_inc _ _ _ _ HF _ (compact_inc_rht a b Hab)).
   apply projT2.
  apply H.
 assumption.
Qed.

Lemma Law_of_the_Mean'_I : forall HA HB e, [0] [<] e ->
 {x : IR | Compact Hab x | forall Hx,
  AbsIR (F b HB[-]F a HA[-]PartInt (ProjT1 HF) x Hx[*] (b[-]a)) [<=] e}.
Proof.
 intros.
 unfold Hab in |- *.
 apply Law_of_the_Mean_I.
  apply projT2.
 assumption.
Qed.

End Corollaries.

Section Generalizations.

(**
The mean law is more useful if we abstract [a] and [b] from the
context---allowing them in particular to be equal.  In the case where
[F(a) [=] F(b)] we get Rolle's theorem again, so there is no need to
state it also in this form.

%\begin{convention}% Assume [I] is a proper interval, [F,F':PartIR].
%\end{convention}%
*)

Variable I : interval.
Hypothesis pI : proper I.

Variables F F' : PartIR.
(* begin show *)
Hypothesis derF : Derivative I pI F F'.
(* end show *)

(* begin hide *)
Let incF := Derivative_imp_inc _ _ _ _ derF.
Let incF' := Derivative_imp_inc' _ _ _ _ derF.
(* end hide *)

Theorem Law_of_the_Mean : forall a b, I a -> I b -> forall e, [0] [<] e ->
 {x : IR | Compact (Min_leEq_Max a b) x | forall Ha Hb Hx,
  AbsIR (F b Hb[-]F a Ha[-]F' x Hx[*] (b[-]a)) [<=] e}.
Proof.
 intros a b Ha Hb e He.
 cut (included (Compact (Min_leEq_Max a b)) I). intro H.
  2: apply included_interval'; auto.
 elim (less_cotransitive_unfolded _ _ _ He
   (AbsIR (F b (incF _ Hb) [-]F a (incF _ Ha) [-]F' a (incF' _ Ha) [*] (b[-]a)))); intros.
  cut (Min a b [<] Max a b). intro H0.
   cut (included (Compact (less_leEq _ _ _ H0)) I). intro H1.
    2: apply included_interval'; auto.
   elim (ap_imp_less _ _ _ (Min_less_Max_imp_ap _ _ H0)); intro.
    cut (included (Compact (less_leEq _ _ _ a1)) I). intro H2.
     2: apply included_trans with (Compact (less_leEq _ _ _ H0)); [ apply compact_map2 | apply H1 ].
    elim (Law_of_the_Mean_I _ _ a1 _ _ (included_imp_Derivative _ _ _ _ derF _ _ a1 H2) (
      incF _ Ha) (incF _ Hb) e He).
    intros x H3 H4.
    exists x; auto.
     apply compact_map2 with (Hab := less_leEq _ _ _ a1); auto.
    intros.
    eapply leEq_wdl.
     apply (H4 Hx).
    apply AbsIR_wd; algebra.
   cut (included (Compact (Min_leEq_Max b a)) (Compact (Min_leEq_Max a b))). intro H2.
    cut (included (Compact (less_leEq _ _ _ b0)) I). intro H3.
     2: apply included_trans with (Compact (Min_leEq_Max b a)); [ apply compact_map2
       | apply included_trans with (Compact (less_leEq _ _ _ H0)); [ apply H2 | apply H1 ] ].
    elim (Law_of_the_Mean_I _ _ b0 _ _ (included_imp_Derivative _ _ _ _ derF _ _ b0 H3) (
      incF _ Hb) (incF _ Ha) e He).
    intros x H4 H5.
    exists x; auto.
     apply H2; apply compact_map2 with (Hab := less_leEq _ _ _ b0); auto.
    intros.
    eapply leEq_wdl.
     apply (H5 Hx).
    eapply eq_transitive_unfolded.
     apply AbsIR_minus.
    apply AbsIR_wd; rational.
   intros x H2.
   elim H2; clear H2; intros H3 H4; split.
    eapply leEq_wdl; [ apply H3 | apply Min_comm ].
   eapply leEq_wdr; [ apply H4 | apply Max_comm ].
  apply ap_imp_Min_less_Max.
  cut (Part _ _ (incF b Hb) [-]Part _ _ (incF a Ha) [#] [0]
    or Part _ _ (incF' a Ha) [*] (b[-]a) [#] [0]).
   intro H0.
   elim H0; clear H0; intro H1.
    apply pfstrx with F (incF a Ha) (incF b Hb).
    apply ap_symmetric_unfolded; apply zero_minus_apart; auto.
   apply ap_symmetric_unfolded; apply zero_minus_apart.
   eapply cring_mult_ap_zero_op; apply H1.
  apply cg_minus_strext.
  astepr ZeroR.
  apply AbsIR_cancel_ap_zero.
  apply Greater_imp_ap; auto.
 exists a.
  apply compact_Min_lft.
 intros; apply less_leEq.
 eapply less_wdl.
  apply b0.
 apply AbsIR_wd; algebra.
Qed.

(**
We further generalize the mean law by writing as an explicit bound.
*)

Theorem Law_of_the_Mean_Abs_ineq : forall a b, I a -> I b -> forall c,
 (forall x,  Compact (Min_leEq_Max a b) x -> forall Hx, AbsIR (F' x Hx) [<=] c) ->
 forall Ha Hb, AbsIR (F b Hb[-]F a Ha) [<=] c[*]AbsIR (b[-]a).
Proof.
 intros a b Ia Ib c Hc Ha Hb.
 astepr (c[*]AbsIR (b[-]a) [+][0]).
 apply shift_leEq_plus'.
 apply approach_zero_weak.
 intros e H.
 elim Law_of_the_Mean with a b e; auto.
 intros x H0 H1.
 cut (Dom F' x). intro H2.
  eapply leEq_transitive.
   2: apply (H1 Ha Hb H2).
  eapply leEq_transitive.
   2: apply triangle_IR_minus'.
  unfold cg_minus at 1 4 in |- *; apply plus_resp_leEq_lft.
  apply inv_resp_leEq.
  stepl (AbsIR (F' x H2)[*]AbsIR(b[-]a)).
   2:apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
  apply mult_resp_leEq_rht.
   auto.
  apply AbsIR_nonneg.
 apply (Derivative_imp_inc' _ _ _ _ derF).
 exact (included_interval I a b Ia Ib (Min_leEq_Max a b) x H0).
Qed.

Theorem Law_of_the_Mean_ineq : forall a b, I a -> I b -> forall c,
 (forall x,  Compact (Min_leEq_Max a b) x -> forall Hx, AbsIR (F' x Hx) [<=] c) ->
 forall Ha Hb, F b Hb[-]F a Ha [<=] c[*]AbsIR (b[-]a).
Proof.
 intros.
 eapply leEq_transitive.
  apply leEq_AbsIR.
 apply Law_of_the_Mean_Abs_ineq; assumption.
Qed.

End Generalizations.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonDefinitions.
Require Import VerdiRaft.TraceUtil.

Section OutputGreatestId.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Section inner.

  Variable client : clientId.
  Variable id : nat.

  Definition greatest_id_for_client (net : network) : Prop :=
    forall id',
      id < id' ->
      before_func (has_key client id) (has_key client id') (applied_entries (nwState net)).

  End inner.

  Class output_greatest_id_interface : Prop :=
    {
      output_greatest_id :
        forall client id failed net tr,
          step_failure_star step_failure_init (failed, net) tr ->
          key_in_output_trace client id tr ->
          greatest_id_for_client client id net
    }.
End OutputGreatestId.


Require Import Coq.ZArith.ZArith.
Require Import riscv.Utility.Monads.
Require riscv.Utility.MonadNotations.
Require Import riscv.Utility.Utility.
Require Import riscv.Spec.Decode.
Require Import riscv.Spec.CSRField.
Local Open Scope Z_scope.

(* Note that this is ordered: User < Supervisor < Machine *)
Inductive PrivMode: Type := User | Supervisor | Machine.

Definition decodePrivMode(m: MachineInt): PrivMode :=
  match m with
  | 0 => User
  | 1 => Supervisor
  | 3 => Machine
  | _ => User (* error "Invalid privilege mode" *)
  end.

Definition encodePrivMode(m: PrivMode): MachineInt :=
  match m with
  | User => 0
  | Supervisor => 1
  | Machine => 3
  end.

Definition PrivMode_eqb(m1 m2: PrivMode): bool := Z.eqb (encodePrivMode m1) (encodePrivMode m2).

Definition PrivMode_ltb(m1 m2: PrivMode): bool := Z.ltb (encodePrivMode m1) (encodePrivMode m2).

Inductive AccessType: Type := Instr | Load | Store.
Inductive SourceType: Type := VirtualMemory | Fetch | Execute.

Class RiscvProgram{M}{t}`{Monad M}`{MachineWidth t} := mkRiscvProgram {
  getRegister: Register -> M t;
  setRegister: Register -> t -> M unit;

  loadByte   : SourceType -> t -> M w8;
  loadHalf   : SourceType -> t -> M w16;
  loadWord   : SourceType -> t -> M w32;
  loadDouble : SourceType -> t -> M w64;

  storeByte   : SourceType -> t -> w8 -> M unit;
  storeHalf   : SourceType -> t -> w16 -> M unit;
  storeWord   : SourceType -> t -> w32 -> M unit;
  storeDouble : SourceType -> t -> w64 -> M unit;

  makeReservation  : t -> M unit;
  clearReservation : t -> M unit;
  checkReservation : t -> M bool;

  getCSRField : CSRField -> M MachineInt;
  setCSRField : CSRField -> MachineInt -> M unit;

  getPC: M t;
  setPC: t -> M unit;
  getPrivMode: M PrivMode;
  setPrivMode: PrivMode -> M unit;
  fence: MachineInt -> MachineInt -> M unit;

  (* Both of these update the PC at the end of a cycle.
     Every instance must support endCycleNormal.
     All operations following endCycleEarly are skipped.
     Some instances may not support endCycleEarly and fail instead. *)
  endCycleNormal: M unit;
  endCycleEarly: forall A, M A;
}.

Class RiscvMachine`{MP: RiscvProgram} := mkRiscvMachine {
  (* checks that addr is aligned, and translates the (possibly virtual) addr to a physical
     address, raising an exception if the address is invalid *)
  translate(accessType: AccessType)(alignment: t)(addr: t): M t;
  flushTLB: M unit;
  getCSR_InstRet: M MachineInt;
  getCSR_Time: M MachineInt;
  getCSR_Cycle: M MachineInt;
}.

Section Riscv.
  (* monad (will be instantiated with some kind of state monad) *)
  Context {M: Type -> Type}.
  Context {MM: Monad M}.

  (* type of register values *)
  Context {t: Type}.

  (* provides operations on t *)
  Context {MW: MachineWidth t}.

  Local Open Scope alu_scope.
  Local Open Scope Z_scope.

  Import MonadNotations.

  Context {MP: RiscvProgram}.

  Definition getXLEN: M MachineInt :=
    mxl <- getCSRField MXL;
    if Z.eqb mxl 1 then Return 32
    else if Z.eqb mxl 2 then Return 64
    else Return 0.

  Definition raiseExceptionWithInfo{A: Type}(isInterrupt exceptionCode info: t): M A :=
    pc <- getPC;
    (* here we hardcode that this simplified spec only supports machine mode and no interrupts *)
    addr <- getCSRField MTVecBase;
    setCSRField MTVal (regToZ_unsigned info);;
    (* these two need to be set just so that Mret will succeed at restoring them *)
    setCSRField MPP (encodePrivMode Machine);;
    setCSRField MPIE 0;;
    setCSRField MEPC (regToZ_unsigned pc);;
    setCSRField MCauseCode (regToZ_unsigned exceptionCode);;
    setPC (ZToReg (addr * 4));;
    @endCycleEarly M t MM MW MP A.

  Definition raiseException{A: Type}(isInterrupt: t)(exceptionCode: t): M A :=
    raiseExceptionWithInfo isInterrupt exceptionCode (ZToReg 0).

  (* in a system with virtual memory, this would also do the translation, but in our
     case, we only verify the alignment *)
  Definition translate_with_alignment_check
    (accessType: AccessType)(alignment: t)(addr: t): M t :=
    if remu addr alignment /= ZToReg 0
    then raiseException (ZToReg 0) (ZToReg 4)
    else Return addr.

  Instance DefaultRiscvState: RiscvMachine := {|
    (* riscv does allow misaligned memory access (but might emulate them in software),
       so for the compiler-facing side, we don't do alignment checks, but might add
       another riscv machine layer below to emulate turn misaligned accesses into two
       aligned accesses *)
    translate accessType alignment := @Return M MM t;
    flushTLB := Return tt;
    (* platform specific CSRs that we don't support at the moment: *)
    getCSR_InstRet := raiseException (ZToReg 0) (ZToReg 2);
    getCSR_Time    := raiseException (ZToReg 0) (ZToReg 2);
    getCSR_Cycle   := raiseException (ZToReg 0) (ZToReg 2);
  |}.

End Riscv.

Notation Register0 := 0%Z (only parsing).

Arguments RiscvProgram: clear implicits.
Arguments RiscvProgram (M) (t) {_} {_}.
Arguments RiscvMachine: clear implicits.
Arguments RiscvMachine (M) (t) {_} {_} {_}.

#[global] Existing Instance DefaultRiscvState.


Require Export FSMG.

Section Free.

Definition FSMG_functor_fun {X Y : Type} {T_X : IsHSet X} {T_Y : IsHSet Y}
  (h : X -> Y)
  : FSMG X -> FSMG Y
  := FSMG_rec X (FSMG Y) e (iota o h) m alpha lambda rho tau pentagon triangle hexagon bigon T_FSMG.

Definition FSMG_functor_fun_alpha {X Y : Type} {T_X : IsHSet X} {T_Y : IsHSet Y}
  (h : X -> Y) (a b c : FSMG X)
  : ap (FSMG_functor_fun h) (alpha a b c) = alpha (FSMG_functor_fun h a) (FSMG_functor_fun h b) (FSMG_functor_fun h c)
  := @FSMG_rec_beta_alpha X (FSMG Y) e (iota o h) m alpha lambda rho tau pentagon triangle hexagon bigon T_FSMG a b c.
Definition FSMG_functor_fun_lambda {X Y : Type} {T_X : IsHSet X} {T_Y : IsHSet Y}
  (h : X -> Y) (b : FSMG X)
  : ap (FSMG_functor_fun h) (lambda b) = lambda (FSMG_functor_fun h b)
  := @FSMG_rec_beta_lambda X (FSMG Y) e (iota o h) m alpha lambda rho tau pentagon triangle hexagon bigon T_FSMG b.
Definition FSMG_functor_fun_rho {X Y : Type} {T_X : IsHSet X} {T_Y : IsHSet Y}
  (h : X -> Y) (a : FSMG X)
  : ap (FSMG_functor_fun h) (rho a) = rho (FSMG_functor_fun h a)
  := @FSMG_rec_beta_rho X (FSMG Y) e (iota o h) m alpha lambda rho tau pentagon triangle hexagon bigon T_FSMG a.
Definition FSMG_functor_fun_tau {X Y : Type} {T_X : IsHSet X} {T_Y : IsHSet Y}
  (h : X -> Y) (a b : FSMG X)
  : ap (FSMG_functor_fun h) (tau a b) = tau (FSMG_functor_fun h a) (FSMG_functor_fun h b)
  := @FSMG_rec_beta_tau X (FSMG Y) e (iota o h) m alpha lambda rho tau pentagon triangle hexagon bigon T_FSMG a b.

Definition FSMG_functor_arr
  : forall (X Y : Type) (T_X : IsHSet X) (T_Y : IsHSet Y), (X -> Y) -> SymMonoidalFunctor (FSMG_SMG X) (FSMG_SMG Y).
Proof.
  intros ???? h.
  srapply @Build_SymMonoidalFunctor.
  + exact (FSMG_functor_fun h).
  + constructor.
  + constructor.
  + intros; simpl.
    refine (concat_p1 _ @ _ @ (concat_1p _)^).
    exact (FSMG_functor_fun_alpha h a b c)^.
  + intros; simpl.
    refine (_ @ (concat_1p _)^).
    exact (FSMG_functor_fun_lambda h b)^.
  + intros; simpl.
    refine (_ @ (concat_1p _)^).
    exact (FSMG_functor_fun_rho h a)^.
  + intros; simpl.
    refine (concat_p1 _ @ _ @ (concat_1p _)^).
    exact (FSMG_functor_fun_tau h a b)^.
Defined.

Definition FSMG_functor_id
  : forall (X : Type) (T_X : IsHSet X),
    SymMonoidalNatIso (FSMG_functor_arr X X T_X T_X idmap) (SymMonoidalFunctor_id (FSMG_SMG X)).
Proof.
  intros; srapply @Build_SymMonoidalNatIso; simpl.
  + unfold pointwise_paths. srapply @FSMG_ind_to_paths_in_gpd; simpl.
    - constructor.
    - constructor.
    - intros ?? IHa IHb.
      exact (mm IHa IHb).
    - intros ??? IHa IHb IHc; simpl.
      refine (whiskerL _ (ap_idmap _) @ _ @ whiskerR (FSMG_functor_fun_alpha idmap a b c)^ _).
      exact (@alpha_natural (FSMG_SMG X) _ _ _ _ _ _ IHa IHb IHc)^.
    - intros ? IHb; simpl.
      refine (whiskerL _ (ap_idmap _) @ _ @ whiskerR (FSMG_functor_fun_lambda idmap b)^ _).
      exact (@lambda_natural (FSMG_SMG X) _ _ IHb)^.
    - intros ? IHa; simpl.
      refine (whiskerL _ (ap_idmap _) @ _ @ whiskerR (FSMG_functor_fun_rho idmap a)^ _).
      exact (@rho_natural (FSMG_SMG X) _ _ IHa)^.
    - intros ?? IHa IHb; simpl.
      refine (whiskerL _ (ap_idmap _) @ _ @ whiskerR (FSMG_functor_fun_tau idmap a b)^ _).
      exact (@tau_natural (FSMG_SMG X) _ _ _ _ IHa IHb)^.
    - exact T_FSMG.
  + constructor.
  + intros; simpl.
    refine (concat_1p _ @ (concat_p1 _)^).
Defined.

Definition FSMG_functor_comp
  : forall (X Y Z : Type) (T_X : IsHSet X) (T_Y : IsHSet Y) (T_Z : IsHSet Z) (g : Y -> Z) (f : X -> Y),
    SymMonoidalNatIso
      (SymMonoidalFunctor_comp (FSMG_functor_arr Y Z T_Y T_Z g) (FSMG_functor_arr X Y T_X T_Y f))
      (FSMG_functor_arr X Z T_X T_Z (fun x : X => g (f x))).
Proof.
  intros; srapply @Build_SymMonoidalNatIso; simpl.
  + unfold pointwise_paths. srapply @FSMG_ind_to_paths_in_gpd; simpl.
    - constructor.
    - constructor.
    - intros ?? IHa IHb.
      exact (mm IHa IHb).
    - abstract (intros ??? IHa IHb IHc; simpl;
      refine (_ @ whiskerR (ap_compose (FSMG_functor_fun f) (FSMG_functor_fun g) _)^ _);
      refine (whiskerL _ (FSMG_functor_fun_alpha (g o f) a b c) @ _);
      refine ((@alpha_natural (FSMG_SMG Z) _ _ _ _ _ _ IHa IHb IHc)^ @ _);
      exact (whiskerR ((FSMG_functor_fun_alpha g _ _ _)^ @ ap (ap (FSMG_functor_fun g)) (FSMG_functor_fun_alpha f a b c)^) _))
        using FSMG_functor_comp_alpha.
    - abstract (intros ? IHb; simpl;
      refine (_ @ whiskerR (ap_compose (FSMG_functor_fun f) (FSMG_functor_fun g) _)^ _);
      refine (whiskerL _ (FSMG_functor_fun_lambda (g o f) b) @ _);
      refine ((@lambda_natural (FSMG_SMG Z) _ _ IHb)^ @ _);
      exact (whiskerR ((FSMG_functor_fun_lambda g _)^ @ ap (ap (FSMG_functor_fun g)) (FSMG_functor_fun_lambda f b)^) _))
        using FSMG_functor_comp_lambda.
    - abstract (intros ? IHa; simpl;
      refine (_ @ whiskerR (ap_compose (FSMG_functor_fun f) (FSMG_functor_fun g) _)^ _);
      refine (whiskerL _ (FSMG_functor_fun_rho (g o f) a) @ _);
      refine ((@rho_natural (FSMG_SMG Z) _ _ IHa)^ @ _);
      exact (whiskerR ((FSMG_functor_fun_rho g _)^ @ ap (ap (FSMG_functor_fun g)) (FSMG_functor_fun_rho f a)^) _))
        using FSMG_functor_comp_rho.
    - abstract (intros ?? IHa IHb; simpl;
      refine (_ @ whiskerR (ap_compose (FSMG_functor_fun f) (FSMG_functor_fun g) _)^ _);
      refine (whiskerL _ (FSMG_functor_fun_tau (g o f) a b) @ _);
      refine ((@tau_natural (FSMG_SMG Z) _ _ _ _ IHa IHb)^ @ _);
      exact (whiskerR ((FSMG_functor_fun_tau g _ _)^ @ ap (ap (FSMG_functor_fun g)) (FSMG_functor_fun_tau f a b )^) _))
        using FSMG_functor_comp_tau.
    - exact T_FSMG.
  + constructor.
  + intros; simpl.
    refine (concat_1p _ @ (concat_p1 _)^).
Defined.

Definition FSMG_functor
  : IsFunctor_Sym (fun X T_X => FSMG_SMG X)
  := Build_IsFunctor_Sym _ FSMG_functor_arr FSMG_functor_id FSMG_functor_comp.

Definition phi {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
  (F : SymMonoidalFunctor (FSMG_SMG X) M)
  : X -> M
  := @smg_f _ _ F o iota.

Lemma phi_natural_M {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
  (F : SymMonoidalFunctor (FSMG_SMG X) M)
  {N : SymMonoidalGroupoid} (H : SymMonoidalFunctor M N)
  : H o phi F == phi (SymMonoidalFunctor_comp H F).
Proof.
  constructor.
Defined.

Definition psi_fun {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
  (f : X -> M)
  : FSMG X -> M
  := @FSMG_rec X M smg_e f smg_m smg_alpha smg_lambda smg_rho smg_tau smg_pentagon smg_triangle smg_hexagon smg_bigon smgtrunc.

Definition psi_fun_alpha {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
  (f : X -> M) (a b c : FSMG_SMG X)
  : ap (psi_fun f) (smg_alpha a b c) = smg_alpha (psi_fun f a) (psi_fun f b) (psi_fun f c)
  := FSMG_rec_beta_alpha X M smg_e f smg_m smg_alpha smg_lambda smg_rho smg_tau smg_pentagon smg_triangle smg_hexagon smg_bigon smgtrunc a b c.
Definition psi_fun_lambda {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
  (f : X -> M) (b : FSMG_SMG X)
  : ap (psi_fun f) (smg_lambda b) = smg_lambda (psi_fun f b)
  := FSMG_rec_beta_lambda X M smg_e f smg_m smg_alpha smg_lambda smg_rho smg_tau smg_pentagon smg_triangle smg_hexagon smg_bigon smgtrunc b.
Definition psi_fun_rho {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
  (f : X -> M) (a : FSMG_SMG X)
  : ap (psi_fun f) (smg_rho a) = smg_rho (psi_fun f a)
  := FSMG_rec_beta_rho X M smg_e f smg_m smg_alpha smg_lambda smg_rho smg_tau smg_pentagon smg_triangle smg_hexagon smg_bigon smgtrunc a.
Definition psi_fun_tau {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
  (f : X -> M) (a b : FSMG_SMG X)
  : ap (psi_fun f) (smg_tau a b) = smg_tau (psi_fun f a) (psi_fun f b)
  := FSMG_rec_beta_tau X M smg_e f smg_m smg_alpha smg_lambda smg_rho smg_tau smg_pentagon smg_triangle smg_hexagon smg_bigon smgtrunc a b.

Definition psi {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
  (f : X -> M)
  : SymMonoidalFunctor (FSMG_SMG X) M.
Proof.
  srapply @Build_SymMonoidalFunctor.
  + simpl. exact (psi_fun f).
  + constructor.
  + constructor.
  + intros; simpl.
    refine (concat_p1 _ @ _^ @ (concat_1p _)^).
    exact (psi_fun_alpha f a b c).
  + intros; simpl.
    refine (_^ @ (concat_1p _)^).
    exact (psi_fun_lambda f b).
  + intros; simpl.
    refine (_^ @ (concat_1p _)^).
    exact (psi_fun_rho f a).
  + intros; simpl.
    refine (concat_p1 _ @ _^ @ (concat_1p _)^).
    exact (psi_fun_tau f a b).
Defined.

  Lemma psi_natural_X_homotopy {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
    (f : X -> M)
    {Y : Type} {T_Y : IsHSet Y} (h : Y -> X)
    : SymMonoidalFunctor_comp (psi f) (FSMG_functor_arr Y X T_Y T_X h) == psi (f o h).
  Proof.
    simpl; unfold pointwise_paths.
    srefine (@FSMG_ind_to_paths_in_gpd Y M (psi f o FSMG_functor_fun h) (psi (f o h)) _ _ _ _ _ _ _ (@smgtrunc M)).
    + constructor.
    + constructor.
    + intros a b a' b'.
      change (smg_m ((psi f o FSMG_functor_fun h) a) ((psi f o FSMG_functor_fun h) b) = smg_m (psi (f o h) a) (psi (f o h) b)).
      exact (ap011 smg_m a' b').
    + hnf. intros.
      refine (_ @ whiskerR (ap_compose (FSMG_functor_fun h) (psi f) (alpha a b c))^ _).
      refine (whiskerL _ (psi_fun_alpha (f o h) a b c) @ _).
      refine (_ @ whiskerR (ap (ap (psi f)) (FSMG_functor_fun_alpha h a b c))^ _).
      refine (_ @ whiskerR (psi_fun_alpha f (FSMG_functor_fun h a) (FSMG_functor_fun h b) (FSMG_functor_fun h c))^ _).
      exact (alpha_natural a' b' c')^.
    + intros; hnf.
      refine (_ @ whiskerR (ap_compose (FSMG_functor_fun h) (psi f) (lambda b))^ _).
      refine (whiskerL _ (psi_fun_lambda (f o h) b) @ _).
      refine (_ @ whiskerR (ap (ap (psi f)) (FSMG_functor_fun_lambda h b))^ _).
      refine (_ @ whiskerR (psi_fun_lambda f (FSMG_functor_fun h b))^ _).
      exact (lambda_natural b')^.
    + intros; hnf.
      refine (_ @ whiskerR (ap_compose (FSMG_functor_fun h) (psi f) (rho a))^ _).
      refine (whiskerL _ (psi_fun_rho (f o h) a) @ _).
      refine (_ @ whiskerR (ap (ap (psi f)) (FSMG_functor_fun_rho h a))^ _).
      refine (_ @ whiskerR (psi_fun_rho f (FSMG_functor_fun h a))^ _).
      exact (rho_natural a')^.
    + hnf. intros.
      refine (_ @ whiskerR (ap_compose (FSMG_functor_fun h) (psi f) (tau a b))^ _).
      refine (whiskerL _ (psi_fun_tau (f o h) a b) @ _).
      refine (_ @ whiskerR (ap (ap (psi f)) (FSMG_functor_fun_tau h a b))^ _).
      refine (_ @ whiskerR (psi_fun_tau f (FSMG_functor_fun h a) (FSMG_functor_fun h b))^ _).
      exact (tau_natural a' b')^.
  Defined.

Lemma psi_natural_X {X : Type} {T_X : IsHSet X} {M : SymMonoidalGroupoid}
  (f : X -> M)
  {Y : Type} {T_Y : IsHSet Y} (h : Y -> X)
  : SymMonoidalNatIso (SymMonoidalFunctor_comp (psi f) (FSMG_functor_arr Y X T_Y T_X h)) (psi (f o h)).
Proof.
  srapply @Build_SymMonoidalNatIso.
  + exact (psi_natural_X_homotopy f h).
  + constructor.
  + intros; simpl.
    refine (concat_1p _ @ (concat_p1 _)^).
Defined.

Lemma theta (X : Type) (T_X : IsHSet X) (M : SymMonoidalGroupoid)
  : phi o psi == idmap.
Proof.
  constructor.
Defined.

  Lemma chi_homotopy_alpha (X : Type) (T_X : IsHSet X) (M : SymMonoidalGroupoid)
    (F : SymMonoidalFunctor (FSMG_SMG X) M)
    (a b c : FSMG X)
    (a' : psi_fun (phi F) a = F a)
    (b' : psi_fun (phi F) b = F b)
    (c' : psi_fun (phi F) c = F c)
    : (ap011 smg_m (ap011 smg_m a' b' @ @smg_f2 (FSMG_SMG X) M F a b) c' @ @smg_f2 (FSMG_SMG X) M F (m a b) c) @ ap F (alpha a b c)
      = ap (psi_fun (phi F)) (alpha a b c) @ (ap011 smg_m a' (ap011 smg_m b' c' @ @smg_f2 (FSMG_SMG X) M F b c) @ @smg_f2 (FSMG_SMG X) M F a (m b c)).
  Proof.
    refine (_ @ whiskerR (psi_fun_alpha (phi F) a b c)^ _).
    refine (whiskerR (whiskerR (ap011_pqp1 smg_m (ap011 smg_m a' b') (@smg_f2 (FSMG_SMG X) M F a b) c')^ _ @ concat_pp_p _ _ _) _ @ concat_pp_p _ _ _ @ _).
    refine (_ @ concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _ @ whiskerR (ap011_pq1q smg_m a' (ap011 smg_m b' c') (@smg_f2 (FSMG_SMG X) M F b c)) _)).
    refine (_ @ whiskerR (alpha_natural a' b' c')^ _).
    refine (_ @ concat_p_pp _ _ _); apply whiskerL;
    exact (@smg_dalpha _ _ F a b c)^.
  Qed.

  Lemma chi_homotopy_lambda (X : Type) (T_X : IsHSet X) (M : SymMonoidalGroupoid)
    (F : SymMonoidalFunctor (FSMG_SMG X) M)
    (b : FSMG X)
    (b' : psi_fun (phi F) b = F b)
    : (ap011 smg_m smg_f0 b' @ @smg_f2 (FSMG_SMG X) M F e b) @ ap F (lambda b) = ap (psi_fun (phi F)) (lambda b) @ b'.
  Proof.
    refine (_ @ whiskerR (psi_fun_lambda (phi F) b)^ _).
    refine (concat_pp_p _ _ _ @ whiskerR (ap011_1qp1 smg_m smg_f0 b')^ _ @ _).
    refine (concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _ @ (@smg_dlambda _ _ F b)^) @ _).
    exact (lambda_natural b')^.
  Qed.

  Lemma chi_homotopy_rho (X : Type) (T_X : IsHSet X) (M : SymMonoidalGroupoid)
    (F : SymMonoidalFunctor (FSMG_SMG X) M)
    (a : FSMG X)
    (a' : psi_fun (phi F) a = F a)
    : (ap011 smg_m a' smg_f0 @ @smg_f2 (FSMG_SMG X) M F a e) @ ap F (rho a) = ap (psi_fun (phi F)) (rho a) @ a'.
  Proof.
    refine (_ @ whiskerR (psi_fun_rho (phi F) a)^ _).
    refine (concat_pp_p _ _ _ @ whiskerR (ap011_p11q smg_m a' smg_f0)^ _ @ _).
    refine (concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _ @ (@smg_drho _ _ F a)^) @ _).
    exact (rho_natural a')^.
  Qed.

  Lemma chi_homotopy_tau (X : Type) (T_X : IsHSet X) (M : SymMonoidalGroupoid)
    (F : SymMonoidalFunctor (FSMG_SMG X) M)
    (a b : FSMG X)
    (a' : psi_fun (phi F) a = F a)
    (b' : psi_fun (phi F) b = F b)
    : (ap011 smg_m a' b' @ @smg_f2 (FSMG_SMG X) M F a b) @ ap F (tau a b)
      = ap (psi_fun (phi F)) (tau a b) @ (ap011 smg_m b' a' @ @smg_f2 (FSMG_SMG X) M F b a).
  Proof.
    refine (_ @ whiskerR (psi_fun_tau (phi F) a b)^ _).
    refine (concat_pp_p _ _ _ @ _ @ concat_p_pp _ _ _ @ whiskerR (tau_natural a' b')^ _ @ concat_pp_p _ _ _); apply whiskerL.
    exact (@smg_dtau _ _ F a b)^.
  Defined.

  Lemma chi_homotopy (X : Type) (T_X : IsHSet X) (M : SymMonoidalGroupoid)
    (F : SymMonoidalFunctor (FSMG_SMG X) M)
    : psi (phi F) == F.
  Proof.
    simpl; unfold pointwise_paths.
    srefine (@FSMG_ind_to_paths_in_gpd X M (psi_fun (phi F)) F _ _ _ _ _ _ _ smgtrunc).
    + change (smg_e = F e). exact smg_f0.
    + constructor.
    + intros a b a' b'. change (smg_m (psi_fun (phi F) a) (psi_fun (phi F) b) = F (m a b)).
      exact (ap011 smg_m a' b' @ @smg_f2 (FSMG_SMG X) M F a b).
    + intros; hnf.
      exact (chi_homotopy_alpha X T_X M F a b c a' b' c').
    + intros; hnf.
      exact (chi_homotopy_lambda X T_X M F b b').
    + intros; hnf.
      exact (chi_homotopy_rho X T_X M F a a').
    + intros; hnf.
      exact (chi_homotopy_tau X T_X M F a b a' b').
  Defined.

Lemma chi (X : Type) (T_X : IsHSet X) (M : SymMonoidalGroupoid)
  (F : SymMonoidalFunctor (FSMG_SMG X) M)
  : SymMonoidalNatIso (psi (phi F)) F.
Proof.
  srapply @Build_SymMonoidalNatIso.
  + apply chi_homotopy.
  + simpl. exact (concat_1p _).
  + intros; simpl. exact (concat_1p _).
Defined.

Lemma FSMG_FreeFunctor
  : IsFreeFunctor_Sym (fun X T_X => FSMG_SMG X).
Proof.
  exact (Build_IsFreeFunctor_Sym _ FSMG_functor (@phi) (@phi_natural_M) (@psi) (@psi_natural_X) (@theta) (@chi)).
Defined.

End Free.


(** Formalization of monads with a commutative sum operation to combine them.
    See StrongMonads.v for a better version. *)
Require Import String.

Set Implicit Arguments.

Class Monad : Type := {
  I : Type;
  O : Type;
  E : Type;
  M : Type -> Type :=
    fun A => I -> (A + E) * O;
  ret : forall A, A -> M A;
  bind : forall A B, M A -> (A -> M B) -> M B}.

Definition monadic_sum {m1 m2 : Monad} : Monad := {|
  I := @I m1 * @I m2;
  O := @O m1 * @O m2;
  E := @E m1 + @E m2;
  ret := fun _ x i =>
    let (i1, i2) := i in
    match (ret x i1, ret x i2) with
    | ((inl _, o1), (inl _, o2)) => (inl x, (o1, o2))
    | ((inl _, o1), (inr e2, o2)) => (inr (inr e2), (o1, o2))
    | ((inr e1, o1), (_, o2)) => (inr (inl e1), (o1, o2))
    end;
  bind := fun _ _ x f i =>
     match x i with
     | (inl x', (o1, o2)) =>
      let x1 := fun i1 =>
      end
     | (inr e, (o1, o2) => (inr e, (o1, o2))
     end |}.

Infix "·" := monadic_sum (at level 50, left associativity).

Instance Id : Monad := {
  I := unit;
  O := unit;
  E := Empty_set;
  ret := fun _ x _ => (inl x, tt)}.

Instance Option : Monad := {
  I := unit;
  O := unit;
  E := unit;
  ret := fun _ x _ => (inl x, tt)}.

Instance Error (E : Type) : Monad := {
  I := unit;
  O := unit;
  E := E;
  ret := fun _ x _ => (inl x, tt)}.

Instance Print : Monad := {
  I := unit;
  O := list string;
  E := Empty_set;
  ret := fun _ x _ => (inl x, nil)}.

Instance State (S : Type) : Monad := {
  I := S;
  O := S;
  E := Empty_set;
  ret := fun _ x s => (inl x, s)}.

Instance Loop : Monad := {
  I := nat;
  O := unit;
  E := unit;
  ret := fun _ x _ => (inl x, tt)}.


From Coq Require Import Arith.
From Coq Require Import Lia.

From Elo Require Import Util.
From Elo Require Import Array.
From Elo Require Import Core.
From Elo Require Import ValidAddresses.
From Elo Require Import Access.
From Elo Require Import References.
From Elo Require Import Soundness.
From Elo Require Import UnsafeAccess.
From Elo Require Import SafeSpawns.
From Elo Require Import SMS.

Theorem memory_value_multistep_preservation : forall m m' ths ths' tc,
  forall_memory m value ->
  m / ths ~~[tc]~~>* m' / ths' ->
  forall_memory m' value.
Proof.
  assert (forall t t' ad v Tr, t --[EF_Alloc ad v Tr]--> t' -> value v)
    by (intros; induction_step; eauto).
  assert (forall t t' ad v Tr, t --[EF_Write ad v Tr]--> t' -> value v)
    by (intros; induction_step; eauto).
  intros. induction_multistep; trivial. auto_specialize.
  inversion_cstep; trivial. inversion_mstep; trivial;
  (eapply forall_array_add || eapply forall_array_set); eauto using value.
Qed.

Theorem valid_addresses_multistep_preservation : forall m m' ths ths' tc,
  forall_program m ths (valid_addresses m) ->
  m / ths ~~[tc]~~>* m' / ths' ->
  forall_memory m' (valid_addresses m') /\
  forall_threads ths' (valid_addresses m').
Proof.
  intros * [? ?] Hmultistep. induction Hmultistep; eauto.
  destruct IHHmultistep; eauto; split;
  eauto using valid_addresses_term_preservation,
    valid_addresses_memory_preservation.
Qed.

Theorem well_typed_multistep_preservation : forall m m' ths ths' tc,
  forall_program m ths (valid_addresses m) ->
  (* --- *)
  forall_program m ths well_typed ->
  forall_program m ths (well_typed_references m) ->
  m / ths ~~[tc]~~>* m' / ths' ->
  forall_program m' ths' well_typed /\
    forall_program m' ths' (well_typed_references m') /\
    m' extends m.
Proof.
  (* TODO *)
Admitted.

Theorem safe_spawns_multistep_preservation : forall m m' ths ths' tc,
  forall_program m ths well_typed ->
  forall_program m ths (valid_addresses m) ->
  forall_program m ths (well_typed_references m) ->
  (* --- *)
  forall_program m ths SafeSpawns ->
  m / ths ~~[tc]~~>* m' / ths' ->
  forall_program m' ths' SafeSpawns.
Proof.
  intros * ? ? ? ? Hmultistep. induction Hmultistep; eauto.
  destruct IHHmultistep; eauto.
  eapply (safe_spawns_preservation m' m'' ths' ths''); eauto.
  eapply well_typed_multistep_preservation; eauto.
Qed.

Theorem safe_memory_sharing_multistep_preservation :
  forall m m' ths ths' tc,
    forall_memory m value ->
    forall_program m ths well_typed ->
    forall_program m ths (valid_addresses m) ->
    forall_program m ths (well_typed_references m) ->
    forall_program m ths SafeSpawns ->
    (* --- *)
    safe_memory_sharing m ths ->
    m / ths ~~[tc]~~>* m' / ths' ->
    safe_memory_sharing m' ths'.
Proof.
  intros * ? ? ? ? ? ? Hmultistep. induction Hmultistep; trivial.
  do 6 auto_specialize.
  eapply (safe_memory_sharing_preservation m' m'' ths' ths''); eauto.
  - eapply memory_value_multistep_preservation; eauto.
  - eapply well_typed_multistep_preservation; eauto.
  - eapply valid_addresses_multistep_preservation; eauto.
  - eapply well_typed_multistep_preservation; eauto.
  - eapply safe_spawns_multistep_preservation; eauto.
Qed.

(* ------------------------------------------------------------------------- *)
(*                                                                           *)
(* ------------------------------------------------------------------------- *)

Local Lemma acc_from_mem : forall m t ad ad' v Tr,
  valid_accesses m t ->
  ~ access m t ad ->
  access m[ad' <- (v, Tr)] t ad ->
  access m t ad'.
Proof.
  intros * ? Hnacc Hacc. eapply nacc_iff in Hnacc.
  induction Hnacc; try inversion_vac; inversion_acc; try lia;
  try (destruct (acc_dec m t ad'); eauto using access);
  try (destruct (acc_dec m t1 ad'));
  try solve [
    exfalso; eapply (mem_set_nacc1 _ _ ad ad'); eauto using vac_nacc_length
  ];
  try (destruct (acc_dec m t2 ad'); eauto using access);
  try solve [
    exfalso; eapply (mem_set_nacc1 _ _ ad ad'); eauto using vac_nacc_length
  ].
  destruct (Nat.eq_dec ad ad'); subst; eauto using access. simpl_array.
  match goal with _ : ~ access _ _ ?ad |- _ => rename ad into ad'' end.
  eapply acc_mem; eauto. destruct (acc_dec m m[ad].tm ad'); trivial. exfalso.
  eapply (mem_set_nacc1 _ _ ad'' ad'); eauto using vac_nacc_length.
Qed.

Local Lemma cstep_nacc_preservation : forall m m' ths ths' tid tid' ad eff,
  ad < #m ->
  tid < #ths ->
  forall_threads ths well_typed ->
  forall_threads ths (valid_accesses m) ->
  safe_memory_sharing m ths ->
  ~ access m ths[tid] ad ->
  m / ths ~~[tid', eff]~~> m' / ths' ->
  ~ access m' ths'[tid] ad.
Proof.
  intros * ? ? Htype ? Hsms. intros. rename ad into ad'.
  destruct (Htype tid'). inversion_clear_cstep;
  destruct (Nat.eq_dec tid tid'); subst; simpl_array;
  eauto using mstep_nacc_preservation, step_spawn_nacc_preservation.
  inversion_mstep; eauto using vac_nacc_length, mem_add_nacc. intros ?.
  eapply (Hsms tid' tid); eauto using step_write_requires_uacc, acc_from_mem.
Qed.

Lemma monotonic_nondecreasing_memory_length: forall m m' ths ths' tc,
  m / ths ~~[tc]~~>* m' / ths' ->
  #m <= #m'.
Proof.
  assert (forall m m' eff t t',
    m / t ==[eff]==> m' / t' ->
    #m <= #m'). {
    intros. inversion_mstep; try lia.
    - rewrite add_increments_length. lia.
    - eauto using Nat.eq_le_incl, set_preserves_length.
  }
  intros. induction_multistep; trivial. inversion_cstep; eauto.
  eauto using Nat.le_trans.
Qed.

Lemma monotonic_nondecreasing_threads_length: forall m m' ths ths' tc,
  m / ths ~~[tc]~~>* m' / ths' ->
  #ths <= #ths'.
Proof.
  intros. induction_multistep; trivial. inversion_cstep;
  try rewrite add_increments_length; rewrite set_preserves_length;
  eauto using Nat.le_trans.
Qed.

Theorem not_access_multistep_preservation : forall m m' ths ths' tid ad tc,
  ad < #m ->
  tid < #ths ->
  forall_memory m value ->
  forall_program m ths well_typed ->
  forall_program m ths (valid_addresses m) ->
  forall_program m ths (well_typed_references m) ->
  forall_program m ths SafeSpawns ->
  safe_memory_sharing m ths ->
  (* --- *)
  ~ access m ths[tid] ad ->
  m / ths ~~[tc]~~>* m' / ths' ->
  ~ access m' ths'[tid] ad.
Proof.
  intros. induction H8; trivial. do 9 auto_specialize.
  eapply (cstep_nacc_preservation m' _ ths'); eauto.
  - eauto using monotonic_nondecreasing_memory_length, Nat.le_trans.
  - eauto using monotonic_nondecreasing_threads_length, Nat.le_trans.
  - eapply well_typed_multistep_preservation; eauto.
  - eapply forall_threads_vad_then_vac;
    eapply valid_addresses_multistep_preservation; eauto.
  - eapply safe_memory_sharing_multistep_preservation; eauto.
Qed.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (plus Zero (mult lv0 lv1))).
Admitted.
QuickChick conj8eqsynthconj1.


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

Require Import Reals.
Require Import trajectory_const.
Require Import trajectory_def.
Require Import constants.
Require Import ails_def.
Require Import Omega.

Lemma cond1_sty :
 forall (tr : Trajectory) (t : R), (- toDeg MaxBank <= toDeg (phi tr t))%R.
Proof with trivial.
intros; unfold toDeg in |- *; repeat rewrite Rmult_assoc;
 rewrite <- Ropp_mult_distr_l_reverse; rewrite (Rmult_comm (- MaxBank));
 rewrite (Rmult_comm (phi tr t)); apply Rmult_le_compat_l...
left; apply Rmult_lt_0_compat...
unfold plat in |- *; prove_sup0...
apply Rinv_0_lt_compat; apply PI_RGT_0...
generalize (cond_phi tr); intro H; elim (H t)...
Qed.

Lemma cond2_sty :
 forall (tr : Trajectory) (t : R), (toDeg (phi tr t) <= toDeg MaxBank)%R.
Proof with trivial.
intros; unfold toDeg in |- *; repeat rewrite Rmult_assoc;
 rewrite (Rmult_comm MaxBank); rewrite (Rmult_comm (phi tr t));
 apply Rmult_le_compat_l...
left; apply Rmult_lt_0_compat...
unfold plat in |- *; prove_sup...
apply Rinv_0_lt_compat; apply PI_RGT_0...
generalize (cond_phi tr); intro H; elim (H t)...
Qed.

Definition measure2state (tr : Trajectory) (t : R) : State :=
  mkState (x tr t) (y tr t) (toDeg (theta tr t))
    (mkBank (toDeg (phi tr t)) (cond1_sty tr t) (cond2_sty tr t)).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: LegacyField.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Export LegacyField_Compl.
Require Export LegacyField_Theory.
Require Export LegacyField_Tactic.
Declare ML Module "field_plugin".

(* Command declarations are moved to the ML side *)


From SSL_Iris Require Import core.
From iris.heap_lang Require Import lang notation proofmode.
From iris_string_ident Require Import ltac2_string_ident.
Section common.
Context `{!heapG Σ}.
Inductive sll_card : Set :=
    | sll_card_0 : sll_card
    | sll_card_1 : sll_card -> sll_card.

Fixpoint sll (x: loc) (s: (list Z)) (self_card: sll_card) { struct self_card } : iProp Σ := match self_card with
    | sll_card_0  => ⌜(x = null_loc) ∧ (s = [])⌝
    | sll_card_1 _alpha_543 => ∃ (v : Z) (s1 : (list Z)) (nxt : loc), ⌜~ (x = null_loc) ∧ (s = ([v] ++ s1))⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #nxt ∗ (sll nxt s1 _alpha_543)
end.

Global Opaque sll.

Inductive treeN_card : Set :=
    | treeN_card_0 : treeN_card
    | treeN_card_2 : treeN_card -> treeN_card -> treeN_card.

Fixpoint treeN (x: loc) (n: Z) (self_card: treeN_card) { struct self_card } : iProp Σ := match self_card with
    | treeN_card_0  => ⌜(x = null_loc) ∧ (n = 0)⌝
    | treeN_card_2 _alpha_542 _alpha_541 => ∃ (n1 : Z) (n2 : Z) (v : loc) (l : loc) (r : loc), ⌜~ (x = null_loc) ∧ (0 ≤ n1)%Z ∧ (0 ≤ n2)%Z ∧ (n = ((1 + n1)%Z + n2)%Z)⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #l ∗ (x +ₗ 2) ↦ #r ∗ (treeN l n1 _alpha_541) ∗ (treeN r n2 _alpha_542)
end.

Global Opaque treeN.

Inductive tree_card : Set :=
    | tree_card_0 : tree_card
    | tree_card_2 : tree_card -> tree_card -> tree_card.

Fixpoint tree (x: loc) (s: (list Z)) (self_card: tree_card) { struct self_card } : iProp Σ := match self_card with
    | tree_card_0  => ⌜(x = null_loc) ∧ (s = [])⌝
    | tree_card_2 _alpha_540 _alpha_539 => ∃ (v : Z) (s1 : (list Z)) (s2 : (list Z)) (l : loc) (r : loc), ⌜~ (x = null_loc) ∧ (s = (([v] ++ s1) ++ s2))⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #l ∗ (x +ₗ 2) ↦ #r ∗ (tree l s1 _alpha_539) ∗ (tree r s2 _alpha_540)
end.

Global Opaque tree.

Lemma sll_card_0_learn (x: loc) (s: (list Z)) self_card:
sll x s self_card  ⊢ sll x s self_card ∗ ⌜(x = null_loc) -> self_card = sll_card_0⌝.
Proof.
Transparent sll.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (v s1 nxt) "((% & %) & (? & ? & ? & ?))".
   iSplitL.
   iExists v, s1, nxt. iFrame. eauto.
   eauto.
Global Opaque sll.
Qed.

Lemma sll_card_1_learn (x: loc) (s: (list Z)) self_card:
sll x s self_card  ⊢ sll x s self_card ∗ ⌜~ (x = null_loc) -> ∃ _alpha_543, self_card = (sll_card_1 _alpha_543)⌝.
Proof.
Transparent sll.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (v s1 nxt) "((% & %) & (? & ? & ? & ?))".
   iSplitL.
   iExists v, s1, nxt. iFrame. eauto.
   eauto.
Global Opaque sll.
Qed.

Lemma sll_card_0_open  (x: loc) (s: (list Z)) :
sll x s (sll_card_0 ) = (⌜(x = null_loc) ∧ (s = [])⌝)%I.
Proof. auto. Qed.

Lemma sll_card_1_open (_alpha_543 : sll_card) (x: loc) (s: (list Z)) :
sll x s (sll_card_1 _alpha_543) = (∃ (v : Z) (s1 : (list Z)) (nxt : loc), ⌜~ (x = null_loc) ∧ (s = ([v] ++ s1))⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #nxt ∗ (sll nxt s1 _alpha_543))%I.
Proof. auto. Qed.

Lemma treeN_card_0_learn (x: loc) (n: Z) self_card:
treeN x n self_card  ⊢ treeN x n self_card ∗ ⌜(x = null_loc) -> self_card = treeN_card_0⌝.
Proof.
Transparent treeN.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (n1 n2 v l r) "((% & % & % & %) & (? & ? & ? & ? & ? & ?))".
   iSplitL.
   iExists n1, n2, v, l, r. iFrame. eauto.
   eauto.
Global Opaque treeN.
Qed.

Lemma treeN_card_2_learn (x: loc) (n: Z) self_card:
treeN x n self_card  ⊢ treeN x n self_card ∗ ⌜~ (x = null_loc) -> ∃ _alpha_542 _alpha_541, self_card = (treeN_card_2 _alpha_542 _alpha_541)⌝.
Proof.
Transparent treeN.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (n1 n2 v l r) "((% & % & % & %) & (? & ? & ? & ? & ? & ?))".
   iSplitL.
   iExists n1, n2, v, l, r. iFrame. eauto.
   eauto.
Global Opaque treeN.
Qed.

Lemma treeN_card_0_open  (x: loc) (n: Z) :
treeN x n (treeN_card_0 ) = (⌜(x = null_loc) ∧ (n = 0)⌝)%I.
Proof. auto. Qed.

Lemma treeN_card_2_open (_alpha_542 : treeN_card) (_alpha_541 : treeN_card) (x: loc) (n: Z) :
treeN x n (treeN_card_2 _alpha_542 _alpha_541) = (∃ (n1 : Z) (n2 : Z) (v : loc) (l : loc) (r : loc), ⌜~ (x = null_loc) ∧ (0 ≤ n1)%Z ∧ (0 ≤ n2)%Z ∧ (n = ((1 + n1)%Z + n2)%Z)⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #l ∗ (x +ₗ 2) ↦ #r ∗ (treeN l n1 _alpha_541) ∗ (treeN r n2 _alpha_542))%I.
Proof. auto. Qed.

Lemma tree_card_0_learn (x: loc) (s: (list Z)) self_card:
tree x s self_card  ⊢ tree x s self_card ∗ ⌜(x = null_loc) -> self_card = tree_card_0⌝.
Proof.
Transparent tree.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (v s1 s2 l r) "((% & %) & (? & ? & ? & ? & ? & ?))".
   iSplitL.
   iExists v, s1, s2, l, r. iFrame. eauto.
   eauto.
Global Opaque tree.
Qed.

Lemma tree_card_2_learn (x: loc) (s: (list Z)) self_card:
tree x s self_card  ⊢ tree x s self_card ∗ ⌜~ (x = null_loc) -> ∃ _alpha_540 _alpha_539, self_card = (tree_card_2 _alpha_540 _alpha_539)⌝.
Proof.
Transparent tree.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (v s1 s2 l r) "((% & %) & (? & ? & ? & ? & ? & ?))".
   iSplitL.
   iExists v, s1, s2, l, r. iFrame. eauto.
   eauto.
Global Opaque tree.
Qed.

Lemma tree_card_0_open  (x: loc) (s: (list Z)) :
tree x s (tree_card_0 ) = (⌜(x = null_loc) ∧ (s = [])⌝)%I.
Proof. auto. Qed.

Lemma tree_card_2_open (_alpha_540 : tree_card) (_alpha_539 : tree_card) (x: loc) (s: (list Z)) :
tree x s (tree_card_2 _alpha_540 _alpha_539) = (∃ (v : Z) (s1 : (list Z)) (s2 : (list Z)) (l : loc) (r : loc), ⌜~ (x = null_loc) ∧ (s = (([v] ++ s1) ++ s2))⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #l ∗ (x +ₗ 2) ↦ #r ∗ (tree l s1 _alpha_539) ∗ (tree r s2 _alpha_540))%I.
Proof. auto. Qed.

End common.


(** This file contains all of Coq's default logical types and a few basic things
related to them.  Because we pass -nois to the compiler, we need to explicitly
export these things to be able to use them.  However, I don't like a lot of the
names that Coq made for them, so I give a bunch of new names here. *)

Require Coq.Init.Logic.
Require Export Coq.Init.Ltac.
Require Export Coq.Init.Notations.
(* Even though we never use it, not requiring this makes things break? *)
Require Utf8.

Require Export notations.

Set Implicit Arguments.

Notation "x → y" := (forall (_ : x), y)
  (at level 99, y at level 200, right associativity): type_scope.

Notation "'equal'" := Coq.Init.Logic.eq.
Export Coq.Init.Logic (ex).
Export Coq.Init.Logic (ex_intro).
Export Coq.Init.Logic (iff).
Export Coq.Init.Logic (not).
Export Coq.Init.Logic (inhabits).
Export Coq.Init.Logic (inhabited).
Export Coq.Init.Logic (all).
Export Coq.Init.Logic (f_equal).
Export Coq.Init.Logic (f_equal2).
Export Coq.Init.Logic (f_equal3).
Export Coq.Init.Logic (f_equal4).

Export Coq.Init.Logic (True).
Definition true := Coq.Init.Logic.I.
Export Coq.Init.Logic (False).
Export Coq.Init.Logic (False_rect).

Export Coq.Init.Logic (and).
Notation "'make_and'" := Coq.Init.Logic.conj.
Notation "A ∧ B" := (and A B).

Section Conjunction.

  Variables A B : Prop.

  Theorem land : A ∧ B → A.
  Proof.
    destruct 1; trivial.
  Qed.

  Theorem rand : A ∧ B → B.
  Proof.
    destruct 1; trivial.
  Qed.

End Conjunction.

Export Coq.Init.Logic (or).
Notation "'make_lor'" := Coq.Init.Logic.or_introl.
Notation "'make_ror'" := Coq.Init.Logic.or_intror.
Notation "A ∨ B" := (or A B) : type_scope.

Notation "A ↔ B" := (iff A B) : type_scope.
Notation "¬ x" := (not x) : type_scope.
Notation "x = y" := (equal x y) : type_scope.
Notation "x ≠ y" := (¬ (x = y)) : type_scope.

Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.

(* Logic *)
Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[  ' '[  ' ∀  x  ..  y ']' ,  '/' P ']'") : type_scope.
Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[  ' '[  ' ∃  x  ..  y ']' ,  '/' P ']'") : type_scope.

(* Abstraction *)
Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[  ' '[  ' 'λ'  x  ..  y ']' ,  '/' t ']'").

#[universes(template)]
Inductive ex_type (A : Type) (P : A → Prop) : Type :=
    ex_type_constr : ∀ x : A, P x → ex_type P.

Inductive strong_or (A B : Prop) : Set :=
    | strong_or_left : A → {A} + {B}
    | strong_or_right : B → {A} + {B}
where "{ A } + { B }" := (strong_or A B).

Arguments strong_or_left {A B} _, [A] B _.
Arguments strong_or_right {A B} _ , A [B] _.

#[universes(template)]
Inductive semi_or (A:Type) (B:Prop) : Type :=
  | semi_or_left : A → A + {B}
  | semi_or_right : B → A + {B}
 where "A + { B }" := (semi_or A B).

Arguments semi_or_left {A B} _ , [A] B _.
Arguments semi_or_right {A B} _ , A [B] _.


(** The contents of this file will be either integrated with Cert.v or moved elsewhere. *)

From iVM Require Import DSet Mono.
Import DSetNotations.

Unset Suggest Proof Using.

Open Scope vector.

(* TODO: Place inside section or module. *)
Import OpCodes.

Open Scope Z.

(***)

Lemma next_1_helper (op: Z) (Hop: 0 <= op < 256) :
  (Vector.map toB8 [op] : Bytes 1) = Z.to_N op :> N.
Proof.
  simp map.
  remember (toB8 op) as u eqn:Hu.
  dependent elimination u as [[b0; b1; b2; b3; b4; b5; b6; b7]].
  simp bytesToBits. simpl. rewrite Hu.
  unfold bitsToN. f_equal.
  apply fromBits_toBits. cbn. lia.
Qed.

Lemma step_match_helper (op: Z) (Hop: 0 <= op < 256) :
  Z.of_N (bitsToN (bytesToBits (cells_to_bytes (Vector.map toB8 [op])))) = op.
Proof.
  unfold cells_to_bytes, id.
  rewrite next_1_helper;
    [ rewrite Z2N.id | ];
    lia.
Qed.

Proposition shiftin_spec [X n] [x: X] [u: vector X n] (H: (n + 1 = S n)%nat) :
  shiftin x u = rew H in (u ++ [x]).
Proof.
  induction u.
  - revert H. apply EqDec.UIP_K. reflexivity.
  - cbn in *.
    set (HH := Nat.succ_inj _ _ H). rewrite (rew_cons HH).
    f_equal. exact (IHu HH).
Qed.

(** We would have preferred to call this [shiftout_shiftin], but we stick
to the same naming pattern of VectorSpec. *)

Proposition shiftin_shiftout
            [X n] (x: X) (u: vector X n) :
  shiftout (shiftin x u) = u.
Proof.
  induction u.
  - reflexivity.
  - cbn. rewrite IHu. reflexivity.
Qed.

Proposition last_shiftout_shifting [X n] (u: vector X (S n)) :
  shiftin (Vector.last u) (shiftout u) = u.
Proof.
  induction n.
  - dependent elimination u as [[x]]. reflexivity.
  - dependent elimination u as [x :: u].
    cbn. f_equal. exact (IHn u).
Qed.

(** Cf. [List.rev_ind]. *)
Proposition vec_rev_ind
            [A : Type]
            (P : forall {n}, vector A n -> Prop)
            (H_nil: P [])
            (H_cons: forall {n} (u: vector A n) x, P u -> P (shiftin x u))
            {n} (u: vector A n) : P u.
Proof.
  induction n.
  - dependent elimination u. exact H_nil.
  - specialize (H_cons n (shiftout u) (Vector.last u) (IHn (shiftout u))).
    rewrite last_shiftout_shifting in H_cons. exact H_cons.
Qed.

Corollary vec_rev_ind'
          [A : Type]
          (P : forall {n}, vector A n -> Prop)
          (H_nil: P [])
          (H_cons: forall {n} (u: vector A n) x, P u -> P (u ++ [x]))
          {n} (u: vector A n) : P u.
Proof.
  induction u using vec_rev_ind.
  - exact H_nil.
  - set (H := Nat.add_1_r n).
    rewrite (shiftin_spec H).
    destruct H.
    exact (H_cons n u x IHu).
Qed.

(***)

Instance chain_propr : PropR chain.
Proof.
  intros u u' Hu v v' Hv.
  unfold chain.
  apply (bind_propr _ _ _).
  - exact Hu.
  - intros x x' Hx.
    cbv in Hx.
    subst x.
    destruct x'.
    + exact Hv.
    + crush.
Qed.

Proposition id_equation_1 X (x: X) : id x = x.
Proof. reflexivity. Qed.

(** * Certified programs *)

Definition Cert (spec: M bool) :=
  exists (f: State -> nat), spec ⊑ let* s := get in
                           nSteps (f s).

(** In most cases we know exactly how many steps are needed. *)
Definition nCert n (spec: M bool) := spec ⊑ nSteps n.

Proposition nCert_is_Cert n (spec: M bool) : nCert n spec -> Cert spec.
Proof.
  unfold nCert, Cert.
  intros H.
  exists (fun _ => n).
  smon_rewrite.
  exact H.
Qed.

Local Notation not_terminated := (ret true) (only parsing).
Local Notation terminated := (ret false) (only parsing).

Lemma cert_id : nCert 0 not_terminated.
Proof.
  unfold nCert.
  simp nSteps.
  crush.
Qed.

Lemma ncert_comp m n (u: M bool) {Cu: nCert m u} (v: M bool) {Cv: nCert n v} :
  nCert (m + n) (chain u v).
Proof.
  unfold nCert in *.
  rewrite nSteps_action.
  apply chain_propr.
  - exact Cu.
  - exact Cv.
Qed.

Definition nCertN n {X} (mx: M X) := nCert n (mx;; not_terminated).

(** *** Asserting next operations and move PC *)

Definition swallow1 (op: Z) : M unit :=
  let* pc := get' PC in
  let* x := load pc in
  assume' (x = toB8 op);;
  put' PC (offset 1 pc).

Equations swallow {n} (ops: vector Z n) : M unit :=
  swallow [] := ret tt;
  swallow (op :: rest) :=
    swallow1 op;;
    swallow rest.

(* TODO: Move *)
Lemma assume_cons' {A} (EA: EqDec A) (a a': A) n (u u': vector A n) {X} (mx: M X) :
  assume' (a :: u = a' :: u');;
  mx = assume' (a = a');;
       assume' (u = u');;
       mx.
  Proof.
    repeat setoid_rewrite <- simplify_assume.
    apply assume_cons.
  Qed.

Lemma swallow_spec {n} (ops: vector Z n) :
  swallow ops = let* pc := get' PC in
                let* u := loadMany n pc in
                assume' (u = Vector.map toB8 ops);;
                put' PC (offset n pc).
Proof.
  (* TODO: Simplify *)
  induction n.
  - dependent elimination ops.
    simp swallow map.
    simp_loadMany.
    unfold offset.
    smon_rewrite. setoid_rewrite toBits_ofN_bitsToN.
    smon_rewrite.
  - dependent elimination ops as [ @Vector.cons z n ops ].
    simp swallow map. unfold swallow1. rewrite IHn.
    simp_loadMany.
    smon_rewrite.

    apply bind_extensional. intros pc.
    apply bind_extensional. intros op.

    do 3 setoid_rewrite postpone_assume'.
    smon_rewrite.
    setoid_rewrite <- confined_put;
      [ | apply (confined_neutral (m':=MEM));
          typeclasses eauto ].

    apply bind_extensional. intros u.
    simpl Vector.map.

    unfold Cells. (* TODO: How can we avoid having to remember this everywhere? *)
    setoid_rewrite assume_cons'.
    destruct (decide (op = toB8 z)) as [Hop|Hop]; [ | smon_rewrite ].
    subst op.
    destruct (decide _) as [Hu|Hu]; [ | smon_rewrite ].
    subst u.
    smon_rewrite.
    setoid_rewrite <- Z_action_add.
    do 2 f_equal.
    lia.
Qed.

Instance confined_swallow {n} (ops: vector Z n) :
  Confined (MEM * PC) (swallow ops).
Proof.
  rewrite swallow_spec.
  typeclasses eauto.
Qed.

Lemma swallow_action {m n} (o1: vector Z m) (o2: vector Z n) :
  swallow (o1 ++ o2) = swallow o1;; swallow o2.
Proof.
  induction m.
  - dependent elimination o1.
    simp swallow.
    smon_rewrite.
  - dependent elimination o1 as [ @Vector.cons x m o1 ].
    simpl (swallow _).
    simp swallow.
    rewrite (IHm o1).
    rewrite bind_assoc.
    reflexivity.
Qed.

Instance swallow_propr {n} (ops: vector Z n) : PropR (swallow ops).
Proof.
  rewrite swallow_spec.
  crush.
Qed.

Proposition swallow1' (op: Z) n (ops: vector Z n) :
  swallow (op :: ops) = swallow ([op] ++ ops).
Proof.
  reflexivity.
Qed.

Lemma swallow_lemma {n} {ops: vector Z n} {X} {u: M X} {f: Bytes n -> M X} :
  u ⊑ f (Vector.map toB8 ops) -> swallow ops;; u ⊑ next n >>= f.
Proof.
  intros H.
  repeat setoid_rewrite bind_assoc.
  revert ops u f H.
  induction n; intros ops u f H; simp next.
  - dependent elimination ops. simp swallow.
    setoid_rewrite ret_bind. exact H.
  - dependent elimination ops as [Vector.cons (n:=n) x r].
    simp swallow.
    unfold swallow1.
    repeat setoid_rewrite bind_assoc.
    crush.
    smon_rewrite.
    subst.
    exact (IHn r u (fun v => f (toB8 x :: v)) H).
Qed.

Proposition swallow_equation_3 (n : nat) (z : Z) (u : vector Z n) :
  swallow (shiftin z u) = swallow u;;
                          swallow1 z.
Proof.
  set (H := Nat.add_1_r n).
  rewrite (shiftin_spec H).
  destruct H. cbn.
  rewrite swallow_action. simp swallow.
  setoid_rewrite bind_ret_tt.
  reflexivity.
Qed.

Hint Rewrite swallow_equation_3 : swallow.

(** ** EXIT *)

Ltac cert_start :=
  unfold nCert;
  simp nSteps;
  unfold chain, oneStep;
  repeat setoid_rewrite bind_assoc;
  apply swallow_lemma;
  setoid_rewrite next_1_helper; [ | lia ];
  try (unfold cells_to_bytes, id;
       rewrite next_1_helper; try lia);
  simpl;
  repeat rewrite ret_bind;
  crush.

Proposition cert_EXIT : nCert 1 (swallow [EXIT];;
                           terminated).
Proof. cert_start. Qed.

Proposition cert_NOP : nCertN 1 (swallow [NOP]).
Proof. unfold nCertN. cert_start. Qed.

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

Proposition andb_spec (x y: bool) : x && y <-> x /\ y.
Proof.
  destruct x, y; now cbn.
Qed.

Proposition Is_true_spec (b: bool) : b <-> b = true.
Proof.
  destruct b; now cbn.
Qed.

Proposition ltb_spec (x y: Z) : x <? y <-> x < y.
Proof.
  rewrite Is_true_spec, Z.ltb_lt. tauto.
Qed.

Notation isStdOp op := (0 < op < 256).

Proposition isStdOp_toB8 {op} (Hop: isStdOp op) : toB8 op = op :> Z.
Proof.
  rewrite ofN_bitsToN.
  apply fromBits_toBits.
  lia.
Qed.

Proposition isStdOp_match0 {op} (Hop: isStdOp op) {X} (u v: X) :
  match op with 0 => u | _ => v end = v.
Proof.
  now destruct op.
Qed.

(** ** Not exit *)

(* TODO: Expand and maybe move *)
Ltac binary_simpl_tac :=
  unfold cells_to_bytes;
  try simp map;
  try rewrite id_equation_1;
  try rewrite bytesToBits_equation_3.

Lemma swallow_step_lemma n op n' (ops: vector Z n') mb
    (Hop: isStdOp op)
    (H: swallow ops;; mb ⊑ oneStep' op;; nSteps n) :
  nCert (S n) (swallow (op :: ops);; mb).
Proof.
  unfold nCert.
  simp nSteps.
  unfold chain.
  unfold oneStep.
  rewrite swallow1'.
  rewrite swallow_action.
  smon_rewrite.
  apply swallow_lemma.
  simp map.

  binary_simpl_tac.
  setoid_rewrite (isStdOp_toB8 Hop).
  setoid_rewrite (isStdOp_match0 Hop).
  smon_rewrite.
  setoid_rewrite (isStdOp_toB8 Hop).
  exact H.
Qed.

Corollary swallow_step_lemma' n op mb
    (Hop: isStdOp op)
    (H: mb ⊑ oneStep' op;; nSteps n) :
  nCert (S n) (swallow [op];; mb).
Proof.
  apply swallow_step_lemma; [ exact Hop | ].
  simp swallow.
  smon_rewrite.
  exact H.
Qed.

Corollary swallow_step_lemma_N n op n' (ops: vector Z n') X (mx: M X)
  (Hop: isStdOp op)
  (H: (swallow ops;; mx);; not_terminated ⊑ oneStep' op;; nSteps n) :
  nCertN (S n) (swallow (op :: ops);; mx).
Proof.
  unfold nCertN. revert H.
  smon_rewrite. intros H.
  apply swallow_step_lemma; assumption.
Qed.

Corollary swallow_step_lemma_N' n op X (mx: M X)
  (Hop: isStdOp op)
  (H: mx;; not_terminated ⊑ oneStep' op;; nSteps n) :
  nCertN (S n) (swallow [op];; mx).
Proof.
  apply swallow_step_lemma_N; [ exact Hop | ].
  simp swallow.
  smon_rewrite.
  exact H.
Qed.

Ltac swallow1_tac :=
  unfold nCertN;
  apply swallow_step_lemma_N';
  [ lia | ];
  simp nSteps;
  apply (bind_propr _ _ _);
  [ simp oneStep' |  ];
  crush.

(** ** Instructions with no operands *)

Proposition cert_JUMP : nCertN 1 (
  swallow [JUMP];;
  let* a := pop64 in
  put' PC a).
Proof. swallow1_tac. Qed.

Proposition cert_SET_SP : nCertN 1 (
  swallow [SET_SP];;
  let* a := pop64 in
  put' SP a).
Proof. swallow1_tac. Qed.

Proposition cert_GET_PC : nCertN 1 (
  swallow [GET_PC];;
  let* a := get' PC in
  pushZ a).
Proof. swallow1_tac. Qed.

Proposition cert_GET_SP : nCertN 1 (
  swallow [GET_SP];;
  let* a := get' SP in
  pushZ a).
Proof. swallow1_tac. Qed.

(* For the other push instructions, see below. *)
Proposition cert_PUSH0 : nCertN 1 (
  swallow [PUSH0];;
  pushZ 0).
Proof. swallow1_tac. Qed.

Proposition cert_LOAD1 : nCertN 1 (
  swallow [LOAD1];;
  let* a := pop64 in
  let* x := loadMany 1 a in
  pushZ x).
Proof. swallow1_tac. Qed.

Proposition cert_LOAD2 : nCertN 1 (
  swallow [LOAD2];;
  let* a := pop64 in
  let* x := loadMany 2 a in
  pushZ x).
Proof. swallow1_tac. Qed.

Proposition cert_LOAD4 : nCertN 1 (
  swallow [LOAD4];;
  let* a := pop64 in
  let* x := loadMany 4 a in
  pushZ x).
Proof. swallow1_tac. Qed.

Proposition cert_LOAD8 : nCertN 1 (
  swallow [LOAD8];;
  let* a := pop64 in
  let* x := loadMany 8 a in
  pushZ x).
Proof. swallow1_tac. Qed.

Proposition cert_STORE1 : nCertN 1 (
  swallow [STORE1];;
  let* a := pop64 in
  let* x := pop64 in
  storeZ 1 a x).
Proof. swallow1_tac. Qed.

Proposition cert_STORE2 : nCertN 1 (
  swallow [STORE2];;
  let* a := pop64 in
  let* x := pop64 in
  storeZ 2 a x).
Proof. swallow1_tac. Qed.

Proposition cert_STORE4 : nCertN 1 (
  swallow [STORE4];;
  let* a := pop64 in
  let* x := pop64 in
  storeZ 4 a x).
Proof. swallow1_tac. Qed.

Proposition cert_STORE8 : nCertN 1 (
  swallow [STORE8];;
  let* a := pop64 in
  let* x := pop64 in
  storeZ 8 a x).
Proof. swallow1_tac. Qed.

Proposition cert_ADD : nCertN 1 (
  swallow [ADD];;
  let* x := pop64 in
  let* y := pop64 in
  pushZ (x + y)).
Proof. swallow1_tac. Qed.

Proposition cert_MULT : nCertN 1 (
  swallow [MULT];;
  let* x := pop64 in
  let* y := pop64 in
  pushZ (x * y)).
Proof. swallow1_tac. Qed.

Proposition cert_DIV : nCertN 1 (
  swallow [DIV];;
  let* x := pop64 in
  let* y := pop64 in
  pushZ (if decide (x = 0 :> Z) then 0 else y / x)).
Proof. swallow1_tac. Qed.

Proposition cert_REM : nCertN 1 (
  swallow [REM];;
  let* x := pop64 in
  let* y := pop64 in
  pushZ (if decide (x = 0 :> Z) then 0 else y mod x)).
Proof. swallow1_tac. Qed.

Proposition cert_LT : nCertN 1 (
  swallow [LT];;
  let* x := pop64 in
  let* y := pop64 in
  pushZ (if decide (y < x) then -1 else 0)).
Proof. swallow1_tac. Qed.

Proposition cert_AND : nCertN 1 (
  swallow [AND];;
  let* x := pop64 in
  let* y := pop64 in
  pushZ (Vector.map2 andb x y : B64)).
Proof. swallow1_tac. Qed.

Proposition cert_OR : nCertN 1 (
  swallow [OR];;
  let* x := pop64 in
  let* y := pop64 in
  pushZ (Vector.map2 orb x y : B64)).
Proof. swallow1_tac. Qed.

Proposition cert_NOT : nCertN 1 (
  swallow [NOT];;
  let* x := pop64 in
  pushZ (Vector.map negb x : B64)).
Proof. swallow1_tac. Qed.

Proposition cert_XOR : nCertN 1 (
  swallow [XOR];;
  let* x := pop64 in
  let* y := pop64 in
  pushZ (Vector.map2 xorb x y : B64)).
Proof. swallow1_tac. Qed.

Proposition cert_POW2 : nCertN 1 (
  swallow [POW2];;
  let* x := pop64 in
  pushZ (2 ^ x)).
Proof. swallow1_tac. Qed.

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

Proposition cert_READ_FRAME : nCertN 1 (
  swallow [READ_FRAME];;
  let* i := pop64 in
  let* pair := readFrame i in
  pushZ (fst pair);;
  pushZ (snd pair)).
Proof. swallow1_tac. rewrite readFrame_spec. crush. Qed.

Proposition cert_READ_PIXEL : nCertN 1 (
  swallow [READ_PIXEL];;
  let* y := pop64 in
  let* x := pop64 in
  let* c := readPixel x y in
  pushZ c).
Proof. swallow1_tac. Qed.

Proposition cert_NEW_FRAME : nCertN 1 (
  swallow [NEW_FRAME];;
  let* r := pop64 in
  let* h := pop64 in
  let* w := pop64 in
  newFrame w h r).
Proof. swallow1_tac. Qed.

Proposition cert_SET_PIXEL : nCertN 1 (
  swallow [SET_PIXEL];;
  let* b := pop64 in
  let* g := pop64 in
  let* r := pop64 in
  let* y := pop64 in
  let* x := pop64 in
  setPixel x y (r, g, b)).
Proof. swallow1_tac. Qed.

Proposition cert_ADD_SAMPLE : nCertN 1 (
  swallow [ADD_SAMPLE];;
  let* r := pop64 in
  let* l := pop64 in
  addSample (toB16 l) (toB16 r)).
Proof. swallow1_tac. rewrite addSample_spec. crush. Qed.

Proposition cert_PUT_CHAR : nCertN 1 (
  swallow [PUT_CHAR];;
  let* c := pop64 in
  putChar (toB32 c)).
Proof. swallow1_tac. rewrite putChar_spec. crush. Qed.

Proposition cert_PUT_BYTE : nCertN 1 (
  swallow [PUT_BYTE];;
  let* b := pop64 in
  putByte (toB8 b)).
Proof. swallow1_tac. rewrite putByte_spec. crush. Qed.

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

Ltac cert_operand_tac :=
  apply swallow_step_lemma_N; [ lia | ];
  simp nSteps;
  apply (bind_propr _ _ _); [ | crush ];
  apply swallow_lemma;
  binary_simpl_tac.

  Proposition cert_JZ_FWD o : nCertN 1 (
    swallow [JZ_FWD; o];;
    let* x := pop64 in
    (if (decide (x = 0 :> Z))
     then
       let* pc := get' PC in
       put' PC (offset (toB8 o) pc)
     else
       ret tt)).
  Proof. cert_operand_tac. crush. Qed.

  Proposition cert_JZ_BACK o : nCertN 1 (
    swallow [JZ_BACK; o];;
    let* x := pop64 in
    (if (decide (x = 0 :> Z))
     then
       let* pc := get' PC in
       put' PC (offset (-(1 + toB8 o)) pc)
       else
       ret tt)).
  Proof. cert_operand_tac. crush. Qed.

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

Ltac cert_push_tac :=
  cert_operand_tac;
  apply pushZ_propr.

Definition zVecToZ {n} (u : vector Z n) : Z :=
  Vector.map toB8 u : Bytes n.

Proposition cert_PUSH1 (u: vector Z 1) : nCertN 1 (
  swallow (PUSH1 :: u);;
  pushZ (zVecToZ u)
).
Proof. cert_push_tac. Qed.

Corollary cert_PUSH1' x : nCertN 1 (
  swallow [PUSH1; x];;
  pushZ (toB8 x)
).
Proof. apply (cert_PUSH1 [x]). Qed.

Proposition cert_PUSH2 (u: vector Z 2) : nCertN 1 (
  swallow (PUSH2 :: u);;
  pushZ (zVecToZ u)
).
Proof. cert_push_tac. Qed.

Proposition cert_PUSH4 (u: vector Z 4) : nCertN 1 (
  swallow (PUSH4 :: u);;
  pushZ (zVecToZ u)
).
Proof. cert_push_tac. Qed.

Proposition cert_PUSH8 (u: vector Z 8) : nCertN 1 (
  swallow (PUSH8 :: u);;
  pushZ (zVecToZ u)
).
Proof. cert_push_tac. Qed.

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

Definition isPow2 (z:Z) : Prop := exists (n: nat), z = 2 ^ n.

Proposition isPow2_spec z : isPow2 z <-> exists (n: nat), z = (2 ^ n)%nat.
Proof.
  unfold isPow2.
  change 2 with (Z.of_N (N.of_nat 2)).
  setoid_rewrite <- N2Z.inj_pow.
  setoid_rewrite Nat2N_inj_pow.
  reflexivity.
Qed.

Proposition isPow2_spec' z :
  isPow2 z <-> 0 < z /\ exists (y: nat), (y < Z.to_nat z)%nat /\ z = 2 ^ y.
Proof.
  split.
  - intros [n H].
    subst z.
    split; [ apply pow2_pos | ].
    exists n.
    split; [ | reflexivity ].
    rewrite <- Z_N_nat.
    change 2 with (Z.of_N (N.of_nat 2)).
    rewrite <- N2Z.inj_pow.
    rewrite <- Nat2N_inj_pow.
    rewrite N2Z.id.
    rewrite Nnat.Nat2N.id.
    apply Nat.pow_gt_lin_r.
    lia.

  - intros [H0 [n [Hn Hz]]].
    exists n.
    exact Hz.
Qed.

Instance isPow2_decidable z : Decidable (isPow2 z).
Proof.
  exact (decidable_transfer (isPow2_spec' z)).
Defined.

(***)

Definition toBytes' n z : vector Z n :=
  Vector.map Z.of_N (Vector.map bitsToN (toBytes n z)).

Proposition toBytes'_spec n z i : Vector.nth (toBytes' n z) i = Vector.nth (toBytes n z) i.
Proof.
  unfold toBytes'.
  now do 2 rewrite (nth_map _ _ i i eq_refl).
Qed.

Proposition toBytes_eq {n x y} (H: cong (n * 8) x y) : toBytes n x = toBytes n y.
Proof.
  apply bytesToBits_injective.
  setoid_rewrite bytesToBits_bitsToBytes.
  apply toBits_cong.
  exact H.
Qed.

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

Proposition nAfter_nonempty n a :
  nAfter (S n) a = (nAfter n a) ∪ !{ offset n a }.
Proof.
  apply extensionality. intros x.
  unfold nAfter, singleton, union.
  repeat setoid_rewrite def_spec.
  split.
  - intros [i [Hi Hx]].
    by_lia (i < n \/ i = n) as Hor.
    destruct Hor as [Hor|Hor].
    + left. exists i. intuition.
    + right. subst i. exact Hx.
  - intros [[i [Hi Hx]] | Hor].
    + exists i. split; [lia | exact Hx].
    + exists n. split; [lia | exact Hor].
Qed.

Corollary disjoint_nAfter_nonempty u n a :
  u # nAfter (S n) a <-> u # nAfter n a /\ ~ offset n a ∈ u.
Proof.
  rewrite nAfter_nonempty.
  rewrite disjoint_union_spec.
  setoid_rewrite disjoint_not_member'.
  tauto.
Qed.

(********************************)
(** The following holds in the initial smonad, see MonoExtras.v. *)

Parameter err_less_eq :
  forall {X} {RX: Rel X} (mx: M X) (Hmx: mx ⊑ err), mx = err.

Parameter RM_transitive :
  forall X (RX: Rel X) (RXT: Transitive RX),
    Transitive (RM X RX).

Parameter RM_antisymmetric :
  forall X (RX: Rel X) (RXT: Antisymmetric X eq RX),
    Antisymmetric (M X) eq (RM X RX).

Existing Instance RM_transitive.
Existing Instance RM_antisymmetric.

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

(* TODO: Move to StateRel.v ? *)
Instance update_MEM_propR : PropR (@update _ _ MEM).
Proof.
  crush.
  srel_destruct Hst.
  unfold rel, state_relation, lens_relation, and_relation.
  lens_rewrite.
  repeat split; assumption.
Qed.

(******)

Section assume_rel_section.

  Ltac assume_rel_tac P H :=
    destruct (decide P) as [p|_];
    smon_rewrite;
    [ apply H
    | crush ].

  Proposition assume_rel
    P {DP: Decidable P} {X} (f g: P -> M X)
    (H : forall (p:P), f p ⊑ g p) :
      let* p := assume P in f p ⊑
      let* p := assume P in g p.
  Proof. assume_rel_tac P H. Qed.

  Proposition assume_rel'
    P {DP: Decidable P} {X} (f: P -> M X) (mx: M X)
    (H : forall (p:P), f p ⊑ mx) :
      let* p := assume P in f p ⊑ mx.
  Proof. assume_rel_tac P H. Qed.

End assume_rel_section.

Proposition confined'
  {mix: Mixer State} {mx: M unit} (Cmx: Confined mix mx)
  (my: M unit) {Hmy: Neutral mix my} :
my;; mx = mx;; my.
Proof.
enough (my;; mx;; ret tt = mx;; my;; ret tt) as HH.
- revert HH. smon_rewrite. tauto.
- rewrite Cmx.
  + reflexivity.
  + typeclasses eauto.
Qed.

Instance confined_swallow' pc {n} (ops: vector Z n) :
  Confined (MEM' (nAfter n pc) * PC) (
    put' PC pc;;
    swallow ops
  ).
Proof.
  rewrite swallow_spec, lens_put_get.
  typeclasses eauto.
Qed.

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

(* Finitely enumerable, equivalent to Coq.Logic.FinFun.Finite. *)
Class SFinite X : Type :=
{
  SFinite_n : N;
  SFinite_f : forall i, (i < SFinite_n)%N -> X;
  SFinite_p : forall x, exists i Hi, SFinite_f i Hi = x;
}.

#[refine]
Instance bits_sfinite n : SFinite (Bits n) :=
{
  SFinite_n := 2 ^ n;
  SFinite_f i _ := toBits n i;
}.
Proof.
  intros x. exists x, (bitsToN_bound x).
  apply fromBits_toBits'.
Qed.

(****)

Instance sfinite_decidable_all
    {X} {SF: SFinite X}
    (P: X -> Prop) {DP: forall x, Decidable (P x)} :
  Decidable (forall x, P x).
Proof.
  enough (
    (forall x, P x) <->
    (forall i (Hi: (i < SFinite_n)%N),
      P (SFinite_f i Hi))) as H;
  [ unshelve eapply (decidable_transfer H) | ].
  split.
  - intros H i Hi. apply H.
  - intros H x.
    destruct (SFinite_p x) as [i [Hi Hp]].
    specialize (H i Hi).
    rewrite Hp in H.
    exact H.
Qed.

Definition isWiped (u: DSet Addr) (m: Memory) :=
  forall a (Hau: a ∈ u), exists (Ha: available a), m a Ha = None.

(********)

(** ** Mark memory as undefined *)
Definition wipe (u: DSet Addr) : M unit :=
  assume' (u ⊆ available);;
  put' (MEM' u) (fun _ _ _ => None).

Definition wipe_spec := unfolded_eq (@wipe).

Proposition wipe_empty : wipe ∅ = ret tt.
Proof.
  unfold wipe.
  rewrite put_empty.
  destruct (decide _) as [H|H].
  - now rewrite ret_bind.
  - contradict H. unfold subset. intros a Ha. contradict Ha.
Qed.

Proposition wipe_mono u v (H: u ⊆ v) : wipe v ⊑ wipe u.
Proof.
  unfold wipe. do 2 rewrite put_spec. cbn.
  unfold restr. crush; [ | contradict HR; now transitivity v ].

  apply update_MEM_propR; [ exact Hst | ].
  crush.
  specialize (H a). cbv. cbv in H.
  destruct (v a) eqn:Hva; [ exact I | ].
  destruct (u a) eqn:Hua.
  - exfalso. exact (H I).
  - srel_destruct Hst.
    apply Hst_mem.
Qed.

Corollary wipe_less u : wipe u ⊑ ret tt.
Proof.
  (* This is also provable without assuming RM_transitive. *)
  transitivity (wipe ∅).
  - apply wipe_mono. apply empty_initial.
  - rewrite wipe_empty. crush.
Qed.

Instance confined_wipe u : Confined (MEM' u) (wipe u).
Proof.
  typeclasses eauto.
Qed.

#[global] Opaque wipe.

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

Lemma wipe_swallow_reordering'
    u {n} (ops: vector Z n) pc (Hdis: u # nAfter n pc) :
  put' PC pc;;
  wipe u;;
  swallow ops =
    put' PC pc;;
    swallow ops;;
    wipe u.
Proof.
  setoid_rewrite confined_wipe; [ | typeclasses eauto .. ].
  setoid_rewrite <- bind_assoc at 2.

  setoid_rewrite (confined' (confined_wipe u)); [ reflexivity | ].
  unshelve eapply (confined_neutral (m':= MEM' (nAfter n pc) * PC ));
    try typeclasses eauto.

  apply independent_backward.
  setoid_rewrite prodLens_prodMixer.
  apply independent_prod; [ | typeclasses eauto ].

  (* TODO: Why doesn't 'typeclasses eauto' solve this as well? *)
  now apply independent_backward,
            composite_independent_r,
            separate_independent.
Qed.

Corollary wipe_swallow_reordering u {n} (ops: vector Z n) :
  let* pc := get' PC in
  assume (u # nAfter n pc);;
  wipe u;;
  swallow ops =
    let* pc := get' PC in
    assume (u # nAfter n pc);;
    swallow ops;;
    wipe u.
Proof.
  smon_ext' PC pc.
  setoid_rewrite lens_put_get.
  setoid_rewrite <- confined_put; [ | typeclasses eauto .. ].
  apply assume_eq, wipe_swallow_reordering'.
Qed.

(***)

Proposition rel_extensional'
  {A} (LA: Lens State A)
  {RA: Rel A} {Hg: @PropR _ (RM A RA) (get' LA)}
  {X} {RX: Rel X}
  (mx mx': M X)
  (H: forall a a', a ⊑ a' -> put' LA a;; mx ⊑ put' LA a';; mx') :
  mx ⊑ mx'.
Proof.
  enough (
    let* a := get' LA in put' LA a;; ret tt;; mx ⊑
    let* a' := get' LA in put' LA a';; ret tt;; mx') as HHH.
  - revert HHH. smon_rewrite. tauto.
  - setoid_rewrite ret_tt_bind.
    apply (
      bind_propr State M _ _ _ _ Hg
      (fun a => put' LA a;; mx)
      (fun a' => put' LA a';; mx') H).
Qed.

(***)

Proposition wipe_load {u a} (Ha: a ∈ u) : wipe u;; load a = err.
Proof.
  rewrite wipe_spec.
  rewrite load_spec''.
  setoid_rewrite confined_get; [ | typeclasses eauto ].
  smon_rewrite.
  rewrite (collapse_bind_lift (mem_put_get'' Ha _)).
  smon_rewrite.
Qed.

Proposition put_to_get'
    {A} (LA: Lens State A)
    {RA: Rel A} {Hg: @PropR _ (RM A RA) (get' LA)}
    {X} (f g: A -> M X)
    (H: forall a a', a ⊑ a' ->
      put' LA a;; f a ⊑
      put' LA a';; g a') :
  let* a := get' LA in f a ⊑
  let* a' := get' LA in g a'.
Proof.
  apply (rel_extensional' LA). intros a a' Ha.
  setoid_rewrite lens_put_get. apply H. exact Ha.
Qed.

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

Proposition load_mx a {X} {RX: Rel X} {mx mx': M X} (Hmx: mx ⊑ mx') :
  load a;; mx ⊑ mx'.
Proof.
  rewrite load_spec.
  destruct (decide _) as [Ha|_]; smon_rewrite; [ | crush ].
  rewrite extr_spec.
  apply (rel_extensional' MEM).
  intros mem mem' Hm.
  rewrite lens_put_get.
  destruct (mem a Ha) as [H|]; smon_rewrite; crush.
  apply Hm.
  exact Hmx.
Qed.

Proposition loadMany_mx
    n a {X} {RX: Rel X} {TX: Transitive RX}
    (mx: M X) {Hmx: mx ⊑ mx} :
  loadMany n a;; mx ⊑ mx.
Proof.
  revert a.
  induction n; intros a; simp loadMany; smon_rewrite; crush; [ exact Hmx | ].
  transitivity (load a;; mx).
  - apply bind_propr'.
    + apply load_propr.
    + crush. apply IHn.
  - apply load_mx. exact Hmx.
Qed.

(****)

Proposition swallow_n {n} (ops: vector Z n) :
  swallow ops ⊑
    let* pc := get' PC in
    put' PC (offset n pc).
Proof.
  rewrite swallow_spec.
  apply (@put_to_get' _ _ eq_relation getPc_propr).
  intros a a' Ha. destruct Ha.
  apply (rel_extensional' MEM). intros mem mem' Hm.

  setoid_rewrite confined_put.
  2,3:
    apply (confined_neutral (m':=MEM)); (* TODO *)
    typeclasses eauto.

  transitivity (
    put' PC a;;
    put' MEM mem;;
    let* u := loadMany n a in
    put' PC (offset n a)).

  - apply bind_propr'.
    + apply putPc_propr. reflexivity.
    + crush.

  - apply bind_propr'.
    + apply putPc_propr. reflexivity.
    + crush.
      * apply Hm.
      * apply loadMany_mx.
        -- typeclasses eauto.
        -- apply putPc_propr. reflexivity.
Qed.

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

(* TODO: Move *)
Instance disjoint_proper' X : Proper (eq --> eq --> iff) (@disjoint X).
Proof.
  intros u u' Hu
         v v' Hv.
         Set Printing All.
  unfold flip in *.
  now subst.
Qed.

Proposition wipe_swallow_precondition u {n} (ops: vector Z n) :
  wipe u;;
  swallow ops = let* pc := get' PC in
                assume' (u # nAfter n pc);;
                wipe u;;
                swallow ops.
Proof.
  induction ops using vec_rev_ind.
  {
    smon_ext s.
    unfold Addr.
    rewrite get_spec.
    smon_rewrite.
    apply bind_extensional. intros [].
    rewrite wipe_spec.
    destruct (decide (u ⊆ _)) as [H|H]; [ | now smon_rewrite01 ].
    setoid_rewrite ret_tt_bind.
    rewrite decide_true; [ | now rewrite nAfter_empty ].
    now rewrite ret_tt_bind.
  }
  simp swallow.
  rewrite <- bind_assoc.
  rewrite IHops at 1. clear IHops.
  rewrite bind_assoc.
  smon_ext' PC pc.
  repeat rewrite lens_put_get.

  destruct (decide (u # nAfter (S n) pc)) as [Hd'|Hd'].
  {
    setoid_rewrite ret_bind.
    repeat setoid_rewrite bind_assoc.
    rewrite nAfter_nonempty in Hd'.
    apply disjoint_union_spec in Hd'.
    destruct Hd' as [Hd0 Hd1].

    destruct (decide (u # nAfter n pc)) as [He0|He1];
    [ | contradict He1; exact Hd0 ].
    rewrite ret_bind.
    reflexivity.
  }

  destruct (decide (u # nAfter n pc)) as [Hd''|Hd''].
  {
    smon_rewrite.
    setoid_rewrite disjoint_nAfter_nonempty in Hd'.

    assert (offset n pc ∈ u) as Hn; [ apply decidable_raa; intuition idtac | ].

    setoid_rewrite <- bind_assoc at 2.
    setoid_rewrite <- bind_assoc at 1.
    rewrite wipe_swallow_reordering'; [ | exact Hd'' ].
    setoid_rewrite -> bind_assoc at 1.
    setoid_rewrite -> bind_assoc at 1.

    apply err_less_eq.
    transitivity (
      put' PC pc;;
      (let* pc := get' PC in
      put' PC (offset n pc));;
      wipe u;;
      let* x3 := get' PC in
      let* x4 := load x3 in
      assume' (x4 = toB8 x);;
      put' PC (offset 1 x3)
    ).
    - apply bind_propr'; [ apply putPc_propr; reflexivity | ].
      intros [] [] _. apply bind_propr'; [ apply swallow_n | ].
      intros [] [] _. crush. rewrite wipe_spec.

      rewrite (put_spec (MEM' u)).
      cbn.
      unfold compose.
      crush.
      unfold rel, state_relation, and_relation, lens_relation.
      lens_rewrite.
      srel_destruct Hst.
      repeat split; try assumption.
      setoid_rewrite proj_update.
      crush.
      destruct (decide (a ∈ u)); [ crush | ].
      apply Hst_mem.

    - setoid_rewrite bind_assoc.
      rewrite lens_put_get.
      rewrite lens_put_put.
      setoid_rewrite confined_get.
      rewrite lens_put_get.
      setoid_rewrite <- bind_assoc at 2.
      assert (wipe u;; load (offset n pc) = err) as H.
      + apply wipe_load. exact Hn.
      + setoid_rewrite H.
        smon_rewrite. crush.
      + apply (confined_neutral _ (m':=MEM)).
  }
  smon_rewrite.
Qed.