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

(** Correctness proof for the [Debugvar] pass. *)

Require Import Coqlib.
Require Import Axioms.
Require Import Maps.
Require Import Iteration.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Errors.
Require Import Machregs.
Require Import Locations.
Require Import Conventions.
Require Import Linear.
Require Import Debugvar.

(** * Relational characterization of the transformation *)

Inductive match_code: code -> code -> Prop :=
  | match_code_nil:
      match_code nil nil
  | match_code_cons: forall i before after c c',
      match_code c c' ->
      match_code (i :: c) (i :: add_delta_ranges before after c').

Remark diff_same:
  forall s, diff s s = nil.
Proof.
  induction s as [ | [v i] s]; simpl.
  auto.
  rewrite Pos.compare_refl. rewrite dec_eq_true. auto.
Qed.

Remark delta_state_same:
  forall s, delta_state s s = (nil, nil).
Proof.
  destruct s; simpl. rewrite ! diff_same; auto. auto.
Qed.

Lemma transf_code_match:
  forall lm c before, match_code c (transf_code lm before c).
Proof.
  intros lm. fix REC 1. destruct c; intros before; simpl.
- constructor.
- assert (DEFAULT: forall before after,
            match_code (i :: c)
                       (i :: add_delta_ranges before after (transf_code lm after c))).
  { intros. constructor. apply REC. }
  destruct i; auto. destruct c; auto. destruct i; auto.
  set (after := get_label l0 lm).
  set (c1 := Llabel l0 :: add_delta_ranges before after (transf_code lm after c)).
  replace c1 with (add_delta_ranges before before c1).
  constructor. constructor. apply REC.
  unfold add_delta_ranges. rewrite delta_state_same. auto.
Qed.

Inductive match_function: function -> function -> Prop :=
  | match_function_intro: forall f c,
      match_code f.(fn_code) c ->
      match_function f (mkfunction f.(fn_sig) f.(fn_stacksize) c).

Lemma transf_function_match:
  forall f tf, transf_function f = OK tf -> match_function f tf.
Proof.
  unfold transf_function; intros.
  destruct (ana_function f) as [lm|]; inv H.
  constructor. apply transf_code_match.
Qed.

Remark find_label_add_delta_ranges:
  forall lbl c before after, find_label lbl (add_delta_ranges before after c) = find_label lbl c.
Proof.
  intros. unfold add_delta_ranges.
  destruct (delta_state before after) as [killed born].
  induction killed as [ | [v i] l]; simpl; auto.
  induction born as [ | [v i] l]; simpl; auto.
Qed.

Lemma find_label_match_rec:
  forall lbl c' c tc,
  match_code c tc ->
  find_label lbl c = Some c' ->
  exists before after tc', find_label lbl tc = Some (add_delta_ranges before after tc') /\ match_code c' tc'.
Proof.
  induction 1; simpl; intros.
- discriminate.
- destruct (is_label lbl i).
  inv H0. econstructor; econstructor; econstructor; eauto.
  rewrite find_label_add_delta_ranges. auto.
Qed.

Lemma find_label_match:
  forall f tf lbl c,
  match_function f tf ->
  find_label lbl f.(fn_code) = Some c ->
  exists before after tc, find_label lbl tf.(fn_code) = Some (add_delta_ranges before after tc) /\ match_code c tc.
Proof.
  intros. inv H. eapply find_label_match_rec; eauto.
Qed.

(** * Properties of availability sets *)

(** These properties are not used in the semantic preservation proof,
    but establish some confidence in the availability analysis. *)

Definition avail_above (v: ident) (s: avail) : Prop :=
  forall v' i', In (v', i') s -> Plt v v'.

Inductive wf_avail: avail -> Prop :=
  | wf_avail_nil:
      wf_avail nil
  | wf_avail_cons: forall v i s,
     avail_above v s ->
     wf_avail s ->
     wf_avail ((v, i) :: s).

Lemma set_state_1:
  forall v i s, In (v, i) (set_state v i s).
Proof.
  induction s as [ | [v' i'] s]; simpl.
- auto.
- destruct (Pos.compare v v'); simpl; auto.
Qed.

Lemma set_state_2:
  forall v i v' i' s,
  v' <> v -> In (v', i') s -> In (v', i') (set_state v i s).
Proof.
  induction s as [ | [v1 i1] s]; simpl; intros.
- contradiction.
- destruct (Pos.compare_spec v v1); simpl.
+ subst v1. destruct H0. congruence. auto.
+ auto.
+ destruct H0; auto.
Qed.

Lemma set_state_3:
  forall v i v' i' s,
  wf_avail s ->
  In (v', i') (set_state v i s) ->
  (v' = v /\ i' = i) \/ (v' <> v /\ In (v', i') s).
Proof.
  induction 1; simpl; intros.
- intuition congruence.
- destruct (Pos.compare_spec v v0); simpl in H1.
+ subst v0. destruct H1. inv H1; auto. right; split.
  apply sym_not_equal. apply Plt_ne. eapply H; eauto.
  auto.
+ destruct H1. inv H1; auto.
  destruct H1. inv H1. right; split; auto. apply sym_not_equal. apply Plt_ne. auto.
  right; split; auto. apply sym_not_equal. apply Plt_ne. apply Plt_trans with v0; eauto.
+ destruct H1. inv H1. right; split; auto. apply Plt_ne. auto.
  destruct IHwf_avail as [A | [A B]]; auto.
Qed.

Lemma wf_set_state:
  forall v i s, wf_avail s -> wf_avail (set_state v i s).
Proof.
  induction 1; simpl.
- constructor. red; simpl; tauto. constructor.
- destruct (Pos.compare_spec v v0).
+ subst v0. constructor; auto.
+ constructor.
  red; simpl; intros. destruct H2.
  inv H2. auto. apply Plt_trans with v0; eauto.
  constructor; auto.
+ constructor.
  red; intros. exploit set_state_3. eexact H0. eauto. intros [[A B] | [A B]]; subst; eauto.
  auto.
Qed.

Lemma remove_state_1:
  forall v i s, wf_avail s -> ~ In (v, i) (remove_state v s).
Proof.
  induction 1; simpl; red; intros.
- auto.
- destruct (Pos.compare_spec v v0); simpl in *.
+ subst v0. elim (Plt_strict v); eauto.
+ destruct H1. inv H1.  elim (Plt_strict v); eauto.
  elim (Plt_strict v). apply Plt_trans with v0; eauto.
+ destruct H1. inv H1. elim (Plt_strict v); eauto.  tauto.
Qed.

Lemma remove_state_2:
  forall v v' i' s, v' <> v -> In (v', i') s -> In (v', i') (remove_state v s).
Proof.
  induction s as [ | [v1 i1] s]; simpl; intros.
- auto.
- destruct (Pos.compare_spec v v1); simpl.
+ subst v1. destruct H0. congruence. auto.
+ auto.
+ destruct H0; auto.
Qed.

Lemma remove_state_3:
  forall v v' i' s, wf_avail s -> In (v', i') (remove_state v s) -> v' <> v /\ In (v', i') s.
Proof.
  induction 1; simpl; intros.
- contradiction.
- destruct (Pos.compare_spec v v0); simpl in H1.
+ subst v0. split; auto. apply sym_not_equal; apply Plt_ne; eauto.
+ destruct H1. inv H1. split; auto. apply sym_not_equal; apply Plt_ne; eauto.
  split; auto. apply sym_not_equal; apply Plt_ne. apply Plt_trans with v0; eauto.
+ destruct H1. inv H1. split; auto. apply Plt_ne; auto.
  destruct IHwf_avail as [A B] ; auto.
Qed.

Lemma wf_remove_state:
  forall v s, wf_avail s -> wf_avail (remove_state v s).
Proof.
  induction 1; simpl.
- constructor.
- destruct (Pos.compare_spec v v0).
+ auto.
+ constructor; auto.
+ constructor; auto. red; intros.
  exploit remove_state_3. eexact H0. eauto. intros [A B]. eauto.
Qed.

Lemma wf_filter:
  forall pred s, wf_avail s -> wf_avail (List.filter pred s).
Proof.
  induction 1; simpl.
- constructor.
- destruct (pred (v, i)) eqn:P; auto.
  constructor; auto.
  red; intros. apply filter_In in H1. destruct H1. eauto.
Qed.

Lemma join_1:
  forall v i s1, wf_avail s1 -> forall s2, wf_avail s2 ->
  In (v, i) s1 -> In (v, i) s2 -> In (v, i) (join s1 s2).
Proof.
  induction 1; simpl; try tauto; induction 1; simpl; intros I1 I2; auto.
  destruct I1, I2.
- inv H3; inv H4. rewrite Pos.compare_refl. rewrite dec_eq_true; auto with coqlib.
- inv H3.
  assert (L: Plt v1 v) by eauto. apply Pos.compare_gt_iff in L. rewrite L. auto.
- inv H4.
  assert (L: Plt v0 v) by eauto. apply Pos.compare_lt_iff in L. rewrite L. apply IHwf_avail. constructor; auto. auto. auto with coqlib.
- destruct (Pos.compare v0 v1).
+ destruct (eq_debuginfo i0 i1); auto with coqlib.
+ apply IHwf_avail; auto with coqlib. constructor; auto.
+ eauto.
Qed.

Lemma join_2:
  forall v i s1, wf_avail s1 -> forall s2, wf_avail s2 ->
  In (v, i) (join s1 s2) -> In (v, i) s1 /\ In (v, i) s2.
Proof.
  induction 1; simpl; try tauto; induction 1; simpl; intros I; try tauto.
  destruct (Pos.compare_spec v0 v1).
- subst v1. destruct (eq_debuginfo i0 i1).
  + subst i1. destruct I. auto. exploit IHwf_avail; eauto. tauto.
  + exploit IHwf_avail; eauto. tauto.
- exploit (IHwf_avail ((v1, i1) :: s0)); eauto. constructor; auto.
  simpl. tauto.
- exploit IHwf_avail0; eauto. tauto.
Qed.

Lemma wf_join:
  forall s1, wf_avail s1 -> forall s2, wf_avail s2 -> wf_avail (join s1 s2).
Proof.
  induction 1; simpl; induction 1; simpl; try constructor.
  destruct (Pos.compare_spec v v0).
- subst v0. destruct (eq_debuginfo i i0); auto. constructor; auto.
  red; intros. apply join_2 in H3; auto. destruct H3. eauto.
- apply IHwf_avail. constructor; auto.
- apply IHwf_avail0.
Qed.

(** * Semantic preservation *)

Section PRESERVATION.

Variable prog: program.
Variable tprog: program.

Hypothesis TRANSF: transf_program prog = OK tprog.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma functions_translated:
  forall v f,
  Genv.find_funct ge v = Some f ->
  exists tf,
  Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_transf_partial transf_fundef _ TRANSF).

Lemma function_ptr_translated:
  forall v f,
  Genv.find_funct_ptr ge v = Some f ->
  exists tf,
  Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF).

Lemma symbols_preserved:
  forall id,
  Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof (Genv.find_symbol_transf_partial transf_fundef _ TRANSF).

Lemma public_preserved:
  forall id,
  Genv.public_symbol tge id = Genv.public_symbol ge id.
Proof (Genv.public_symbol_transf_partial transf_fundef _ TRANSF).

Lemma varinfo_preserved:
  forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
Proof (Genv.find_var_info_transf_partial transf_fundef _ TRANSF).

Lemma sig_preserved:
  forall f tf,
  transf_fundef f = OK tf ->
  funsig tf = funsig f.
Proof.
  unfold transf_fundef, transf_partial_fundef; intros.
  destruct f. monadInv H.
  exploit transf_function_match; eauto. intros M; inv M; auto.
  inv H. reflexivity.
Qed.

Lemma find_function_translated:
  forall ros ls f,
  find_function ge ros ls = Some f ->
  exists tf,
  find_function tge ros ls = Some tf /\ transf_fundef f = OK tf.
Proof.
  unfold find_function; intros; destruct ros; simpl.
  apply functions_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
  apply function_ptr_translated; auto.
  congruence.
Qed.

(** Evaluation of the debug annotations introduced by the transformation. *)

Lemma can_eval_safe_arg:
  forall (rs: locset) sp m (a: builtin_arg loc),
  safe_builtin_arg a -> exists v, eval_builtin_arg tge rs sp m a v.
Proof.
  induction a; simpl; intros; try contradiction;
  try (econstructor; now eauto with barg).
  destruct H as [S1 S2].
  destruct (IHa1 S1) as [v1 E1]. destruct (IHa2 S2) as [v2 E2].
  exists (Val.longofwords v1 v2); auto with barg.
Qed.

Lemma eval_add_delta_ranges:
  forall s f sp c rs m before after,
  star step tge (State s f sp (add_delta_ranges before after c) rs m)
             E0 (State s f sp c rs m).
Proof.
  intros. unfold add_delta_ranges.
  destruct (delta_state before after) as [killed born].
  induction killed as [ | [v i] l]; simpl.
- induction born as [ | [v i] l]; simpl.
+ apply star_refl.
+ destruct i as [a SAFE]; simpl.
  exploit can_eval_safe_arg; eauto. intros [v1 E1].
  eapply star_step; eauto.
  econstructor.
  constructor. eexact E1. constructor.
  simpl; constructor.
  simpl; auto.
  traceEq.
- eapply star_step; eauto.
  econstructor.
  constructor.
  simpl; constructor.
  simpl; auto.
  traceEq.
Qed.

(** Matching between program states. *)

Inductive match_stackframes: Linear.stackframe -> Linear.stackframe -> Prop :=
  | match_stackframe_intro:
      forall f sp rs c tf tc before after,
      match_function f tf ->
      match_code c tc ->
      match_stackframes
        (Stackframe f sp rs c)
        (Stackframe tf sp rs (add_delta_ranges before after tc)).

Inductive match_states: Linear.state ->  Linear.state -> Prop :=
  | match_states_instr:
      forall s f sp c rs m tf ts tc
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: match_function f tf)
        (TRC: match_code c tc),
      match_states (State s f sp c rs m)
                   (State ts tf sp tc rs m)
  | match_states_call:
      forall s f rs m tf ts,
      list_forall2 match_stackframes s ts ->
      transf_fundef f = OK tf ->
      match_states (Callstate s f rs m)
                   (Callstate ts tf rs m)
  | match_states_return:
      forall s rs m ts,
      list_forall2 match_stackframes s ts ->
      match_states (Returnstate s rs m)
                   (Returnstate ts rs m).

Lemma parent_locset_match:
  forall s ts,
  list_forall2 match_stackframes s ts ->
  parent_locset ts = parent_locset s.
Proof.
  induction 1; simpl. auto. inv H; auto.
Qed.

(** The simulation diagram. *)

Theorem transf_step_correct:
  forall s1 t s2, step ge s1 t s2 ->
  forall ts1 (MS: match_states s1 ts1),
  exists ts2, plus step tge ts1 t ts2 /\ match_states s2 ts2.
Proof.
  induction 1; intros ts1 MS; inv MS; try (inv TRC).
- (* getstack *)
  econstructor; split.
  eapply plus_left. constructor; auto. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* setstack *)
  econstructor; split.
  eapply plus_left. constructor; auto. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* op *)
  econstructor; split.
  eapply plus_left.
  econstructor; eauto.
  instantiate (1 := v). rewrite <- H; apply eval_operation_preserved; exact symbols_preserved.
  apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* load *)
  econstructor; split.
  eapply plus_left.
  eapply exec_Lload with (a := a).
  rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved.
  eauto. eauto.
  apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* store *)
  econstructor; split.
  eapply plus_left.
  eapply exec_Lstore with (a := a).
  rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved.
  eauto. eauto.
  apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* call *)
  exploit find_function_translated; eauto. intros (tf' & A & B).
  econstructor; split.
  apply plus_one.
  econstructor. eexact A. symmetry; apply sig_preserved; auto. traceEq.
  constructor; auto. constructor; auto. constructor; auto.
- (* tailcall *)
  exploit find_function_translated; eauto. intros (tf' & A & B).
  exploit parent_locset_match; eauto. intros PLS.
  econstructor; split.
  apply plus_one.
  econstructor. eauto. rewrite PLS. eexact A.
  symmetry; apply sig_preserved; auto.
  inv TRF; eauto. traceEq.
  rewrite PLS. constructor; auto.
- (* builtin *)
  econstructor; split.
  eapply plus_left.
  econstructor; eauto.
  eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
  eapply external_call_symbols_preserved. eauto.
  exact symbols_preserved. exact public_preserved. exact varinfo_preserved.
  apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* label *)
  econstructor; split.
  eapply plus_left. constructor; auto. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* goto *)
  exploit find_label_match; eauto. intros (before' & after' & tc' & A & B).
  econstructor; split.
  eapply plus_left. constructor; eauto. apply eval_add_delta_ranges; eauto. traceEq.
  constructor; auto.
- (* cond taken *)
  exploit find_label_match; eauto. intros (before' & after' & tc' & A & B).
  econstructor; split.
  eapply plus_left. eapply exec_Lcond_true; eauto. apply eval_add_delta_ranges; eauto. traceEq.
  constructor; auto.
- (* cond not taken *)
  econstructor; split.
  eapply plus_left. eapply exec_Lcond_false; auto. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* jumptable *)
  exploit find_label_match; eauto. intros (before' & after' & tc' & A & B).
  econstructor; split.
  eapply plus_left. econstructor; eauto.
  apply eval_add_delta_ranges. reflexivity. traceEq.
  constructor; auto.
- (* return *)
  econstructor; split.
  apply plus_one.  constructor. inv TRF; eauto. traceEq.
  rewrite (parent_locset_match _ _ STACKS). constructor; auto.
- (* internal function *)
  monadInv H7. rename x into tf.
  assert (MF: match_function f tf) by (apply transf_function_match; auto).
  inversion MF; subst.
  econstructor; split.
  apply plus_one. constructor. simpl; eauto. reflexivity.
  constructor; auto.
- (* external function *)
  monadInv H8. econstructor; split.
  apply plus_one. econstructor; eauto.
  eapply external_call_symbols_preserved'. eauto.
  exact symbols_preserved. exact public_preserved. exact varinfo_preserved.
  constructor; auto.
- (* return *)
  inv H3. inv H1.
  econstructor; split.
  eapply plus_left. econstructor. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
Qed.

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists st2, initial_state tprog st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  exploit function_ptr_translated; eauto. intros [tf [A B]].
  exists (Callstate nil tf (Locmap.init Vundef) m0); split.
  econstructor; eauto. eapply Genv.init_mem_transf_partial; eauto.
  replace (prog_main tprog) with (prog_main prog).
  rewrite symbols_preserved. eauto.
  symmetry. apply (transform_partial_program_main transf_fundef _ TRANSF).
  rewrite <- H3. apply sig_preserved. auto.
  constructor. constructor. auto.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states st1 st2 -> final_state st1 r -> final_state st2 r.
Proof.
  intros. inv H0. inv H. inv H6. econstructor; eauto.
Qed.

Theorem transf_program_correct:
  forward_simulation (semantics prog) (semantics tprog).
Proof.
  eapply forward_simulation_plus.
  eexact public_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  eexact transf_step_correct.
Qed.

End PRESERVATION.


From Coq.Unicode Require Import Utf8.

Axiom FunExt :
  ∀ (A : Type) (B : A → Type) (f g : ∀ x, B x), (∀ x, f x = g x) → f = g.

Axiom PropExt : ∀ P Q : Prop, P ↔ Q → P = Q.

Lemma ProofIrrelevance : ∀ P : Prop, ∀ p q : P, p = q.
Proof.
  intros P p q.
  assert (True = P) as HP.
  { apply PropExt; split; auto. }
  revert p q.
  refine (match HP in _ = u return ∀ p q : u, p = q :> u with eq_refl => _ end).
  intros [] []; trivial.
Qed.

Axiom Choice :
  ∀ A B (R : A → B → Prop), (∀ x, ∃ y, R x y) → {f : A → B | ∀ x, R x (f x)}.

Definition epsilon {A : Type} {P : A → Prop} (Hex : ∃ x, P x) : A :=
  proj1_sig (Choice unit A (λ _ x, P x) (λ _, Hex)) tt.

Lemma epsilon_correct {A : Type} (P : A → Prop) (Hex : ∃ x, P x) :
  P (epsilon Hex).
Proof.
  exact (proj2_sig (Choice unit A (λ _ x, P x) (λ _, Hex)) tt).
Qed.

Lemma ExcludedMiddle (P : Prop) : P ∨ ¬ P.
Proof.
  set (PA b := b = true ∨ P).
  set (PB b := b = false ∨ P).
  set (U := sig (λ s, s = PA ∨ s = PB)).
  set (R := (λ u b, proj1_sig u b) : U → bool → Prop).
  assert (∀ u, ∃ b, R u b) as HR.
  { intros u.
    unfold R.
    destruct (proj2_sig u) as [->| ->]; unfold PA, PB; eauto. }
  apply Choice in HR as [f Hf].
  set (A := exist _ _ (or_introl eq_refl) : U); simpl in *.
  set (B := exist _ _ (or_intror eq_refl) : U); simpl in *.
  assert (P ↔ A = B) as HPAB.
  { split.
    - intros HP.
      unfold A, B.
      assert (PA = PB) as ->.
      { unfold PA, PB.
        apply FunExt; intros x; apply PropExt; tauto. }
      rewrite (ProofIrrelevance _ (or_introl eq_refl) (or_intror eq_refl));
        trivial.
    - intros HAB.
      assert (proj1_sig A = proj1_sig B) as HPAB; [rewrite HAB; trivial|].
      simpl in *.
      assert (PA false) as HPAf; [rewrite HPAB; unfold PB; auto; fail|].
      destruct HPAf; [congruence| trivial]. }
  pose proof (Hf A) as HfA.
  pose proof (Hf B) as HfB.
  simpl in *.
  destruct (f A) eqn:Aeq.
  - destruct (f B) eqn:Beq.
    + destruct HfB; [congruence| auto].
    + right. intros HP; apply HPAB in HP. congruence.
  - destruct HfA; [congruence| auto].
Qed.

Lemma NNP_P : ∀ P : Prop, ¬ ¬ P → P.
Proof.
  intros P NNP.
  destruct (ExcludedMiddle P); [trivial; fail|].
  exfalso; apply NNP; trivial.
Qed.

Lemma P_NNP : ∀ P : Prop, P → ¬ ¬ P.
Proof.
  intros P HP HnP; apply HnP; trivial.
Qed.

Lemma contrapositive : ∀ P Q : Prop, (¬ Q → ¬ P) → P → Q.
Proof.
  intros P Q Hcontra HP.
  destruct (ExcludedMiddle Q); [trivial; fail|].
  exfalso; apply Hcontra; trivial.
Qed.

Lemma not_exists_forall_not :
  ∀ (A : Type) (P : A → Prop), ¬ (∃ x, P x) → ∀ x, ¬ P x.
Proof. intros A P Hnex x HP; apply Hnex; eauto. Qed.

Lemma not_forall_exists_not :
  ∀ (A : Type) (P : A → Prop), ¬ (∀ x, P x) → ∃ x, ¬ P x.
Proof.
  intros A P.
  apply contrapositive.
  intros Hnex; apply P_NNP.
  intros x; apply NNP_P; revert x.
  apply not_exists_forall_not; trivial.
Qed.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** * Abstract semantics (context-insen + localized) *)

Set Implicit Arguments.

Require Import hpattern vgtac.
Require Import Global UserProofType DStr Syn Global.
Require DomCon SemCon DomInsen.
Require Import SemCommon.

Module Make (Import PInput : PINPUT).

Local Open Scope type.

Include DomInsen.Make PInput.

Section Sem.

Variable g : G.t.

Let pgm : InterCfg.t := G.icfg g.

Let mode : UserInputType.update_mode := UserInputType.Strong.

Variable amap : access_map.

Definition postfix_cmd (cn : InterNode.t) (s : state_t) : Prop :=
  forall cmd (Hcmd : Some cmd = InterCfg.get_cmd pgm cn),
    let m := s (cn, Inputof) in
    let m' := run_only mode g cn cmd m in
    let m'' := s (cn, Outputof) in
    Mem.le m' m''.

Definition postfix_intra_edge (cn : InterNode.t) (s : state_t) : Prop :=
  let p := InterNode.get_pid cn in
  let n := InterNode.get_node cn in
  forall n' cfg
         (Hcfg : InterCfg.PidMap.MapsTo p cfg (InterCfg.cfgs pgm))
         (Hedge : IntraCfg.is_succ cfg n n')
         (Hcn_cond: not (InterCfg.is_call_node pgm cn)),
    Mem.le (s (cn, Outputof)) (s ((p, n'), Inputof)).

Definition postfix_intra_call (cn : InterNode.t) (s : state_t) : Prop :=
  forall callee (Hedge : InterCfg.is_succ pgm cn (callee, IntraNode.Entry))
         retn (Hretn : Some retn = InterCfg.returnof pgm cn),
    let access := get_all_access callee amap in
    let m := s (cn, Outputof) in
    let m' := Mem.subtract access m in
    Mem.le m' (s (retn, Inputof)).

Definition postfix_inter_call (cn : InterNode.t) (s : state_t) : Prop :=
  forall callee (Hedge : InterCfg.is_succ pgm cn (callee, IntraNode.Entry)),
    let access := get_all_access callee amap in
    let m := s (cn, Outputof) in
    let m' := Mem.restrict access m in
    Mem.le m' (s ((callee, IntraNode.Entry), Inputof)).

Definition postfix_inter_ret (cn : InterNode.t)
           (s : state_t) : Prop :=
  forall p (Hp : cn = (p, IntraNode.Exit))
         cn' (Hedge : InterCfg.is_succ pgm cn cn')
         calln (Hret: Some cn' = InterCfg.returnof pgm calln),
    Mem.le (s (cn, Outputof)) (s (cn', Inputof)).

Definition postfix (s : state_t) : Prop :=
  forall (cn : InterNode.t)  ,
    postfix_cmd cn s
    /\ postfix_intra_edge cn s
    /\ postfix_intra_call cn s
    /\ postfix_inter_call cn s
    /\ postfix_inter_ret cn s.

Definition sound_amap_run (s : state_t) :=
  forall cn cmd (Hcmd : Some cmd = InterCfg.get_cmd pgm cn),
    Acc.le
      (Acc.get_acc (run_access mode g cn cmd (s (cn, SemCommon.Inputof))))
      (get_access (InterNode.get_pid cn) amap).

Definition sound_amap_reachable :=
  forall f1 f2 (Hr : InterCfg.reachable pgm f1 f2),
    Acc.le (get_access f2 amap) (get_access f1 amap).

Definition sound_amap (s : state_t) : Prop :=
  sound_amap_run s /\ sound_amap_reachable.

End Sem.

Local Close Scope type.

End Make.


(* Do not edit this file, it was generated automatically *)
(** Heavily annotated for a tutorial introduction. *)

(** First, import the entire Floyd proof automation system, which includes
 ** the VeriC program logic and the MSL theory of separation logic**)
Require Import VST.floyd.proofauto.

(** Import the [reverse.v] file, which is produced by CompCert's clightgen
 ** from reverse.c.   The file reverse.v defines abbreviations for identifiers
 ** (variable names, etc.) of the C program, such as _head, _reverse.
 ** It also defines "prog", which is the entire abstract syntax tree
 ** of the C program *)
Require Import VST.progs64.reverse.

(* The C programming language has a special namespace for struct
** and union identifiers, e.g., "struct foo {...}".  Some type-based operators
** in the program logic need access to an interpretation of this namespace,
** i.e., the meaning of each struct-identifier such as "foo".  The next
** line (which looks identical for any program) builds this
** interpretation, called "CompSpecs" *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.

(** Calculate the "types-of-global-variables" specification
 ** directly from the program *)
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** A convenience definition *)
Definition t_struct_list := Tstruct _list noattr.

(** Inductive definition of linked lists *)
Fixpoint listrep (sigma: list val) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
      data_at Tsh t_struct_list (h,y) x  *  listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Arguments listrep sigma x : simpl never.

(** Whenever you define a new spatial operator, such as
 ** [listrep] here, it's useful to populate two hint databases.
 ** The [saturate_local] hint is a lemma that extracts
 ** pure propositional facts from a spatial fact.
 ** The [valid_pointer] hint is a lemma that extracts a
 ** valid-pointer fact from a spatial lemma.
 **)

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil)).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros; normalize.
apply prop_right; split; simpl; auto. intuition.
entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep;
 intros; normalize.
 auto with valid_pointer.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

(** Specification of the [reverse] function.  It characterizes
 ** the precondition required for calling the function,
 ** and the postcondition guaranteed by the function.
 **)
Definition reverse_spec :=
 DECLARE _reverse
  WITH sigma : list val, p: val
  PRE  [ _p OF (tptr t_struct_list) ]
     PROP ()
     LOCAL (temp _p p)
     SEP (listrep sigma p)
  POST [ (tptr t_struct_list) ]
    EX q:val,
     PROP () LOCAL (temp ret_temp q)
     SEP (listrep(rev sigma) q).

(** The global function spec, characterizing the
 ** preconditions/postconditions of all the functions
 ** that your proved-correct program will call.
 ** Normally you include all the functions here, but
 ** in this tutorial example we include only one. *)
Definition Gprog : funspecs :=
         ltac:(with_library prog [ reverse_spec ]).

(** For each function definition in the C program, prove that the
 ** function-body (in this case, f_reverse) satisfies its specification
 ** (in this case, reverse_spec).
 **)
Lemma body_reverse: semax_body Vprog Gprog
                                    f_reverse reverse_spec.
Proof.
(** The start_function tactic "opens up" a semax_body
 ** proof goal into a Hoare triple. *)
start_function.
(** For each assignment statement, "symbolically execute" it
 ** using the forward tactic *)
forward.  (* w = NULL; *)
forward.  (* v = p; *)
(** To prove a while-loop, you must supply a loop invariant,
 ** in this case (EX s1  PROP(...)LOCAL(...)(SEP(...)).  *)
forward_while
   (EX s1: list val, EX s2 : list val,
    EX w: val, EX v: val,
     PROP (sigma = rev s1 ++ s2)
     LOCAL (temp _w w; temp _v v)
     SEP (listrep s1 w; listrep s2 v)).
(** The forward_while tactic leaves four subgoals,
 ** which we mark with * (the Coq "bullet") *)
* (* Prove that precondition implies loop invariant *)
Exists (@nil val) sigma nullval p.
entailer!.
unfold listrep.
entailer!.
* (* Prove that loop invariant implies typechecking of loop condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
destruct s2 as [ | h r].
 - unfold listrep at 2.
   Intros. subst. contradiction.
 - unfold listrep at 2; fold listrep.
   Intros y.
   forward. (* t = v->tail *)
   forward. (* v->tail = w; *)
   forward. (* w = v; *)
   forward. (* v = t; *)
   (* At end of loop body; reestablish invariant *)
   entailer!.
   Exists (h::s1,r,v,y).
   entailer!.
   + simpl. rewrite app_ass. auto.
   + unfold listrep at 3; fold listrep.
     Exists w. entailer!.
* (* after the loop *)
forward.  (* return w; *)
Exists w; entailer!.
rewrite (proj1 H1) by auto.
unfold listrep at 2; fold listrep.
entailer!.
rewrite <- app_nil_end, rev_involutive.
auto.
Qed.

(** See the file [progs/verif_reverse.v] for an alternate
 ** proof of this function, using a general theory of
 ** list segments.  That file also has proofs of the
 ** sumlist function, the main function, and the
 ** [semax_func] theorem that ties all the functions together
 **)


(**
 * Special handling of ascii and strings for extraction to Haskell.
 *)

Require Coq.extraction.Extraction.

Require Import Ascii.
Require Import String.

(**
 * At the moment, Coq's extraction has no way to add extra import
 * statements to the extracted Haskell code.  You will have to
 * manually add:
 *
 *   import qualified Data.Bits
 *   import qualified Data.Char
 *)

Extract Inductive ascii => "Prelude.Char"
  [ "(\b0 b1 b2 b3 b4 b5 b6 b7 -> Data.Char.chr (
      (if b0 then Data.Bits.shiftL 1 0 else 0) Prelude.+
      (if b1 then Data.Bits.shiftL 1 1 else 0) Prelude.+
      (if b2 then Data.Bits.shiftL 1 2 else 0) Prelude.+
      (if b3 then Data.Bits.shiftL 1 3 else 0) Prelude.+
      (if b4 then Data.Bits.shiftL 1 4 else 0) Prelude.+
      (if b5 then Data.Bits.shiftL 1 5 else 0) Prelude.+
      (if b6 then Data.Bits.shiftL 1 6 else 0) Prelude.+
      (if b7 then Data.Bits.shiftL 1 7 else 0)))" ]
  "(\f a -> f (Data.Bits.testBit (Data.Char.ord a) 0)
              (Data.Bits.testBit (Data.Char.ord a) 1)
              (Data.Bits.testBit (Data.Char.ord a) 2)
              (Data.Bits.testBit (Data.Char.ord a) 3)
              (Data.Bits.testBit (Data.Char.ord a) 4)
              (Data.Bits.testBit (Data.Char.ord a) 5)
              (Data.Bits.testBit (Data.Char.ord a) 6)
              (Data.Bits.testBit (Data.Char.ord a) 7))".
Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)".

Extract Inductive string => "Prelude.String" [ "([])" "(:)" ].
Extract Inlined Constant String.string_dec => "(Prelude.==)".


From HTTP Require Export
     Tester.
From App Require Export
     Observe.

Definition solver_state := list (var * (N + list N)).

Definition assertN (nx : exp N) (n : N) (s : solver_state)
  : option solver_state :=
  match nx with
  | Exp__Var x =>
    match get x s with
    | Some (inl n0) => if n0 =? n then Some s else None
    | Some (inr ns) => if existsb (N.eqb n) ns
                      then None
                      else Some $ update x (inl n) s
    | None => Some $ put x (inl n) s
    end
  | Exp__Const n0 => if n0 =? n then Some s else None
  | Exp__Nth _ _  => None
  end.

Definition assertNotN (nx : exp N) (n : N) (s : solver_state)
  : option solver_state :=
  match nx with
  | Exp__Var x =>
    match get x s with
    | Some (inl n0) => if n0 =? n then None else Some s
    | Some (inr ns) => Some $ update x (inr (n::ns)) s
    | None => Some $ put x (inr [n]) s
    end
  | Exp__Const n0 => if n0 =? n then None else Some s
  | Exp__Nth _ _ => None
  end.

Definition unifyOrder (s : solver_state) (ox : orderT exp) (o : orderT id)
  : option solver_state :=
  let '((oidx, (bix, bax, six, sax)), (oid, (bi, ba, si, sa))) := (ox, o) in
  if (bax, sax) = (ba, sa)?
  then assertN oidx oid s >>= assertN bix bi >>= assertN six si
  else None.

Definition unifyAccount (s : solver_state) (ax : accountT exp) (a : accountT id)
  : option solver_state :=
  let '((aidx, vx), (aid, v)) := (ax, a) in
  if vx = v? then assertN aidx aid s else None.

Definition unifyList {A : (Type -> Type) -> Type}
           (unifier : solver_state -> A exp -> A id -> option solver_state)
           (lx : list (A exp)) (l : list (A id)) (s : solver_state)
  : option solver_state :=
  if length lx =? length l
  then fold_left (fun os ab => os >>= (fun s => uncurry (unifier s) ab))
                 (zip lx l) (pure s)
  else None.

Fixpoint eval_nth_const {E} `{decideE -< E} `{failureE -< E}
           (n : N) (l : list (exp N))
  : Monads.stateT solver_state (itree E) nat :=
  fun s =>
    match l with
    | [] => ret (s, O)
    | x::l' =>
      let left  s1 := ret (s1, O) in
      let right s2 := '(s3, n') <- eval_nth_const n l' s2;;
                      ret (s3, S n') in
      match assertN x n s, assertNotN x n s with
      | Some s1, Some s2 =>
        b <- trigger Decide;;
        if b : bool then left s1 else right s2
      | Some s1, None => left s1
      | None, Some s2 => right s2
      | None, None => throw "Unsatisfiable"
      end
    end.

Fixpoint find_nth {A} (f : A -> bool) (l : list A) : option nat :=
  if l is a::l'
  then if f a then Some O else S <$> find_nth f l'
  else None.

Definition eval_nth {E} `{decideE -< E} `{failureE -< E}
         (x : exp N) (l : list (exp N))
  : Monads.stateT solver_state (itree E) nat :=
  fun s =>
    if find_nth (exp_eq x) l is Some n
    then ret (s, n)
    else
      match x with
      | Exp__Var x =>
        match get x s with
        | Some (inl n) => eval_nth_const n l s
        | _ => ret (s, length l)
        end
      | Exp__Const n => eval_nth_const n l s
      | _ => throw "Should not happen: eval_nth"
      end.

Definition instantiate_unify {E A} `{failureE -< E} `{decideE -< E}
           (e : unifyE swap_response A)
  : Monads.stateT solver_state (itree E) A :=
  fun s : solver_state =>
    match e with
    | Unify__Fresh =>
      let x : var := fresh_var s in
      ret (put x (inr []) s, Exp__Var x)
    | Unify__Eval v =>
      if v is Exp__Nth n l
      then eval_nth n l s
      else throw "Should not happen: instantiate_unify"
    | Unify__Match rx r =>
      let mismatch := throw $ "Expect " ++ to_string rx
                            ++ " but observed " ++ to_string r
                            ++ " under " ++ to_string s in
      let handle os' := if os' is Some s' then ret (s', tt) else mismatch in
      match rx, r with
      | Response__BadRequest      , Response__BadRequest
      | Response__InsufficientFund, Response__InsufficientFund
      | Response__NotFound        , Response__NotFound => ret (s, tt)
      | Response__ListAccount lx  , Response__ListAccount l =>
        handle $ unifyList (A:=accountT) unifyAccount lx l s
      | Response__ListOrders  lx  , Response__ListOrders  l =>
        handle $ unifyList (A:=orderT) unifyOrder lx l s
      | Response__ListAccount [], Response__ListOrders  []
      | Response__ListOrders  [], Response__ListAccount [] => ret (s, tt)
      | Response__Account ax, Response__Account a => handle $ unifyAccount s ax a
      | Response__Order   ox, Response__Order   o => handle $ unifyOrder   s ox o
      | _, _ => mismatch
      end
    end.

Definition solver' {E F} `{failureE -< E} `{decideE -< E} `{F -< E}
           (m : itree (unifyE swap_response +' F) void)
  : Monads.stateT solver_state (itree E) void :=
  interp
    (fun _ e =>
       match e with
       | (ue|) => instantiate_unify ue
       | (|ee)  => liftState (F:=itree _) (trigger ee)
       end) m.

Definition solver {E F} `{failureE -< E} `{decideE -< E} `{F -< E}
           (m : itree (unifyE swap_response +' F) void) : itree E void :=
  snd <$> solver' m [].

Class Is__stE q r s E `{failureE -< E} `{decideE -< E} `{observeE q r s -< E}.
Notation stE q r s := (failureE +' decideE +' observeE q r s).
Instance stE_Is__stE q r s : Is__stE q r s (stE q r s). Defined.

Definition solve_swap {E}
           `{Is__stE (swap_request id) (swap_response id) (swap_state exp) E}
           : swap_state exp -> itree E void
  := solver ∘ observe_swap.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import BaremoreHandler.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition smc_mark_nonsecure_spec0 (addr: Z64) (adt: RData) : option RData :=
    match addr with
    | VZ64 _addr =>
      rely is_int64 (3288334336 + 257);
      rely is_int (3288334336 + 257);
      rely is_int64 _addr;
      when adt == set_monitor_call_spec (3288334336 + 257) (VZ64 _addr) adt;
      when adt == el3_sync_lel_spec  adt;
      when' _t'1 == get_monitor_call_ret_spec  adt;
      rely is_int64 _t'1;
      rely is_int _t'1;
      let _ret := _t'1 in
      rely is_int (1 - _ret);
      when adt == assert_cond_spec (1 - _ret) adt;
      Some adt
     end
    .

End SpecLow.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype fintype choice ssrfun seq path.

From mathcomp.ssreflect
Require Import tuple.

Set Implicit Arguments.

From Probchain
Require Import BlockChain InvMisc FixedList FixedMap Parameters.

Definition oraclestate_keytype := [eqType of ([eqType of ([eqType of Nonce] * [eqType of Hashed] * [eqType of BlockRecord])] )%type].

Definition OracleState := fixmap  oraclestate_keytype  [eqType of Hashed] oraclestate_size.

Definition oraclestate_new : OracleState := fixmap_empty oraclestate_keytype [eqType of Hashed] oraclestate_size.

Definition oraclestate_find k (m : OracleState) := fixmap_find k m.

Definition oraclestate_put (k: oraclestate_keytype) (v : Hashed) (m: OracleState) : OracleState :=
  fixmap_put k v m.

Canonical oraclestate_of_eqType := Eval hnf in [eqType of (OracleState)].
Canonical oraclestate_of_choiceType := Eval hnf in [choiceType of (OracleState)].
Canonical oraclestate_of_countType := Eval hnf in [countType of (OracleState)].
Canonical oraclestate_of_finType := Eval hnf in [finType of (OracleState)].


Require Import Kami.AllNotations.

Require Import ProcKami.FU.

Section pmp.
  Context {procParams: ProcParams}.
  Variable ty: Kind -> Type.

  Local Open Scope kami_expr.
  Local Open Scope kami_action.

  Local Definition PmpEntryPkt
    := STRUCT_TYPE {
         "cfg" :: PmpCfg ;
         "addr" :: Bit pmp_reg_width
         }.

  Local Definition pmp_entry_read
    (n : nat)
    :  ActionT ty PmpEntryPkt
    := Read entry_cfg
         :  PmpCfg
         <- @^("pmp" ++ natToHexStr n ++ "cfg");
       Read entry_addr
         :  Bit pmp_reg_width
         <- @^("pmpaddr" ++ natToHexStr n);
       Ret
         (STRUCT {
            "cfg" ::= #entry_cfg;
            "addr" ::= #entry_addr
          } : PmpEntryPkt @# ty).

  Local Definition pmp_addr_acc_kind
    := STRUCT_TYPE {
         "any_matched" :: Bool;
         "all_matched" :: Bool
       }.

  Local Definition pmp_entry_acc_kind
    := STRUCT_TYPE {
         "any_on"  :: Bool;
         "addr"    :: PAddr;
         "matched" :: Bool;
         "pmp_cfg" :: PmpCfg
       }.

  Local Definition div_up x y
    := (if Nat.eqb (x mod y) 0
         then x / y
         else S (x / y))%nat.

  Definition checkPmp
    (check : AccessType @# ty)
    (mode : PrivMode @# ty)
    (addr : PAddr @# ty)
    (addr_len : MemRqLgSize @# ty)
    :  ActionT ty Bool
    := (* System [
         DispString _ "[checkPmp] addr: ";
         DispHex addr;
         DispString _ "\n";
         DispString _ "[checkPmp] addr len: ";
         DispHex addr_len;
         DispString _ "\n"
       ]; *)
       LETA result
         :  pmp_entry_acc_kind
         <- fold_left
              (fun (acc_act : ActionT ty pmp_entry_acc_kind) entry_index
                => LETA acc <- acc_act;
(*
                   System [
                     DispString _ "[checkPmp] ==================================================\n";
                     DispString _ ("[checkPmp] checking register: pmp" ++ natToHexStr (S entry_index) ++ "cfg.\n");
                     DispString _ "[checkPmp] acc: ";
                     DispHex #acc;
                     DispString _ "\n"
                   ];
*)
                   LETA entry
                     :  PmpEntryPkt
                     <- pmp_entry_read entry_index;
                   LET tor
                     :  PAddr
                     <- ((ZeroExtendTruncLsb PAddrSz (#entry @% "addr")) << (Const ty (natToWord 2 2)));
(*
                   System [
                     DispString _ "[checkPmp] entry: ";
                     DispHex #entry;
                     DispString _ "\n";
                     DispString _ "[checkPmp] entry addr: ";
                     DispHex (#entry @% "addr");
                     DispString _ "\n";
                     DispString _ "[checkPmp] sign extended entry addr: ";
                     DispHex (#entry @% "addr");
                     DispString _ "\n";
                     DispString _ "[checkPmp] tor: ";
                     DispHex #tor;
                     DispString _ "\n"
                   ];
*)
                   LET mask0
                     :  PAddr
                     <- ((ZeroExtendTruncLsb PAddrSz (#entry @% "addr")) << (Const ty (natToWord 1 1))) .| $1;
                   LET mask
                     :  PAddr
                     <- ~ (#mask0 .&  (~ (#mask0 + $1))) << (Const ty (natToWord 2 2));
(*
                   System [
                     DispString _ "[checkPmp] mask: ";
                     DispHex #mask;
                     DispString _ "\n"
                   ];
*)
                   GatherActions
                     (map
                       (fun index
                         => LET offset
                              :  Bit MemRqSize
                              <- Const ty (natToWord MemRqSize (4 * index)%nat);
                            If #offset < ($1 << addr_len)
                              then
                                LET curr_addr
                                  :  PAddr
                                  <- (addr + (ZeroExtendTruncLsb PAddrSz #offset));
                                LET napot_match
                                  :  Bool
                                  <- ((CABit Bxor [#curr_addr; #tor]) .&  #mask) == $0;
                                LET tor_match
                                  :  Bool
                                  <- (#acc @% "addr" <= #curr_addr) &&  (#curr_addr < #tor);
                                LET matched
                                  :  Bool
                                  <- IF #entry @% "cfg" @% "A" == $1
                                       then #tor_match
                                       else #napot_match;
                                Ret (Valid #matched : Maybe Bool @# ty)
                              else Ret Invalid
                              as result;
                            Ret #result)
                       (seq 0 (div_up Rlen_over_8 4)))
                     as match_results;
                   LET addr_result
                     :  pmp_addr_acc_kind
                     <- STRUCT {
                          "any_matched"
                            ::= (@Kor _ Bool)
                                  (map
                                    (fun result : Maybe Bool @# ty
                                      => result @% "valid" &&  result @% "data")
                                    match_results);
                          "all_matched"
                            ::= CABool And
                                  (map
                                    (fun result : Maybe Bool @# ty
                                      => !(result @% "valid") || result @% "data")
                                    match_results)
                        } : pmp_addr_acc_kind @# ty;
                   LET isOff <- #entry @% "cfg" @% "A" == $0;
                   Ret (STRUCT {
                            "any_on"  ::= ((#acc @% "any_on") || !#isOff) ;
                            "addr"    ::= #tor ;
                            "matched" ::= ((#acc @% "matched") ||
                                           (!#isOff &&  #addr_result @% "all_matched"));
                            "pmp_cfg" ::= (IF #acc @% "matched"
                                           then #acc @% "pmp_cfg"
                                           else #entry @% "cfg") }: pmp_entry_acc_kind @# ty))
              (seq 0 16)
              (Ret (STRUCT {
                 "any_on"  ::= $$false;
                 "addr"    ::= $$(getDefaultConst PAddr);
                 "matched" ::= $$false;
                 "pmp_cfg" ::= $$(getDefaultConst PmpCfg)
               } : pmp_entry_acc_kind @# ty));
(*
    System [
         DispString _ "[checkPmp] ##################################################\n";
         DispString _ "[checkPmp] result: ";
         DispHex #result;
         DispString _ "\n"
       ];
*)
       Ret
         (IF #result @% "matched"
          then
             (mode == $MachineMode &&  !(#result @% "pmp_cfg" @% "L")) ||
             (Switch check Retn Bool With {
               ($VmAccessLoad : AccessType @# ty)
                 ::= #result @% "pmp_cfg" @% "R";
               ($VmAccessSAmo : AccessType @# ty)
                 ::= #result @% "pmp_cfg" @% "R" &&  #result @% "pmp_cfg" @% "W";
               ($VmAccessInst : AccessType @# ty)
                 ::= #result @% "pmp_cfg" @% "X"
             })
           else
             (!(#result @% "any_on") || mode == $MachineMode)).

  Local Close Scope kami_action.
  Local Close Scope kami_expr.

End pmp.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype.
Require Import finfun paths ssralg.
(*Require Import div connect.*)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Reserved Notation "\big [ op / nil ]_ i F"
  (at level 36, F at level 36, op, nil at level 10, i at level 0,
     right associativity,
           format "'[' \big [ op / nil ]_ i '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( <- r | P ) F"
  (at level 36, F at level 36, op, nil at level 10, r at level 50,
           format "'[' \big [ op / nil ]_ ( <-  r  |  P ) '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( i <- r | P ) F"
  (at level 36, F at level 36, op, nil at level 10, i, r at level 50,
           format "'[' \big [ op / nil ]_ ( i  <-  r  |  P ) '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( i <- r ) F"
  (at level 36, F at level 36, op, nil at level 10, i, r at level 50,
           format "'[' \big [ op / nil ]_ ( i  <-  r ) '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( m <= i < n | P ) F"
  (at level 36, F at level 36, op, nil at level 10, m, i, n at level 50,
           format "'[' \big [ op / nil ]_ ( m  <=  i  <  n  |  P )  F ']'").
Reserved Notation "\big [ op / nil ]_ ( m <= i < n ) F"
  (at level 36, F at level 36, op, nil at level 10, i, m, n at level 50,
           format "'[' \big [ op / nil ]_ ( m  <=  i  <  n ) '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( i | P ) F"
  (at level 36, F at level 36, op, nil at level 10, i at level 50,
           format "'[' \big [ op / nil ]_ ( i  |  P ) '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( i : t | P ) F"
  (at level 36, F at level 36, op, nil at level 10, i at level 50,
           format "'[' \big [ op / nil ]_ ( i   :  t   |  P ) '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( i : t ) F"
  (at level 36, F at level 36, op, nil at level 10, i at level 50,
           format "'[' \big [ op / nil ]_ ( i   :  t ) '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( i < n | P ) F"
  (at level 36, F at level 36, op, nil at level 10, i, n at level 50,
           format "'[' \big [ op / nil ]_ ( i  <  n  |  P ) '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( i < n ) F"
  (at level 36, F at level 36, op, nil at level 10, i, n at level 50,
           format "'[' \big [ op / nil ]_ ( i  <  n )  F ']'").
Reserved Notation "\big [ op / nil ]_ ( i \in A | P ) F"
  (at level 36, F at level 36, op, nil at level 10, i, A at level 50,
           format "'[' \big [ op / nil ]_ ( i  \in  A  |  P ) '/  '  F ']'").
Reserved Notation "\big [ op / nil ]_ ( i \in A ) F"
  (at level 36, F at level 36, op, nil at level 10, i, A at level 50,
           format "'[' \big [ op / nil ]_ ( i  \in  A ) '/  '  F ']'").

Reserved Notation "\sum_ i F"
  (at level 41, F at level 41, i at level 0,
           right associativity,
           format "'[' \sum_ i '/  '  F ']'").
Reserved Notation "\sum_ ( <- r | P ) F"
  (at level 41, F at level 41, r at level 50,
           format "'[' \sum_ ( <-  r  |  P ) '/  '  F ']'").
Reserved Notation "\sum_ ( i <- r | P ) F"
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \sum_ ( i  <-  r  |  P ) '/  '  F ']'").
Reserved Notation "\sum_ ( i <- r ) F"
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \sum_ ( i  <-  r ) '/  '  F ']'").
Reserved Notation "\sum_ ( m <= i < n | P ) F"
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \sum_ ( m  <=  i  <  n  |  P ) '/  '  F ']'").
Reserved Notation "\sum_ ( m <= i < n ) F"
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \sum_ ( m  <=  i  <  n ) '/  '  F ']'").
Reserved Notation "\sum_ ( i | P ) F"
  (at level 41, F at level 41, i at level 50,
           format "'[' \sum_ ( i  |  P ) '/  '  F ']'").
Reserved Notation "\sum_ ( i : t | P ) F"
  (at level 41, F at level 41, i at level 50,
           only parsing).
Reserved Notation "\sum_ ( i : t ) F"
  (at level 41, F at level 41, i at level 50,
           only parsing).
Reserved Notation "\sum_ ( i < n | P ) F"
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \sum_ ( i  <  n  |  P ) '/  '  F ']'").
Reserved Notation "\sum_ ( i < n ) F"
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \sum_ ( i  <  n ) '/  '  F ']'").
Reserved Notation "\sum_ ( i \in A | P ) F"
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \sum_ ( i  \in  A  |  P ) '/  '  F ']'").
Reserved Notation "\sum_ ( i \in A ) F"
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \sum_ ( i  \in  A ) '/  '  F ']'").

Reserved Notation "\max_ i F"
  (at level 41, F at level 41, i at level 0,
           format "'[' \max_ i '/  '  F ']'").
Reserved Notation "\max_ ( <- r | P ) F"
  (at level 41, F at level 41, r at level 50,
           format "'[' \max_ ( <-  r  |  P ) '/  '  F ']'").
Reserved Notation "\max_ ( i <- r | P ) F"
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \max_ ( i  <-  r  |  P ) '/  '  F ']'").
Reserved Notation "\max_ ( i <- r ) F"
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \max_ ( i  <-  r ) '/  '  F ']'").
Reserved Notation "\max_ ( m <= i < n | P ) F"
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \max_ ( m  <=  i  <  n  |  P ) '/  '  F ']'").
Reserved Notation "\max_ ( m <= i < n ) F"
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \max_ ( m  <=  i  <  n ) '/  '  F ']'").
Reserved Notation "\max_ ( i | P ) F"
  (at level 41, F at level 41, i at level 50,
           format "'[' \max_ ( i  |  P ) '/  '  F ']'").
Reserved Notation "\max_ ( i : t | P ) F"
  (at level 41, F at level 41, i at level 50,
           only parsing).
Reserved Notation "\max_ ( i : t ) F"
  (at level 41, F at level 41, i at level 50,
           only parsing).
Reserved Notation "\max_ ( i < n | P ) F"
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \max_ ( i  <  n  |  P ) '/  '  F ']'").
Reserved Notation "\max_ ( i < n ) F"
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \max_ ( i  <  n )  F ']'").
Reserved Notation "\max_ ( i \in A | P ) F"
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \max_ ( i  \in  A  |  P ) '/  '  F ']'").
Reserved Notation "\max_ ( i \in A ) F"
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \max_ ( i  \in  A ) '/  '  F ']'").

Reserved Notation "\prod_ i F"
  (at level 36, F at level 36, i at level 0,
           format "'[' \prod_ i '/  '  F ']'").
Reserved Notation "\prod_ ( <- r | P ) F"
  (at level 36, F at level 36, r at level 50,
           format "'[' \prod_ ( <-  r  |  P ) '/  '  F ']'").
Reserved Notation "\prod_ ( i <- r | P ) F"
  (at level 36, F at level 36, i, r at level 50,
           format "'[' \prod_ ( i  <-  r  |  P ) '/  '  F ']'").
Reserved Notation "\prod_ ( i <- r ) F"
  (at level 36, F at level 36, i, r at level 50,
           format "'[' \prod_ ( i  <-  r ) '/  '  F ']'").
Reserved Notation "\prod_ ( m <= i < n | P ) F"
  (at level 36, F at level 36, i, m, n at level 50,
           format "'[' \prod_ ( m  <=  i  <  n  |  P ) '/  '  F ']'").
Reserved Notation "\prod_ ( m <= i < n ) F"
  (at level 36, F at level 36, i, m, n at level 50,
           format "'[' \prod_ ( m  <=  i  <  n ) '/  '  F ']'").
Reserved Notation "\prod_ ( i | P ) F"
  (at level 36, F at level 36, i at level 50,
           format "'[' \prod_ ( i  |  P ) '/  '  F ']'").
Reserved Notation "\prod_ ( i : t | P ) F"
  (at level 36, F at level 36, i at level 50,
           only parsing).
Reserved Notation "\prod_ ( i : t ) F"
  (at level 36, F at level 36, i at level 50,
           only parsing).
Reserved Notation "\prod_ ( i < n | P ) F"
  (at level 36, F at level 36, i, n at level 50,
           format "'[' \prod_ ( i  <  n  |  P ) '/  '  F ']'").
Reserved Notation "\prod_ ( i < n ) F"
  (at level 36, F at level 36, i, n at level 50,
           format "'[' \prod_ ( i  <  n ) '/  '  F ']'").
Reserved Notation "\prod_ ( i \in A | P ) F"
  (at level 36, F at level 36, i, A at level 50,
           format "'[' \prod_ ( i  \in  A  |  P )  F ']'").
Reserved Notation "\prod_ ( i \in A ) F"
  (at level 36, F at level 36, i, A at level 50,
           format "'[' \prod_ ( i  \in  A ) '/  '  F ']'").

Delimit Scope big_scope with BIG.
Open Scope big_scope.

Definition reducebig R I nil op r (P : pred I) (F : I -> R) : R :=
  foldr (fun i x => if P i then op (F i) x else x) nil r.

Module Type ReduceBigSig.
Parameter bigop : forall R I,
   R -> (R -> R -> R) -> seq I -> pred I -> (I -> R) -> R.
Axiom bigopE : bigop = reducebig.
End ReduceBigSig.

Module ReduceBig : ReduceBigSig.
Definition bigop := reducebig.
Lemma bigopE : bigop = reducebig. Proof. by []. Qed.
End ReduceBig.

Notation bigop := ReduceBig.bigop.
Canonical Structure reduce_big_unlock := Unlockable ReduceBig.bigopE.

Definition index_iota m n := iota m (n - m).

Definition index_enum (T : finType) := enum T.

Lemma mem_index_iota : forall m n i, i \in index_iota m n = (m <= i < n).
Proof.
move=> m n i; rewrite mem_iota; case le_m_i: (m <= i) => //=.
by rewrite -leq_sub_add leq_subS // -ltn_0sub subn_sub subnK // ltn_0sub.
Qed.

Lemma filter_index_enum : forall T P, filter P (index_enum T) = enum P.
Proof. by move=> T P; rewrite /enum -enumE. Qed.

Notation "\big [ op / nil ]_ ( <- r | P ) F" :=
  (bigop nil op r P F) : big_scope.
Notation "\big [ op / nil ]_ ( i <- r | P ) F" :=
  (bigop nil op r (fun i => P%B) (fun i => F)) : big_scope.
Notation "\big [ op / nil ]_ ( i <- r ) F" :=
  (bigop nil op r (fun _ => true) (fun  i => F)) : big_scope.
Notation "\big [ op / nil ]_ ( m <= i < n | P ) F" :=
  (bigop nil op (index_iota m n) (fun i : nat => P%B) (fun i : nat => F))
     : big_scope.
Notation "\big [ op / nil ]_ ( m <= i < n ) F" :=
  (bigop nil op (index_iota m n) (fun _ => true) (fun i : nat => F))
     : big_scope.
Notation "\big [ op / nil ]_ ( i | P ) F" :=
  (bigop nil op (index_enum _) (fun i => P%B) (fun i => F)) : big_scope.
Notation "\big [ op / nil ]_ i F" :=
  (bigop nil op (index_enum _) (fun _ => true) (fun i => F)) : big_scope.
Notation "\big [ op / nil ]_ ( i : t | P ) F" :=
  (bigop nil op (index_enum _) (fun i : t => P%B) (fun i : t => F))
     (only parsing) : big_scope.
Notation "\big [ op / nil ]_ ( i : t ) F" :=
  (bigop nil op (index_enum _) (fun _ => true) (fun i : t => F))
     (only parsing) : big_scope.
Notation "\big [ op / nil ]_ ( i < n | P ) F" :=
  (\big[op/nil]_(i : ordinal n | P%B) F) : big_scope.
Notation "\big [ op / nil ]_ ( i < n ) F" :=
  (\big[op/nil]_(i : ordinal n) F) : big_scope.
Notation "\big [ op / nil ]_ ( i \in A | P ) F" :=
  (\big[op/nil]_(i | (i \in A) && P) F) : big_scope.
Notation "\big [ op / nil ]_ ( i \in A ) F" :=
  (\big[op/nil]_(i | i \in A) F) : big_scope.

Notation Local "'+%R'" := (@Ring.add _) (at level 0).
Notation Local "'+%N'" := addn (at level 0, only parsing).

Notation "\sum_ ( <- r | P ) F" :=
  (\big[+%R/0%R]_(<- r | P%B) F%R) : ring_scope.
Notation "\sum_ ( i <- r | P ) F" :=
  (\big[+%R/0%R]_(i <- r | P%B) F%R) : ring_scope.
Notation "\sum_ ( i <- r ) F" :=
  (\big[+%R/0%R]_(i <- r) F%R) : ring_scope.
Notation "\sum_ ( m <= i < n | P ) F" :=
  (\big[+%R/0%R]_(m <= i < n | P%B) F%R) : ring_scope.
Notation "\sum_ ( m <= i < n ) F" :=
  (\big[+%R/0%R]_(m <= i < n) F%R) : ring_scope.
Notation "\sum_ ( i | P ) F" :=
  (\big[+%R/0%R]_(i | P%B) F%R) : ring_scope.
Notation "\sum_ i F" :=
  (\big[+%R/0%R]_i F%R) : ring_scope.
Notation "\sum_ ( i : t | P ) F" :=
  (\big[+%R/0%R]_(i : t | P%B) F%R) (only parsing) : ring_scope.
Notation "\sum_ ( i : t ) F" :=
  (\big[+%R/0%R]_(i : t) F%R) (only parsing) : ring_scope.
Notation "\sum_ ( i < n | P ) F" :=
  (\big[+%R/0%R]_(i < n | P%B) F%R) : ring_scope.
Notation "\sum_ ( i < n ) F" :=
  (\big[+%R/0%R]_(i < n) F%R) : ring_scope.
Notation "\sum_ ( i \in A | P ) F" :=
  (\big[+%R/0%R]_(i \in A | P%B) F%R) : ring_scope.
Notation "\sum_ ( i \in A ) F" :=
  (\big[+%R/0%R]_(i \in A) F%R) : ring_scope.

Notation "\sum_ ( <- r | P ) F" :=
  (\big[+%N/0%N]_(<- r | P%B) F%N) : nat_scope.
Notation "\sum_ ( i <- r | P ) F" :=
  (\big[+%N/0%N]_(i <- r | P%B) F%N) : nat_scope.
Notation "\sum_ ( i <- r ) F" :=
  (\big[+%N/0%N]_(i <- r) F%N) : nat_scope.
Notation "\sum_ ( m <= i < n | P ) F" :=
  (\big[+%N/0%N]_(m <= i < n | P%B) F%N) : nat_scope.
Notation "\sum_ ( m <= i < n ) F" :=
  (\big[+%N/0%N]_(m <= i < n) F%N) : nat_scope.
Notation "\sum_ ( i | P ) F" :=
  (\big[+%N/0%N]_(i | P%B) F%N) : nat_scope.
Notation "\sum_ i F" :=
  (\big[+%N/0%N]_i F%N) : nat_scope.
Notation "\sum_ ( i : t | P ) F" :=
  (\big[+%N/0%N]_(i : t | P%B) F%N) (only parsing) : nat_scope.
Notation "\sum_ ( i : t ) F" :=
  (\big[+%N/0%N]_(i : t) F%N) (only parsing) : nat_scope.
Notation "\sum_ ( i < n | P ) F" :=
  (\big[+%N/0%N]_(i < n | P%B) F%N) : nat_scope.
Notation "\sum_ ( i < n ) F" :=
  (\big[+%N/0%N]_(i < n) F%N) : nat_scope.
Notation "\sum_ ( i \in A | P ) F" :=
  (\big[+%N/0%N]_(i \in A | P%B) F%N) : nat_scope.
Notation "\sum_ ( i \in A ) F" :=
  (\big[+%N/0%N]_(i \in A) F%N) : nat_scope.

Notation Local "'*%R'" := (@Ring.mul _) (at level 0).
Notation Local "'*%N'" := muln (at level 0, only parsing).

Notation "\prod_ ( <- r | P ) F" :=
  (\big[*%R/1%R]_(<- r | P%B) F%R) : ring_scope.
Notation "\prod_ ( i <- r | P ) F" :=
  (\big[*%R/1%R]_(i <- r | P%B) F%R) : ring_scope.
Notation "\prod_ ( i <- r ) F" :=
  (\big[*%R/1%R]_(i <- r) F%R) : ring_scope.
Notation "\prod_ ( m <= i < n | P ) F" :=
  (\big[*%R/1%R]_(m <= i < n | P%B) F%R) : ring_scope.
Notation "\prod_ ( m <= i < n ) F" :=
  (\big[*%R/1%R]_(m <= i < n) F%R) : ring_scope.
Notation "\prod_ ( i | P ) F" :=
  (\big[*%R/1%R]_(i | P%B) F%R) : ring_scope.
Notation "\prod_ i F" :=
  (\big[*%R/1%R]_i F%R) : ring_scope.
Notation "\prod_ ( i : t | P ) F" :=
  (\big[*%R/1%R]_(i : t | P%B) F%R) (only parsing) : ring_scope.
Notation "\prod_ ( i : t ) F" :=
  (\big[*%R/1%R]_(i : t) F%R) (only parsing) : ring_scope.
Notation "\prod_ ( i < n | P ) F" :=
  (\big[*%R/1%R]_(i < n | P%B) F%R) : ring_scope.
Notation "\prod_ ( i < n ) F" :=
  (\big[*%R/1%R]_(i < n) F%R) : ring_scope.
Notation "\prod_ ( i \in A | P ) F" :=
  (\big[*%R/1%R]_(i \in A | P%B) F%R) : ring_scope.
Notation "\prod_ ( i \in A ) F" :=
  (\big[*%R/1%R]_(i \in A) F%R) : ring_scope.

Notation "\prod_ ( <- r | P ) F" :=
  (\big[*%N/1%N]_(<- r | P%B) F%N) : nat_scope.
Notation "\prod_ ( i <- r | P ) F" :=
  (\big[*%N/1%N]_(i <- r | P%B) F%N) : nat_scope.
Notation "\prod_ ( i <- r ) F" :=
  (\big[*%N/1%N]_(i <- r) F%N) : nat_scope.
Notation "\prod_ ( m <= i < n | P ) F" :=
  (\big[*%N/1%N]_(m <= i < n | P%B) F%N) : nat_scope.
Notation "\prod_ ( m <= i < n ) F" :=
  (\big[*%N/1%N]_(m <= i < n) F%N) : nat_scope.
Notation "\prod_ ( i | P ) F" :=
  (\big[*%N/1%N]_(i | P%B) F%N) : nat_scope.
Notation "\prod_ i F" :=
  (\big[*%N/1%N]_i F%N) : nat_scope.
Notation "\prod_ ( i : t | P ) F" :=
  (\big[*%N/1%N]_(i : t | P%B) F%N) (only parsing) : nat_scope.
Notation "\prod_ ( i : t ) F" :=
  (\big[*%N/1%N]_(i : t) F%N) (only parsing) : nat_scope.
Notation "\prod_ ( i < n | P ) F" :=
  (\big[*%N/1%N]_(i < n | P%B) F%N) : nat_scope.
Notation "\prod_ ( i < n ) F" :=
  (\big[*%N/1%N]_(i < n) F%N) : nat_scope.
Notation "\prod_ ( i \in A | P ) F" :=
  (\big[*%N/1%N]_(i \in A | P%B) F%N) : nat_scope.
Notation "\prod_ ( i \in A ) F" :=
  (\big[*%N/1%N]_(i \in A) F%N) : nat_scope.

Section Extensionality.

Variables (R : Type)  (nil : R) (op : R -> R -> R).

Section SeqExtension.

Variable I : Type.

Lemma big_filter : forall r (P : pred I) F,
  \big[op/nil]_(i <- filter P r) F i = \big[op/nil]_(i <- r | P i) F i.
Proof. by rewrite unlock => r P F; elim: r => //= i r <-; case (P i). Qed.

Lemma big_filter_cond : forall r (P1 P2 : pred I) F,
  \big[op/nil]_(i <- filter P1 r | P2 i) F i
     = \big[op/nil]_(i <- r | P1 i && P2 i) F i.
Proof.
move=> r P1 P2 F; rewrite -big_filter -(big_filter r); congr bigop.
rewrite -filter_predI; apply: eq_filter => i; exact: andbC.
Qed.

Lemma eq_bigl : forall r (P1 P2 : pred I) F, P1 =1 P2 ->
  \big[op/nil]_(i <- r | P1 i) F i = \big[op/nil]_(i <- r | P2 i) F i.
Proof.
by move=> r P1 P2 F eqP12; rewrite -big_filter (eq_filter eqP12) big_filter.
Qed.

Lemma eq_bigr : forall r (P : pred I) F1 F2, (forall i, P i -> F1 i = F2 i) ->
  \big[op/nil]_(i <- r | P i) F1 i = \big[op/nil]_(i <- r | P i) F2 i.
Proof.
move=> r P F1 F2 eqF12; rewrite unlock.
by elim: r => //= x r ->; case Px: (P x); rewrite // eqF12.
Qed.

Lemma eq_big : forall r (P1 P2 : pred I) F1 F2,
  P1 =1 P2 -> (forall i, P1 i -> F1 i = F2 i) ->
  \big[op/nil]_(i <- r | P1 i) F1 i = \big[op/nil]_(i <- r | P2 i) F2 i.
Proof. by move=> r P1 P2 F1 F2; move/eq_bigl <-; move/eq_bigr->. Qed.

Lemma congr_big : forall r1 r2 (P1 P2 : pred I) F1 F2,
  r1 = r2 -> P1 =1 P2 -> (forall i, P1 i -> F1 i = F2 i) ->
    \big[op/nil]_(i <- r1 | P1 i) F1 i = \big[op/nil]_(i <- r2 | P2 i) F2 i.
Proof. move=> r1 r2 P1 P2 F1 F2 <-{r2}; exact: eq_big. Qed.

Lemma big_seq0 : forall (P : pred I) F,
  \big[op/nil]_(i <- [::] | P i) F i = nil.
Proof. by rewrite unlock. Qed.

Lemma big_adds : forall i r (P : pred I) F,
  let x := \big[op/nil]_(j <- r | P j) F j in
  \big[op/nil]_(j <- i :: r | P j) F j = if P i then op (F i) x else x.
Proof. by rewrite unlock. Qed.

Lemma big_maps : forall (J : eqType) (h : J -> I) r F (P : pred I),
  \big[op/nil]_(i <- maps h r | P i) F i
     = \big[op/nil]_(j <- r | P (h j)) F (h j).
Proof. by rewrite unlock => J h r P F; elim: r => //= j r ->. Qed.

Lemma big_sub : forall x0 r (P : pred I) F,
  \big[op/nil]_(i <- r | P i) F i
     = \big[op/nil]_(0 <= i < size r | P (sub x0 r i)) (F (sub x0 r i)).
Proof.
by move=> x0 r P F; rewrite -{1}(mkseq_sub x0 r) big_maps /index_iota subn0.
Qed.

Lemma big_hasC : forall r (P : pred I) F,
  ~~ has P r -> \big[op/nil]_(i <- r | P i) F i = nil.
Proof.
move=> r P F; rewrite -big_filter has_count count_filter.
case: filter => // _; exact: big_seq0.
Qed.

Lemma big_pred0_eq : forall (r : seq I) F,
  \big[op/nil]_(i <- r | false) F i = nil.
Proof. by move=> r F; rewrite big_hasC // has_pred0. Qed.

Lemma big_pred0 : forall r (P : pred I) F, P =1 xpred0 ->
  \big[op/nil]_(i <- r | P i) F i = nil.
Proof. move=> r P F; move/eq_bigl->; exact: big_pred0_eq. Qed.

Lemma big_cat_nested : forall r1 r2 (P : pred I) F,
  let x := \big[op/nil]_(i <- r2 | P i) F i in
  \big[op/nil]_(i <- r1 ++ r2 | P i) F i = \big[op/x]_(i <- r1 | P i) F i.
Proof. by move=> r1 r2 P F; rewrite unlock /reducebig foldr_cat. Qed.

Lemma big_catl : forall r1 r2 (P : pred I) F, ~~ has P r2 ->
  \big[op/nil]_(i <- r1 ++ r2 | P i) F i = \big[op/nil]_(i <- r1 | P i) F i.
Proof. by move=> r1 r2 P F; rewrite big_cat_nested; move/big_hasC->. Qed.

Lemma big_catr : forall r1 r2 (P : pred I) F, ~~ has P r1 ->
  \big[op/nil]_(i <- r1 ++ r2 | P i) F i = \big[op/nil]_(i <- r2 | P i) F i.
Proof.
move=> r1 r2 P F; rewrite -big_filter -(big_filter r2) filter_cat.
by rewrite has_count count_filter; case: filter.
Qed.

Lemma big_const_seq : forall r (P : pred I) x,
  \big[op/nil]_(i <- r | P i) x = iter (count P r) (op x) nil.
Proof. by rewrite unlock => r P x; elim: r => //= i r ->; case: (P i). Qed.

End SeqExtension.

(* The following lemma can be used to localise extensionality to     *)
(* the specific index sequence. This is done by ssreflect rewriting, *)
(* before applying congruence or induction lemmas. This is important *)
(* for the latter, because ssreflect 1.1 still relies on primitive   *)
(* Coq matching unification for second-order application (e.g., for  *)
(* elim), and the latter can't handle the eqType constraint on I, as *)
(* it doesn't recognize canonical projections.                       *)
Lemma big_cond_seq : forall (I : eqType) r (P : pred I) F,
  \big[op/nil]_(i <- r | P i) F i
    = \big[op/nil]_(i <- r | P i && (i \in r)) F i.
Proof.
move=> I r P F; rewrite -!(big_filter r); congr bigop.
by apply: eq_in_filter => i ->; rewrite andbT.
Qed.

Lemma congr_big_nat : forall m1 n1 m2 n2 P1 P2 F1 F2,
    m1 = m2 -> n1 = n2 ->
    (forall i, m1 <= i < n2 -> P1 i = P2 i) ->
    (forall i, P1 i && (m1 <= i < n2) -> F1 i = F2 i) ->
  \big[op/nil]_(m1 <= i < n1 | P1 i) F1 i
    = \big[op/nil]_(m2 <= i < n2 | P2 i) F2 i.
Proof.
move=> m n _ _ P1 P2 F1 F2 <- <- eqP12 eqF12.
rewrite big_cond_seq (big_cond_seq _ P2).
apply: eq_big => i; rewrite ?inE /= !mem_index_iota; last exact: eqF12.
case inmn_i: (m <= i < n); rewrite ?(andbT, andbF) //; exact: eqP12.
Qed.

Lemma big_geq : forall m n (P : pred nat) F, m >= n ->
  \big[op/nil]_(m <= i < n | P i) F i = nil.
Proof.
by move=> m n P F ge_m_n; rewrite /index_iota (eqnP ge_m_n) big_seq0.
Qed.

Lemma big_ltn_cond : forall m n (P : pred nat) F, m < n ->
  let x := \big[op/nil]_(m.+1 <= i < n | P i) F i in
  \big[op/nil]_(m <= i < n | P i) F i = if P m then op (F m) x else x.
Proof.
by move=> m [//|n] P F le_m_n; rewrite /index_iota leq_subS // big_adds.
Qed.

Lemma big_ltn : forall m n F, m < n ->
  \big[op/nil]_(m <= i < n) F i = op (F m) (\big[op/nil]_(m.+1 <= i < n) F i).
Proof. move=> *; exact: big_ltn_cond. Qed.

Lemma big_addn : forall m n a (P : pred nat) F,
  \big[op/nil]_(m + a <= i < n | P i) F i =
     \big[op/nil]_(m <= i < n - a | P (i + a)) F (i + a).
Proof.
move=> m n a P F; rewrite /index_iota subn_sub addnC iota_addl big_maps.
by apply: eq_big => ? *; rewrite addnC.
Qed.

Lemma big_add1 : forall m n (P : pred nat) F,
  \big[op/nil]_(m.+1 <= i < n | P i) F i =
     \big[op/nil]_(m <= i < n.-1 | P (i.+1)) F (i.+1).
Proof.
move=> m n P F; rewrite -addn1 big_addn subn1.
by apply: eq_big => ? *; rewrite addn1.
Qed.

Lemma big_nat_recl : forall n F,
  \big[op/nil]_(0 <= i < n.+1) F i =
     op (F 0) (\big[op/nil]_(0 <= i < n) F i.+1).
Proof. by move=> n F; rewrite big_ltn // big_add1. Qed.

Lemma big_mkord : forall n (P : pred nat) F,
  \big[op/nil]_(0 <= i < n | P i) F i = \big[op/nil]_(i < n | P i) F i.
Proof.
move=> n P F; rewrite /index_iota subn0 -(big_maps (@nat_of_ord n)).
by congr bigop; rewrite val_enum_ord.
Qed.

Lemma big_nat_widen : forall m n1 n2 (P : pred nat) F, n1 <= n2 ->
  \big[op/nil]_(m <= i < n1 | P i) F i
      = \big[op/nil]_(m <= i < n2 | P i && (i < n1)) F i.
Proof.
move=> m n1 n2 P F len12; symmetry.
rewrite -big_filter filter_predI big_filter.
congr bigop; rewrite /index_iota; set d1 := n1 - m; set d2 := n2 - m.
rewrite -(@subnK d1 d2) /=; last by rewrite leq_sub2r ?leq_addr.
have: ~~ has (fun i => i < n1) (iota (m + d1) (d2 - d1)).
  apply/hasPn=> i; rewrite mem_iota -leqNgt; case/andP=> le_mn1_i _.
  by apply: leq_trans le_mn1_i; rewrite -leq_sub_add.
rewrite iota_add filter_cat has_filter /=; case: filter => // _.
rewrite cats0; apply/all_filterP; apply/allP=> i.
rewrite mem_iota; case/andP=> le_m_i lt_i_md1.
apply: (leq_trans lt_i_md1); rewrite subnK // ltnW //.
rewrite -ltn_0sub -(ltn_add2l m) addn0; exact: leq_trans lt_i_md1.
Qed.

Lemma big_ord_widen_cond : forall n1 n2 (P : pred nat) (F : nat -> R),
     n1 <= n2 ->
  \big[op/nil]_(i < n1 | P i) F i
      = \big[op/nil]_(i < n2 | P i && (i < n1)) F i.
Proof.
move=> n1 n2 P F len12.
by rewrite -big_mkord (big_nat_widen _ _ _ len12) big_mkord.
Qed.

Lemma big_ord_widen : forall n1 n2 (F : nat -> R),
 n1 <= n2 ->
  \big[op/nil]_(i < n1) F i = \big[op/nil]_(i < n2 | i < n1) F i.
Proof. move=> *; exact: (big_ord_widen_cond (predT)). Qed.

Lemma big_ord_widen_leq : forall n1 n2 (P : pred 'I_(n1.+1)) F,
 n1 < n2 ->
  \big[op/nil]_(i < n1.+1 | P i) F i
      = \big[op/nil]_(i < n2 | P (inord i) && (i <= n1)) F (inord i).
Proof.
move=> n1 n2 P F len12; pose g G i := G (inord i : 'I_(n1.+1)).
rewrite -(big_ord_widen_cond (g _ P) (g _ F) len12) {}/g.
by apply: eq_big => i *; rewrite inord_val.
Qed.

Lemma big_ord_narrow_cond : forall n1 n2 (P : pred 'I_n2) F,
  forall le_n1_n2 : n1 <= n2,
  let w := widen_ord le_n1_n2 in
  \big[op/nil]_(i < n2 | P i && (i < n1)) F i
    = \big[op/nil]_(i < n1 | P (w i)) F (w i).
Proof.
move=> [|n1] n2 P F ltn12 /=.
  by rewrite !big_pred0 // => [[//] | i]; rewrite andbF.
rewrite (big_ord_widen_leq _ _ ltn12); apply: eq_big => i.
  rewrite ltnS; case: leqP => [le_i_n1|_]; last by rewrite !andbF.
  by congr (P _ && _); apply: val_inj; rewrite /= inordK.
by case/andP=> _ le_i_n1; congr F; apply: val_inj; rewrite /= inordK.
Qed.

Lemma big_ord_narrow_cond_leq : forall n1 n2 (P : pred 'I_(n2.+1)) F,
  forall le_n1_n2 : n1 <= n2,
  let w := @widen_ord n1.+1 n2.+1 le_n1_n2 in
  \big[op/nil]_(i < n2.+1 | P i && (i <= n1)) F i
  = \big[op/nil]_(i < n1.+1 | P (w i)) F (w i).
Proof. move=> n1 n2; exact: big_ord_narrow_cond n1.+1 n2.+1. Qed.

Lemma big_ord_narrow : forall n1 n2 F,
  forall le_n1_n2 : n1 <= n2,
  let w := widen_ord le_n1_n2 in
  \big[op/nil]_(i < n2 | i < n1) F i = \big[op/nil]_(i < n1) F (w i).
Proof. move=> *; exact: (big_ord_narrow_cond (predT)). Qed.

Lemma big_ord_narrow_leq : forall n1 n2 F,
  forall le_n1_n2 : n1 <= n2,
  let w := @widen_ord n1.+1 n2.+1 le_n1_n2 in
  \big[op/nil]_(i < n2.+1 | i <= n1) F i = \big[op/nil]_(i < n1.+1) F (w i).
Proof. move=> *; exact: (big_ord_narrow_cond_leq (predT)). Qed.

Lemma big_ord_recl : forall n F,
  \big[op/nil]_(i < n.+1) F i =
     op (F ord0) (\big[op/nil]_(i < n) F (@lift n.+1 ord0 i)).
Proof.
move=> n F; pose G i := F (inord i).
have eqFG: forall i, F i = G i by move=> i; rewrite /G inord_val.
rewrite (eq_bigr _ (fun i _ => eqFG i)) -(big_mkord _ (fun _ => _) G) eqFG.
rewrite big_ltn // big_add1 /= big_mkord; congr op.
by apply: eq_bigr => i _; rewrite eqFG.
Qed.

Lemma big_const : forall (I : finType) (A : pred I) x,
  \big[op/nil]_(i \in A) x = iter #|A| (op x) nil.
Proof.
by move=> *; rewrite big_const_seq count_filter cardE [index_enum _]enumE.
Qed.

Lemma big_const_nat : forall m n x,
  \big[op/nil]_(m <= i < n) x = iter (n - m) (op x) nil.
Proof. by move=> *; rewrite big_const_seq count_predT size_iota. Qed.

Lemma big_const_ord : forall n x,
  \big[op/nil]_(i < n) x = iter n (op x) nil.
Proof. by move=> *; rewrite big_const card_ord. Qed.

End Extensionality.

Section MonoidProperties.

Import Monoid.

Variable R : Type.

Variable nil : R.
Notation Local "1" := nil.

Section Plain.

Variable op : Monoid.law 1.

Notation Local "'*%M'" := (operator op) (at level 0).
Notation Local "x * y" := ( *%M x y).

Lemma eq_big_nil_seq : forall nil' I r (P : pred I) F,
     right_unit nil' *%M -> has P r ->
   \big[*%M/nil']_(i <- r | P i) F i =\big[*%M/1]_(i <- r | P i) F i.
Proof.
move=> nil' I r P F op_nil'.
rewrite -!(big_filter _ _ r) has_count count_filter.
case/lastP: (filter P r) => {r p}// r i _.
by rewrite -cats1 !(big_cat_nested, big_adds, big_seq0) op_nil' mulm1.
Qed.

Lemma eq_big_nil  : forall nil' (I : finType) i0 (P : pred I) F,
     P i0 -> right_unit nil' *%M ->
  \big[*%M/nil']_(i | P i) F i =\big[*%M/1]_(i | P i) F i.
Proof.
move=> nil' I i0 P F op_nil' Pi0; apply: eq_big_nil_seq => //.
by apply/hasP; exists i0; first exact: mem_enum.
Qed.

Lemma big1_eq : forall I r (P : pred I), \big[*%M/1]_(i <- r | P i) 1 = 1.
Proof.
move=> *; rewrite big_const_seq; elim: (count _ _) => //= n ->; exact: mul1m.
Qed.

Lemma big1 : forall (I : finType) (P : pred I) F,
  (forall i, P i -> F i = 1) -> \big[*%M/1]_(i | P i) F i = 1.
Proof. by move=> I P F eq_F_1; rewrite (eq_bigr _ _ _ eq_F_1) big1_eq. Qed.

Lemma big1_seq : forall (I : eqType) r (P : pred I) F,
  (forall i, P i && (i \in r) -> F i = 1)
  -> \big[*%M/1]_(i <- r | P i) F i = 1.
Proof.
by move=> I r P F eqF1; rewrite big_cond_seq (eq_bigr _ _ _ eqF1) big1_eq.
Qed.

Lemma big_seq1 : forall I (i : I) F, \big[*%M/1]_(j <- [:: i]) F j = F i.
Proof. by rewrite unlock => /= *; rewrite mulm1. Qed.

Lemma big_mkcond : forall I r (P : pred I) F,
  \big[*%M/1]_(i <- r | P i) F i =
     \big[*%M/1]_(i <- r) (if P i then F i else 1).
Proof.
by rewrite unlock => I r P F; elim: r => //= i r ->; case P; rewrite ?mul1m.
Qed.

Lemma big_cat : forall I r1 r2 (P : pred I) F,
  \big[*%M/1]_(i <- r1 ++ r2 | P i) F i =
     \big[*%M/1]_(i <- r1 | P i) F i * \big[*%M/1]_(i <- r2 | P i) F i.
Proof.
move=> I r1 r2 P F; rewrite !(big_mkcond _ P).
elim: r1 => [|i r1 IHr1]; first by rewrite big_seq0 mul1m.
by rewrite /= !big_adds IHr1 mulmA.
Qed.

Lemma big_pred1_eq : forall (I : finType) (i : I) F,
  \big[*%M/1]_(j | j == i) F j = F i.
Proof.
by move=> I i F; rewrite -big_filter filter_index_enum enum1 big_seq1.
Qed.

Lemma big_pred1 : forall (I : finType) i (P : pred I) F,
  P =1 pred1 i -> \big[*%M/1]_(j | P j) F j = F i.
Proof. move=> I i P F; move/(eq_bigl _ _)->; exact: big_pred1_eq. Qed.

Lemma big_cat_nat : forall n m p (P : pred nat) F, m <= n -> n <= p ->
  \big[*%M/1]_(m <= i < p | P i) F i =
   (\big[*%M/1]_(m <= i < n | P i) F i) * (\big[*%M/1]_(n <= i < p | P i) F i).
Proof.
move=> n m p F P le_mn le_np; rewrite -big_cat.
by rewrite -{2}(subnK le_mn) -iota_add -subn_sub subnK // leq_sub2.
Qed.

Lemma big_nat1 : forall n F, \big[*%M/1]_(n <= i < n.+1) F i = F n.
Proof. by move=> n F; rewrite big_ltn // big_geq // mulm1. Qed.

Lemma big_nat_recr : forall n F,
  \big[*%M/1]_(0 <= i < n.+1) F i = (\big[*%M/1]_(0 <= i < n) F i) * F n.
Proof. by move=> n F; rewrite (@big_cat_nat n) ?leqnSn // big_nat1. Qed.

Lemma big_ord_recr : forall n F,
  \big[*%M/1]_(i < n.+1) F i =
     (\big[*%M/1]_(i < n) F (widen_ord (leqnSn n) i)) * F ord_max.
Proof.
move=> n F; transitivity (\big[*%M/1]_(0 <= i < n.+1) F (inord i)).
  by rewrite big_mkord; apply: eq_bigr=> i _; rewrite inord_val.
rewrite big_nat_recr big_mkord; congr (_ * F _); last first.
  by apply: val_inj; rewrite /= inordK.
by apply: eq_bigr => [] i _; congr F; apply: ord_inj; rewrite inordK //= leqW.
Qed.

End Plain.

Section Abelian.

Variable op : abelian_law 1.

Notation Local "'*%M'" := (operator (law_of_abelian op)) (at level 0).
Notation Local "x * y" := ( *%M x y).

Lemma eq_big_perm : forall (I : eqType) r1 r2 (P : pred I) F,
    perm_eq r1 r2 ->
  \big[*%M/1]_(i <- r1 | P i) F i = \big[*%M/1]_(i <- r2 | P i) F i.
Proof.
move=> I r1 r2 P F; move/perm_eqP; rewrite !(big_mkcond _ _ P).
elim: r1 r2 => [|i r1 IHr1] r2 eq_r12.
  by case: r2 eq_r12 => // i r2; move/(_ (pred1 i)); rewrite /= eqxx.
have r2i: i \in r2 by rewrite -has_pred1 has_count -eq_r12 /= eqxx.
case/splitPr: r2 / r2i => [r3 r4] in eq_r12 *; rewrite big_cat /= !big_adds.
rewrite mulmCA; congr (_ * _); rewrite -big_cat; apply: IHr1 => a.
move/(_ a): eq_r12; rewrite !count_cat /= addnCA; exact: addn_injl.
Qed.

Lemma big_uniq : forall (I : finType) (r : seq I) F,
  uniq r -> \big[*%M/1]_(i <- r) F i = \big[*%M/1]_(i | i \in r) F i.
Proof.
move=> I r F uniq_r; rewrite -(big_filter _ _ _ (mem r)); apply: eq_big_perm.
by rewrite filter_index_enum uniq_perm_eq ?uniq_enum // => i; rewrite mem_enum.
Qed.

Lemma big_split : forall I r (P : pred I) F1 F2,
  \big[*%M/1]_(i <- r | P i) (F1 i * F2 i) =
    \big[*%M/1]_(i <- r | P i) F1 i * \big[*%M/1]_(i <- r | P i) F2 i.
Proof.
rewrite unlock => I r P F1 F2.
elim: r => /= [|i r ->]; [by rewrite mulm1 | case: (P i) => //=].
rewrite !mulmA; congr (_ * _); exact: mulmAC.
Qed.

Lemma bigID : forall I r (a P : pred I) F,
  \big[*%M/1]_(i <- r | P i) F i
  = \big[*%M/1]_(i <- r | P i && a i) F i *
    \big[*%M/1]_(i <- r | P i && ~~ a i) F i.
Proof.
move=> I r a P F; rewrite !(big_mkcond _ _ _ F) -big_split; apply: eq_bigr => i.
by case: (a i); rewrite !simpm.
Qed.
Implicit Arguments bigID [I r].

Lemma bigD1 : forall (I : finType) j (P : pred I) F,
  P j -> \big[*%M/1]_(i | P i) F i
    = F j * \big[*%M/1]_(i | P i && (i != j)) F i.
Proof.
move=> I j P F Pj; rewrite (bigID (pred1 j)); congr (_ * _).
by apply: big_pred1 => i; rewrite /= andbC; case: eqP => // ->.
Qed.
Implicit Arguments bigD1 [I P F].

Lemma cardD1x : forall (I : finType) (A : pred I) j,
  A j -> #|SimplPred A| = 1 + #|[pred i | A i && (i != j)]|.
Proof.
move=> I A j Aj; rewrite (cardD1 j) [j \in A]Aj; congr (_ + _).
by apply: eq_card => i; rewrite inE /= andbC.
Qed.
Implicit Arguments cardD1x [I A].

Lemma partition_big : forall (I J : finType) (P : pred I) p (Q : pred J) F,
    (forall i, P i -> Q (p i)) ->
      \big[*%M/1]_(i | P i) F i =
         \big[*%M/1]_(j | Q j) \big[*%M/1]_(i | P i && (p i == j)) F i.
Proof.
move=> I J P p Q F Qp; transitivity (\big[*%M/1]_(i | P i && Q (p i)) F i).
  by apply: eq_bigl => i; case Pi: (P i); rewrite // Qp.
elim: {Q Qp}_.+1 {-2}Q (ltnSn #|Q|) => // n IHn Q.
case: (pickP Q) => [j Qj | Q0 _]; last first.
  by rewrite !big_pred0 // => i; rewrite Q0 andbF.
rewrite ltnS (cardD1x j Qj) (bigD1 j) //; move/IHn=> {n IHn} <-.
rewrite (bigID (fun i => p i == j)); congr (_ * _); apply: eq_bigl => i.
  by case: eqP => [-> | _]; rewrite !(Qj, simpm).
by rewrite andbA.
Qed.

Implicit Arguments partition_big [I J P F].

Lemma reindex_onto : forall (I J : finType) (h : J -> I) h' (P : pred I) F,
   (forall i, P i -> h (h' i) = i) ->
  \big[*%M/1]_(i | P i) F i =
    \big[*%M/1]_(j | P (h j) && (h' (h j) == j)) F (h j).
Proof.
move=> I J h h' P F h'K.
elim: {P}_.+1 {-3}P h'K (ltnSn #|P|) => //= n IHn P h'K.
case: (pickP P) => [i Pi | P0 _]; last first.
  by rewrite !big_pred0 // => j; rewrite P0.
rewrite ltnS (cardD1x i Pi); move/IHn {n IHn} => IH.
rewrite (bigD1 i Pi) (bigD1 (h' i)) h'K ?Pi ?eq_refl //=; congr (_ * _).
rewrite {}IH => [|j]; [apply: eq_bigl => j | by case/andP; auto].
rewrite andbC -andbA (andbCA (P _)); case: eqP => //= hK; congr (_ && ~~ _).
by apply/eqP/eqP=> [<-|->] //; rewrite h'K.
Qed.
Implicit Arguments reindex_onto [I J P F].

Lemma reindex : forall (I J : finType) (h : J -> I) (P : pred I) F,
  {on [pred i | P i], bijective h} ->
  \big[*%M/1]_(i | P i) F i = \big[*%M/1]_(j | P (h j)) F (h j).
Proof.
move=> I J h P F [h' hK h'K]; rewrite (reindex_onto h h' h'K).
by apply: eq_bigl => j; rewrite !inE; case Pi: (P _); rewrite //= hK ?eqxx.
Qed.
Implicit Arguments reindex [I J P F].

Lemma pair_big_dep : forall (I J : finType) (P : pred I) (Q : I -> pred J) F,
  \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q i j) F i j =
    \big[*%M/1]_(p | P p.1 && Q p.1 p.2) F p.1 p.2.
Proof.
move=> I J P Q F.
rewrite (partition_big (fun p => p.1) P) => [|j]; last by case/andP.
apply: eq_bigr => i /= Pi; rewrite (reindex_onto (pair i) (fun p => p.2)).
   by apply: eq_bigl => j; rewrite !eqxx [P i]Pi !andbT.
by case=> i' j /=; case/andP=> _ /=; move/eqP->.
Qed.

Lemma pair_big : forall (I J : finType) (P : pred I) (Q : pred J) F,
  \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q j) F i j =
    \big[*%M/1]_(p | P p.1 && Q p.2) F p.1 p.2.
Proof. move=> *; exact: pair_big_dep. Qed.

Lemma pair_bigA_ : forall (I J : finType) (F : I -> J -> R),
  \big[*%M/1]_i \big[*%M/1]_j F i j = \big[*%M/1]_p F p.1 p.2.
Proof. move=> *; exact: pair_big_dep. Qed.

Lemma exchange_big_dep :
    forall (I J : finType) (P : pred I) (Q : I -> pred J) (xQ : pred J) F,
    (forall i j, P i -> Q i j -> xQ j) ->
  \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q i j) F i j =
    \big[*%M/1]_(j | xQ j) \big[*%M/1]_(i | P i && Q i j) F i j.
Proof.
move=> I J P Q xQ F PQxQ; pose p u := (u.2, u.1).
rewrite !pair_big_dep (reindex_onto (p J I) (p I J)) => [|[//]].
apply: eq_big => [] [j i] //=; symmetry; rewrite eq_refl andbC.
case: (@andP (P i)) => //= [[]]; exact: PQxQ.
Qed.
Implicit Arguments exchange_big_dep [I J P Q F].

Lemma exchange_big :  forall (I J : finType) (P : pred I) (Q : pred J) F,
  \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q j) F i j =
    \big[*%M/1]_(j | Q j) \big[*%M/1]_(i | P i) F i j.
Proof.
move=> I J P Q F; rewrite (exchange_big_dep Q) //; apply: eq_bigr => i /= Qi.
by apply: eq_bigl => j; rewrite [Q i]Qi andbT.
Qed.

Lemma exchange_big_dep_nat :
  forall m1 n1 m2 n2 (P : pred nat) (Q : rel nat) (xQ : pred nat) F,
    (forall i j, m1 <= i < n1 -> m2 <= j < n2 -> P i -> Q i j -> xQ j) ->
  \big[*%M/1]_(m1 <= i < n1 | P i) \big[*%M/1]_(m2 <= j < n2 | Q i j) F i j =
    \big[*%M/1]_(m2 <= j < n2 | xQ j)
       \big[*%M/1]_(m1 <= i < n1 | P i && Q i j) F i j.
Proof.
move=> m1 n1 m2 n2 P Q xQ F PQxQ.
transitivity
  (\big[*%M/1]_(i < n1 - m1| P (i + m1))
    \big[*%M/1]_(j < n2 - m2 | Q (i + m1) (j + m2)) F (i + m1) (j + m2)).
- rewrite -{1}[m1]add0n big_addn big_mkord; apply: eq_bigr => i _.
  by rewrite -{1}[m2]add0n big_addn big_mkord.
rewrite (exchange_big_dep (fun j: 'I__ => xQ (j + m2))) => [|i j]; last first.
  by apply: PQxQ; rewrite leq_addl addnC -ltn_0sub -subn_sub ltn_0sub ltn_ord.
symmetry; rewrite -{1}[m2]add0n big_addn big_mkord; apply: eq_bigr => j _.
by rewrite -{1}[m1]add0n big_addn big_mkord.
Qed.
Implicit Arguments exchange_big_dep_nat [m1 n1 m2 n2 P Q F].

Lemma exchange_big_nat : forall m1 n1 m2 n2 (P Q : pred nat) F,
  \big[*%M/1]_(m1 <= i < n1 | P i) \big[*%M/1]_(m2 <= j < n2 | Q j) F i j =
    \big[*%M/1]_(m2 <= j < n2 | Q j) \big[*%M/1]_(m1 <= i < n1 | P i) F i j.
Proof.
move=> m1 n1 m2 n2 P Q F; rewrite (exchange_big_dep_nat Q) //.
by apply: eq_bigr => i /= Qi; apply: eq_bigl => j; rewrite [Q i]Qi andbT.
Qed.

End Abelian.

End MonoidProperties.

Implicit Arguments big_filter [R op nil I].
Implicit Arguments big_filter_cond [R op nil I].
Implicit Arguments congr_big [R op nil I r1 P1 F1].
Implicit Arguments eq_big [R op nil I r P1  F1].
Implicit Arguments eq_bigl [R op nil  I r P1].
Implicit Arguments eq_bigr [R op nil I r  P F1].
Implicit Arguments eq_big_nil [R op nil nil' I P F].
Implicit Arguments big_cond_seq [R op nil I r].
Implicit Arguments congr_big_nat [R op nil m1 n1 P1 F1].
Implicit Arguments big_maps [R op nil I J r].
Implicit Arguments big_sub [R op nil I r].
Implicit Arguments big_catl [R op nil I r1 r2 P F].
Implicit Arguments big_catr [R op nil I r1 r2  P F].
Implicit Arguments big_geq [R op nil m n P F].
Implicit Arguments big_ltn_cond [R op nil m n P F].
Implicit Arguments big_ltn [R op nil m n F].
Implicit Arguments big_addn [R op nil]. (* m n a *)
Implicit Arguments big_mkord [R op nil n].
Implicit Arguments big_nat_widen [R op nil] (* m n a *).
Implicit Arguments big_ord_widen_cond [R op nil n1].
Implicit Arguments big_ord_widen [R op nil n1].
Implicit Arguments big_ord_widen_leq [R op nil n1].
Implicit Arguments big_ord_narrow_cond [R op nil n1 n2 P F].
Implicit Arguments big_ord_narrow_cond_leq [R op nil n1 n2 P F].
Implicit Arguments big_ord_narrow [R op nil n1 n2 F].
Implicit Arguments big_ord_narrow_leq [R op nil n1 n2 F].
Implicit Arguments big_mkcond [R op nil I r].
Implicit Arguments big1_eq [R op nil I].
Implicit Arguments big1_seq [R op nil I].
Implicit Arguments big1 [R op nil I].
Implicit Arguments big_pred1 [R op nil I P F].
Implicit Arguments eq_big_perm [R op nil I r1 P F].
Implicit Arguments big_uniq [R op nil I F].
Implicit Arguments bigID [R op nil I r].
Implicit Arguments bigD1 [R op nil I P F].
Implicit Arguments partition_big [R op nil I J P F].
Implicit Arguments reindex_onto [R op nil I J P F].
Implicit Arguments reindex [R op nil I J P F].
Implicit Arguments pair_big_dep [R op nil I J].
Implicit Arguments pair_big [R op nil I J].
Implicit Arguments exchange_big_dep [R op nil I J P Q F].
Implicit Arguments exchange_big_dep_nat [R op nil m1 n1 m2 n2 P Q F].
Implicit Arguments big_ord_recl [R op nil].
Implicit Arguments big_ord_recr [R op nil].
Implicit Arguments big_nat_recl [R op nil].
Implicit Arguments big_nat_recr [R op nil].

Section BigProp.

Variables (R : Type) (Pb : R -> Type).
Variables (nil : R) (op1 op2 : R -> R -> R).
Hypothesis (Pb_nil : Pb nil)
           (Pb_op1 : forall x y, Pb x -> Pb y -> Pb (op1 x y))
           (Pb_eq_op : forall x y, Pb x -> Pb y -> op1 x y = op2 x y).

Lemma big_prop : forall I r (P : pred I) F,
  (forall i, P i -> Pb (F i)) -> Pb (\big[op1/nil]_(i <- r | P i) F i).
Proof.
by rewrite unlock => I r P F PbF; elim: r => //= i *; case Pi: (P i); auto.
Qed.

(* Pb must be given explicitly for the lemma below, because Coq second-order *)
(* unification will not handle the eqType constraint on I.                   *)
Lemma big_prop_seq : forall (I : eqType) (r : seq I) (P : pred I) F,
  (forall i, P i && (i \in r) -> Pb (F i)) ->
   Pb (\big[op1/nil]_(i <- r | P i) F i).
Proof. move=> I r P F; rewrite big_cond_seq; exact: big_prop. Qed.

(* Change operation *)
Lemma eq_big_op :  forall I r (P : pred I) F,
   (forall i, P i -> Pb (F i)) ->
  \big[op1/nil]_(i <- r | P i) F i = \big[op2/nil]_(i <- r | P i) F i.
Proof.
have:= big_prop; rewrite unlock => Pb_big I r P F Pb_F.
by elim: r => //= i r <-; case Pi: (P i); auto.
Qed.

(* See big_prop_seq above *)
Lemma eq_big_op_seq :  forall (I : eqType) r (P : pred I) F,
    (forall i, P i && (i \in r) -> Pb (F i)) ->
  \big[op1/nil]_(i <- r | P i) F i = \big[op2/nil]_(i <- r | P i) F i.
Proof. move=> I r P F Pb_F; rewrite !(big_cond_seq P); exact: eq_big_op. Qed.

End BigProp.

(* The implicit arguments expect an explicit Pb *)
Implicit Arguments eq_big_op_seq [R nil op1 I r P F].
Implicit Arguments eq_big_op [R nil op1 I P F].

Section BigRel.

Variables (R1 R2 : Type) (Pr : R1 -> R2 -> Type).
Variables (nil1 : R1) (op1 : R1 -> R1 -> R1).
Variables (nil2 : R2) (op2 : R2 -> R2 -> R2).
Hypothesis Pr_nil : Pr nil1 nil2.
Hypothesis Pr_rel : forall x1 x2 y1 y2,
  Pr x1 x2 -> Pr y1 y2 -> Pr (op1 x1 y1) (op2 x2 y2).

(* Pr must be given explicitly *)
Lemma big_rel : forall I r (P : pred I) F1 F2,
  (forall i, (P i) -> Pr (F1 i) (F2 i)) ->
  Pr (\big[op1/nil1]_(i <- r | P i) F1 i) (\big[op2/nil2]_(i <- r | P i) F2 i).
Proof.
rewrite !unlock => I r P F1 F2 PrF.
elim: r => //= i *; case Pi: (P i); auto.
Qed.

Lemma big_rel_seq : forall (I : eqType) (r : seq I) (P : pred I) F1 F2,
    (forall i, P i && (i \in r) -> Pr (F1 i) (F2 i)) ->
  Pr (\big[op1/nil1]_(i <- r | P i) F1 i) (\big[op2/nil2]_(i <- r | P i) F2 i).
Proof. move=> I r P *; rewrite !(big_cond_seq P); exact: big_rel. Qed.

End BigRel.

Implicit Arguments big_rel_seq [R1 R2 nil1 op1 nil2 op2 I r P F1 F2].
Implicit Arguments big_rel [R1 R2 nil1 op1 nil2 op2 I P F1 F2].

Section Morphism.

Variables R1 R2 : Type.
Variables (nil1 : R1) (nil2 : R2).
Variables (op1 : R1 -> R1 -> R1) (op2 : R2 -> R2 -> R2).
Variable phi : R1 -> R2.
Hypothesis phi_morphism : Monoid.morphism nil1 nil2 op1 op2 phi.

Lemma big_morph : forall I r (P : pred I) F,
  phi (\big[op1/nil1]_(i <- r | P i) F i) =
     \big[op2/nil2]_(i <- r | P i) phi (F i).
Proof.
case: phi_morphism => [phi1 phiM] I r P F.
by rewrite !unlock; elim: r => //= i r <-; case: (P i).
Qed.

End Morphism.

Implicit Arguments big_morph [R1 R2 nil1 nil2 op1 op2].

Section Distributivity.

Import Monoid.

Variable R : Type.
Variables zero one : R.
Notation Local "0" := zero.
Notation Local "1" := one.
Variable times : mul_law 0.
Notation Local "'*%M'" := (mul_operator times) (at level 0).
Notation Local "x * y" := ( *%M x y).
Variable plus : add_law times.
Notation Local "'+%M'" :=
  (operator (law_of_abelian (law_of_additive plus))) (at level 0).
Notation Local "x + y" := ( +%M x y).

Lemma big_distrl : forall I r alpha (P : pred I) F,
  \big[+%M/0]_(i <- r | P i) F i * alpha
    = \big[+%M/0]_(i <- r | P i) (F i * alpha).
Proof.
move=> *; apply: (big_morph ( *%M^~ _)).
by split=> [|? * /=]; rewrite (mul0m,  mulm_addl).
Qed.

Lemma big_distrr : forall I r alpha (P : pred I) F,
  alpha * \big[+%M/0]_(i <- r | P i) F i
    = \big[+%M/0]_(i <- r | P i) (alpha * F i).
Proof.
move=> *; apply: (big_morph ( *%M _)).
by split=> [|? * /=]; rewrite (mulm0,  mulm_addr).
Qed.

Lemma big_distr_big_dep :
  forall (I J : finType) j0 (P : pred I) (Q : I -> pred J) F,
  \big[*%M/1]_(i | P i) \big[+%M/0]_(j | Q i j) F i j =
     \big[+%M/0]_(f | pfamily j0 P Q f) \big[*%M/1]_(i | P i) F i (f i).
Proof.
move=> I J j0 P Q F; rewrite -big_filter filter_index_enum; set r := enum P.
pose fIJ := {ffun I -> J}; pose Pf := pfamily j0 _ Q; symmetry.
transitivity (\big[+%M/0]_(f | Pf (mem r) f) \big[*%M/1]_(i <- r) F i (f i)).
  apply: eq_big=> f; last by rewrite -big_filter filter_index_enum.
  by apply: eq_forallb => i; rewrite /= mem_enum.
have: uniq r by exact: uniq_enum.
elim: {P}r => /= [_|i r IHr].
  rewrite (big_pred1 [ffun => j0]) ?big_seq0 //= => f.
  apply/familyP/eqP=> /= [Df |->{f} i]; last by rewrite ffunE.
  apply/ffunP=> i; rewrite ffunE; exact/eqP.
case/andP=> nri; rewrite big_adds big_distrl; move/IHr {IHr} <-.
rewrite (partition_big (fun f : fIJ => f i) (Q i)); last first.
  by move=> f; move/familyP; move/(_ i); rewrite /= inE /= eqxx.
pose seti j (f : fIJ) := [ffun k => if k == i then j else f k].
apply: eq_bigr => j Qij; rewrite (reindex_onto (seti j) (seti j0)); last first.
  move=> f /=; case/andP; move/familyP=> eq_f; move/eqP=> fi.
  by apply/ffunP => k; rewrite !ffunE; case: eqP => // ->.
rewrite big_distrr; apply: eq_big => [f | f eq_f]; last first.
  rewrite big_adds ffunE eq_refl !(big_cond_seq predT) /=; congr (_ * _).
  by apply: eq_bigr => k; rewrite ffunE; case: eqP => // ->; case/idPn.
rewrite !ffunE !eq_refl andbT; apply/andP/familyP=> [[Pjf fij0] k | Pff].
  have:= familyP _ _ Pjf k; rewrite /= ffunE in_adds; case: eqP => // -> _.
  by rewrite (negbET nri) -(eqP fij0) !ffunE ?inE /= !eqxx.
split.
  apply/familyP=> k; move/(_ k): Pff; rewrite /= ffunE in_adds.
  by case: eqP => // ->.
apply/eqP; apply/ffunP=> k; have:= Pff k; rewrite !ffunE /=.
by case: eqP => // ->; rewrite (negbET nri) /=; move/eqP.
Qed.

Lemma big_distr_big :
  forall (I J : finType) j0 (P : pred I) (Q : pred J) F,
  \big[*%M/1]_(i | P i) \big[+%M/0]_(j | Q j) F i j =
     \big[+%M/0]_(f | pffun_on j0 P Q f) \big[*%M/1]_(i | P i) F i (f i).
Proof.
move=> I J j0 P Q F; rewrite (big_distr_big_dep j0); apply: eq_bigl => f.
by apply/familyP/familyP=> Pf i; move/(_ i): Pf; case: (P i).
Qed.

Lemma bigA_distr_big_dep :
  forall (I J : finType) (Q : I -> pred J) F,
  \big[*%M/1]_i \big[+%M/0]_(j | Q i j) F i j
    = \big[+%M/0]_(f | family Q f) \big[*%M/1]_i F i (f i).
Proof.
move=> I J Q F; case: (pickP J) => [j0 _ | J0].
   exact: (big_distr_big_dep j0).
rewrite /index_enum; case: (enum I) (mem_enum I) => [I0 | i r _].
  have f0: I -> J by move=> i; have:= I0 i.
  rewrite (big_pred1 (finfun f0)) ?big_seq0 // => g.
  by apply/familyP/eqP=> _; first apply/ffunP; move=> i; have:= I0 i.
have Q0: Q _ =1 pred0 by move=> ? j; have:= J0 j.
rewrite big_adds /= big_pred0 // mul0m big_pred0 // => f.
by apply/familyP; move/(_ i); rewrite Q0.
Qed.

Lemma bigA_distr_big :
  forall (I J : finType) (Q : pred J) (F : I -> J -> R),
  \big[*%M/1]_i \big[+%M/0]_(j | Q j) F i j
    = \big[+%M/0]_(f | ffun_on Q f) \big[*%M/1]_i F i (f i).
Proof. move=> *; exact: bigA_distr_big_dep. Qed.

Lemma bigA_distr_bigA :
  forall (I J : finType) F,
  \big[*%M/1]_(i : I) \big[+%M/0]_(j : J) F i j
    = \big[+%M/0]_(f : {ffun I -> J}) \big[*%M/1]_i F i (f i).
Proof.
move=> *; rewrite bigA_distr_big; apply: eq_bigl => ?; exact/familyP.
Qed.

End Distributivity.

Implicit Arguments big_distrl [R zero times plus I r].
Implicit Arguments big_distrr [R zero times plus I r].
Implicit Arguments big_distr_big_dep [R zero one times plus I J].
Implicit Arguments big_distr_big [R zero one times plus I J].
Implicit Arguments bigA_distr_big_dep [R zero one times plus I J].
Implicit Arguments bigA_distr_big [R zero one times plus I J].
Implicit Arguments bigA_distr_bigA [R zero one times plus I J].

Section Ring.

Import ssralg.Ring.

Section Opp.

Variable R : additive_group.

Lemma sum_opp : forall I r P (F : I -> R),
  \sum_(i <- r | P i) - F i = - (\sum_(i <- r | P i) F i).
Proof.
move=> *; symmetry; apply: big_morph.
by split=> [|x y]; rewrite (oppr0, oppr_add).
Qed.

Lemma sum_split_sub : forall I r (P : pred I) (F1 F2 : I -> R),
  \sum_(i <- r | P i) (F1 i - F2 i)
     = \sum_(i <- r | P i) F1 i - \sum_(i <- r | P i) F2 i.
Proof. by move=> *; rewrite -sum_opp -big_split /=. Qed.

Lemma sumr_const : forall (I : finType) (A : pred I) (x : R),
  \sum_(i \in A) x = x *+ #|A|.
Proof. exact: big_const. Qed.

End Opp.

Lemma prodr_const : forall (R : basic) (I : finType) (A : pred I) (x : R),
  \prod_(i \in A) x = x ^+ #|A|.
Proof. move=> *; exact: big_const. Qed.

End Ring.

(* Redundant, unparseable notation to print constant sums and products. *)
Notation "\su 'm_' ( i | P ) e" :=
  (\sum_(<- index_enum _ | (fun i => P)) (fun _ => e%N))
  (at level 41, e at level 41, format "\su 'm_' ( i  |  P )  e") : nat_scope.

Notation "\su 'm_' ( i \in A ) e" :=
  (\sum_(<- index_enum _ | (fun i => i \in A)) (fun _ => e%N))
  (at level 41, e at level 41, format "\su 'm_' ( i  \in  A )  e") : nat_scope.

Notation "\su 'm_' ( i \in A | P ) e" :=
  (\sum_(<- index_enum _ | (fun i => (i \in A) && P)) (fun _ => e%N))
  (at level 41, e at level 41, format "\su 'm_' ( i  \in  A  |  P )  e")
    : nat_scope.

Notation "\pro 'd_' ( i | P ) e" :=
  (\prod_(<- index_enum _ | (fun i => P)) (fun _ => e%N))
  (at level 36, e at level 36, format "\pro 'd_' ( i  |  P )  e") : nat_scope.

Lemma sum_nat_const : forall (I : finType) (A : pred I) (n : nat),
  \sum_(i \in A) n = #|A| * n.
Proof. by move=> I A n; rewrite big_const; elim: #|A| => //= i ->. Qed.

Lemma sum1_card : forall (I : finType) (A : pred I), \sum_(i \in A) 1 = #|A|.
Proof. by move=> I A; rewrite sum_nat_const muln1. Qed.

Lemma prod_nat_const : forall (I : finType) (A : pred I) (n : nat),
  \prod_(i \in A) n = n ^ #|A|.
Proof. by move=> I A n; rewrite big_const; elim: #|_| => //= ? ->. Qed.

Lemma sum_nat_const_nat : forall n1 n2 n : nat,
  \sum_(n1 <= i < n2) n = (n2 - n1) * n.
Proof. by move=> *; rewrite big_const_nat; elim: (_ - _) => //= ? ->. Qed.

Lemma prod_nat_const_nat : forall n1 n2 n : nat,
  \prod_(n1 <= i < n2) n = n ^ (n2 - n1).
Proof. by move=> *; rewrite big_const_nat; elim: (_ - _) => //= ? ->. Qed.

(* Beware: applying sum_predU to a [disjoint A & B] hypothesis will strip *)
(* the mem wrappers from A and B, possibly exposing internal coercions.   *)
Lemma sum_predU : forall (I : finType) (N : I -> nat) (a b : pred I),
  [disjoint a & b] ->
  \sum_(i | a i || b i) N i = (\sum_(i | a i) N i) + (\sum_(i | b i) N i).
Proof.
move => d N a b Hdisj; rewrite (bigID a) //=; congr addn; apply: eq_bigl => x0.
  by rewrite andb_orl andbb andbC [_ && _](pred0P Hdisj) orbF.
rewrite andbC; move/pred0P: Hdisj; move/(_ x0)=> /=.
by rewrite -topredE /=; case: a.
Qed.

Lemma ltn_0prodn_cond : forall I r (P : pred I) F,
  (forall i, P i -> 0 < F i) -> 0 < \prod_(i <- r | P i) F i.
Proof.
by move=> I r P F Fpos; apply big_prop => // n1 n2; rewrite ltn_0mul => ->.
Qed.

Lemma ltn_0prodn : forall I r (P : pred I) F,
  (forall i, 0 < F i) -> 0 < \prod_(i <- r | P i) F i.
Proof. move=> I r P F Fpos; exact: ltn_0prodn_cond. Qed.

Notation "\max_ ( <- r | P ) F" :=
  (\big[maxn/0%N]_(<- r | P%B) F%N) : nat_scope.
Notation "\max_ ( i <- r | P ) F" :=
  (\big[maxn/0%N]_(i <- r | P%B) F%N) : nat_scope.
Notation "\max_ ( i <- r ) F" :=
  (\big[maxn/0%N]_(i <- r) F%N) : nat_scope.
Notation "\max_ ( i | P ) F" :=
  (\big[maxn/0%N]_(i | P%B) F%N) : nat_scope.
Notation "\max_ i F" :=
  (\big[maxn/0%N]_i F%N) : nat_scope.
Notation "\max_ ( i : I | P ) F" :=
  (\big[maxn/0%N]_(i : I | P%B) F%N) (only parsing) : nat_scope.
Notation "\max_ ( i : I ) F" :=
  (\big[maxn/0%N]_(i : I) F%N) (only parsing) : nat_scope.
Notation "\max_ ( m <= i < n | P ) F" :=
 (\big[maxn/0%N]_(m <= i < n | P%B) F%N) : nat_scope.
Notation "\max_ ( m <= i < n ) F" :=
 (\big[maxn/0%N]_(m <= i < n) F%N) : nat_scope.
Notation "\max_ ( i < n | P ) F" :=
 (\big[maxn/0%N]_(i < n | P%B) F%N) : nat_scope.
Notation "\max_ ( i < n ) F" :=
 (\big[maxn/0%N]_(i < n) F%N) : nat_scope.
Notation "\max_ ( i \in A | P ) F" :=
 (\big[maxn/0%N]_(i \in A | P%B) F%N) : nat_scope.
Notation "\max_ ( i \in A ) F" :=
 (\big[maxn/0%N]_(i \in A) F%N) : nat_scope.

Lemma leq_bigmax_cond : forall (I : finType) (P : pred I) F i0,
  P i0 -> F i0 <= \max_(i | P i) F i.
Proof.
by move=> I P F i0 Pi0; rewrite -eqn_maxr (bigD1 i0) // maxnA /= maxnn eqxx.
Qed.

Lemma leq_bigmax : forall (I : finType) F (i0 : I), F i0 <= \max_i F i.
Proof. by move=> *; exact: leq_bigmax_cond. Qed.

Implicit Arguments leq_bigmax_cond [I P F].
Implicit Arguments leq_bigmax [I F].

Lemma eq_bigmax_cond : forall (I : finType) (P : pred I) F,
  ~~ pred0b P -> exists i0, P i0 && (F i0 == \max_(i | P i) F i).
Proof.
move=> I P F n0P; set m := \max_(i | P i) F i.
pose ub i := P i && (F i >= m); case: (pickP ub) => [i| ub0].
  by case/andP=> Pi ubi; exists i; rewrite Pi eqn_leq leq_bigmax_cond.
have ubm: forall i, P i -> F i < m.
  by move=> i Pi; case/nandP: (ub0 i); rewrite (Pi, ltnNge).
case/idP: (ltnn m); apply: (@big_prop _ (fun n => n < m)) => // [|n1 n2].
  by case/existsP: n0P => i; move/ubm; exact: leq_trans.
by rewrite !ltnNge leq_maxr negb_or => ->.
Qed.

Lemma eq_bigmax : forall (I : finType) F,
  (~~ pred0b I) -> exists i0 : I, (F i0 == \max_i F i).
Proof.
by move=> I F; move/(eq_bigmax_cond F)=> [] x; move/andP=> [] _; exists x.
Qed.

Implicit Arguments eq_bigmax_cond [I P F].
Implicit Arguments eq_bigmax [I F].

Unset Implicit Arguments.