From iris.heap_lang Require Export spawn.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".
Import uPred.

Definition parN : namespace := nroot .@ "par".

Definition par : val :=
  λ: "fs",
    let: "handle" := spawn (Fst "fs") in
    let: "v2" := Snd "fs" #() in
    let: "v1" := join "handle" in
    ("v1", "v2").
Notation "e1 ||| e2" := (par (Pair (λ: <>, e1) (λ: <>, e2)))%E : expr_scope.

Section proof.
Local Set Default Proof Using "Type*".
Context `{!heapG Σ, !spawnG Σ}.

(* Notice that this allows us to strip a later *after* the two Ψ have been
   brought together.  That is strictly stronger than first stripping a later
   and then merging them, as demonstrated by [tests/joining_existentials.v].
   This is why these are not Texan triples. *)
Lemma par_spec (Ψ1 Ψ2 : val → iProp Σ) e (f1 f2 : val) (Φ : val → iProp Σ) :
  IntoVal e (f1,f2) →
  WP f1 #() {{ Ψ1 }} -∗ WP f2 #() {{ Ψ2 }} -∗
  (▷ ∀ v1 v2, Ψ1 v1 ∗ Ψ2 v2 -∗ ▷ Φ (v1,v2)%V) -∗
  WP par e {{ Φ }}.
Proof.
  iIntros (<-) "Hf1 Hf2 HΦ".
  rewrite /par /=. wp_let. wp_proj.
  wp_apply (spawn_spec parN with "Hf1").
  iIntros (l) "Hl". wp_let. wp_proj. wp_bind (f2 _).
  iApply (wp_wand with "Hf2"); iIntros (v) "H2". wp_let.
  wp_apply (join_spec with "[$Hl]"). iIntros (w) "H1".
  iSpecialize ("HΦ" with "[-]"); first by iSplitL "H1". by wp_let.
Qed.

Lemma wp_par (Ψ1 Ψ2 : val → iProp Σ)
    (e1 e2 : expr) `{!Closed [] e1, Closed [] e2} (Φ : val → iProp Σ) :
  WP e1 {{ Ψ1 }} -∗ WP e2 {{ Ψ2 }} -∗
  (∀ v1 v2, Ψ1 v1 ∗ Ψ2 v2 -∗ ▷ Φ (v1,v2)%V) -∗
  WP e1 ||| e2 {{ Φ }}.
Proof.
  iIntros "H1 H2 H". iApply (par_spec Ψ1 Ψ2 with "[H1] [H2] [H]").
  by wp_let. by wp_let. auto.
Qed.
End proof.


From Coq Require Import Reals Bool Relations RelationClasses List ListSet Setoid Permutation EqdepFacts IndefiniteDescription Classical Sorting.
Import ListNotations.

From CasperCBC
Require Import Lib.Preamble Lib.ListExtras Lib.ListSetExtras Lib.SortedLists VLSM.Equivocation CBC.Protocol Lib.RealsExtras VLSM.Decisions Lib.Measurable.

(** * CBC General Definitions and Lemmas *)

Class InhabitedTwice V := { inhabited_twice : exists (v1 v2 : V), v1 <> v2 }.

Class DistinctChoice V `{HscV : StrictlyComparable V} `{Hit : InhabitedTwice V}.

Program Instance distinct_choice {V} `{HscV : StrictlyComparable V} `{Hit : InhabitedTwice V} : DistinctChoice V.

Lemma distinct_choice_total
  {V} `{Hdc : DistinctChoice V}
  : forall v1 : V, exists v2 : V, v1 <> v2.
Proof.
  intros.
  destruct inhabited_twice  as [v1' [v2' Hneq]].
  destruct (compare_eq_dec v1 v1') eqn:Heq.
  - subst. exists v2'. assumption.
  - exists v1'. assumption.
Qed.

Definition get_distinct_sender
  {V} `{Hdc : DistinctChoice V}
  (v : V)
  :=
  proj1_sig (constructive_indefinite_description (fun v' => v <> v') (distinct_choice_total v)).

Definition get_distinct_sender_correct
  {V} `{Hdc : DistinctChoice V}
  (v : V)
  :=
  proj2_sig (constructive_indefinite_description (fun v' => v <> v') (distinct_choice_total v)).

Lemma get_distinct_sender_correct'
  {V} `{Hdc : DistinctChoice V}
  : forall v, get_distinct_sender v <> v.
Proof.
  intros. unfold get_distinct_sender.
  assert (H_useful := get_distinct_sender_correct v).
  simpl in *.
  intro H_absurd.
  apply H_useful; symmetry; assumption.
Qed.

Lemma senders_fault_weight_eq
   `{EqDecision V} `{Hm : Measurable V}
  : forall lv1 lv2 : list V,
    NoDup lv1 ->
    NoDup lv2 ->
    set_eq lv1 lv2 ->
    sum_weights lv1 = sum_weights lv2.
Proof.
  induction lv1 as [|hd tl IHlv1]; intros lv2 H_lv1 H_lv2 H_eq.
  - destruct lv2.
    reflexivity.
    inversion H_eq.
    spec H0 v (in_eq v lv2).
    inversion H0.
  - simpl.
    (* hd must be in duplicate-free lv2 *)
    spec IHlv1 (set_remove decide_eq hd lv2).
    spec IHlv1.
    apply NoDup_cons_iff in H_lv1. tauto.
    spec IHlv1.
    now apply set_remove_nodup.
    spec IHlv1.
    replace tl with (set_remove decide_eq hd (hd :: tl)).
    apply set_eq_remove; try assumption.
    now rewrite set_remove_first.
    (* Now. *)
    rewrite IHlv1.
    symmetry.
    apply sum_weights_in. assumption.
    destruct H_eq as [H_eq _].
    spec H_eq hd (in_eq hd tl). assumption.
Qed.

Lemma pivotal_validator_extension
  `{EqDecision V} `{Hrt : ReachableThreshold V}
  : forall vsfix vss,
  NoDup vsfix ->
  (* and whose added weight does not pass the threshold *)
  (sum_weights vsfix <= proj1_sig threshold)%R ->
  NoDup (vss ++ vsfix) ->
  (sum_weights (vss ++ vsfix) > proj1_sig threshold)%R ->
  exists (vs : list V),
  NoDup vs /\
  incl vs vss /\
  (sum_weights (vs ++ vsfix) > proj1_sig threshold)%R /\
  exists v,
    In v vs /\
    (sum_weights ((set_remove decide_eq v vs) ++ vsfix) <= proj1_sig threshold)%R.
Proof.
  destruct threshold as [t about_t]; simpl in *.
  intro.  induction vss; intros.
  - simpl in H2. exfalso. apply (Rge_gt_trans t) in H2; try (apply Rle_ge; assumption).
    apply Rgt_not_eq in H2. apply H2. reflexivity.
  - simpl in H2. destruct (Rtotal_le_gt (sum_weights (vss ++ vsfix)) t).
    + exists (a :: vss). repeat split; try assumption.
      * apply append_nodup_left in H1. assumption.
      * apply incl_refl.
      * exists a. split; try (left; reflexivity).
        simpl. rewrite decide_True; try reflexivity. assumption.
    + simpl in H1. apply NoDup_cons_iff in H1. destruct H1 as [Hnin Hvss]. apply IHvss in H3; try assumption.
      destruct H3 as [vs [Hvs [Hincl Hex]]].
      exists vs. repeat (split;try assumption). apply incl_tl. assumption.
Qed.

(* From threshold.v *)
Lemma validators_pivotal_ind
  `{EqDecision V} `{Hrt : ReachableThreshold V}
  : forall vss,
  NoDup vss ->
  (sum_weights vss > proj1_sig threshold)%R ->
  exists (vs : list V),
  NoDup vs /\
  incl vs vss /\
  (sum_weights vs > proj1_sig threshold)%R /\
  exists v,
    In v vs /\
    (sum_weights (set_remove decide_eq v vs) <= proj1_sig threshold)%R.
Proof.
  intros.
  rewrite <- (app_nil_r vss) in H.   rewrite <- (app_nil_r vss) in H0.
  apply (pivotal_validator_extension [] vss) in H0; try assumption.
  - destruct H0 as [vs [NoDupvs [Inclvs [Gt [v [Inv Lt]]]]]].
    rewrite app_nil_r in Lt. rewrite app_nil_r in Gt.
    exists vs. repeat (split; try assumption).
    exists v. repeat (split; try assumption).
  - constructor.
  - destruct threshold as [t about_t]; simpl in *.
    apply Rge_le; assumption.
Qed.

Lemma sufficient_validators_pivotal
  `{EqDecision V} `{Hrt : ReachableThreshold V}
  : exists (vs : list V),
    NoDup vs /\
    (sum_weights vs > proj1_sig threshold)%R /\
    exists v,
      In v vs /\
      (sum_weights (set_remove decide_eq v vs) <= proj1_sig threshold)%R.
Proof.
  destruct reachable_threshold as [vs [Hvs Hweight]].
  apply (validators_pivotal_ind vs Hvs) in Hweight.
  destruct Hweight as [vs' [Hnd [Hincl H]]].
  destruct threshold as [t about_t]; simpl in *.
  exists vs'. repeat (split; try assumption).
Qed.

Definition potentially_pivotal
  `{Hrt : ReachableThreshold V}
  (v : V) : Prop
  :=
  exists (vs : list V),
      NoDup vs /\
      ~In v vs /\
      (sum_weights vs <= proj1_sig threshold)%R /\
      (sum_weights vs > proj1_sig threshold - (proj1_sig (weight v)))%R.

Lemma exists_pivotal_validator
  `{EqDecision V} `{Hrt : ReachableThreshold V}
  : exists v, potentially_pivotal v.
Proof.
  destruct sufficient_validators_pivotal as [vs [Hnodup [Hgt [v [Hin Hlte]]]]].
  exists v.
  subst. exists (set_remove decide_eq v vs). repeat split.
  - apply set_remove_nodup. assumption.
  - intro. apply set_remove_iff in H; try assumption. destruct H. apply H0. reflexivity.
  - assumption.
  - rewrite (sum_weights_in v) in Hgt; try assumption.
    rewrite Rplus_comm in Hgt.
    apply (Rplus_gt_compat_r (- (proj1_sig (weight v))%R)) in Hgt.
    rewrite Rplus_assoc in Hgt.
    rewrite Rplus_opp_r in Hgt.
    rewrite Rplus_0_r in Hgt.
    assumption.
Qed.

Definition get_estimate {state C} `{Estimator state C} (s : state) :=
  proj1_sig (constructive_indefinite_description (estimator s) (estimator_total s)).

Definition get_estimate_correct {state C} `{Estimator state C} (s : state) :=
  proj2_sig (constructive_indefinite_description (estimator s) (estimator_total s)).

Lemma get_estimate_consistent {state C} `{Estimator state C}
  (s : state)
  (c : C)
  (Heq : get_estimate s = c)
  : estimator s c.
Proof.
  unfold get_estimate in Heq.
  remember (constructive_indefinite_description (estimator s) (estimator_total s)) as Hchoice. destruct Hchoice as [c' Hc'].
  simpl in Heq. subst. assumption.
Qed.

(* Estimator approval condition *)
Definition valid_estimate
  {C state} `{Estimator state C}
  (c : C) (sigma : state) : Prop
  :=
    estimator sigma c.


From stdpp Require Export sets gmap mapset.
From iris.algebra Require Export cmra.
From iris.algebra Require Import updates local_updates.
From iris Require Import options.

(* The union CMRA *)
Section gset.
  Context `{Countable K}.
  Implicit Types X Y : gset K.

  Canonical Structure gsetO := discreteO (gset K).

  Instance gset_valid : Valid (gset K) := λ _, True.
  Instance gset_unit : Unit (gset K) := (∅ : gset K).
  Instance gset_op : Op (gset K) := union.
  Instance gset_pcore : PCore (gset K) := λ X, Some X.

  Lemma gset_op_union X Y : X ⋅ Y = X ∪ Y.
  Proof. done. Qed.
  Lemma gset_core_self X : core X = X.
  Proof. done. Qed.
  Lemma gset_included X Y : X ≼ Y ↔ X ⊆ Y.
  Proof.
    split.
    - intros [Z ->]. rewrite gset_op_union. set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L. by exists Z.
  Qed.

  Lemma gset_ra_mixin : RAMixin (gset K).
  Proof.
    apply ra_total_mixin; apply _ || eauto; [].
    intros X. by rewrite gset_core_self idemp_L.
  Qed.
  Canonical Structure gsetR := discreteR (gset K) gset_ra_mixin.

  Global Instance gset_cmra_discrete : CmraDiscrete gsetR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma gset_ucmra_mixin : UcmraMixin (gset K).
  Proof. split. done. intros X. by rewrite gset_op_union left_id_L. done. Qed.
  Canonical Structure gsetUR := UcmraT (gset K) gset_ucmra_mixin.

  Lemma gset_opM X mY : X ⋅? mY = X ∪ default ∅ mY.
  Proof. destruct mY; by rewrite /= ?right_id_L. Qed.

  Lemma gset_update X Y : X ~~> Y.
  Proof. done. Qed.

  Lemma gset_local_update X Y X' : X ⊆ X' → (X,Y) ~l~> (X',X').
  Proof.
    intros (Z&->&?)%subseteq_disjoint_union_L.
    rewrite local_update_unital_discrete=> Z' _ /leibniz_equiv_iff->.
    split. done. rewrite gset_op_union. set_solver.
  Qed.

  Global Instance gset_core_id X : CoreId X.
  Proof. by apply core_id_total; rewrite gset_core_self. Qed.
End gset.

Arguments gsetO _ {_ _}.
Arguments gsetR _ {_ _}.
Arguments gsetUR _ {_ _}.

(* The disjoint union CMRA *)
Inductive gset_disj K `{Countable K} :=
  | GSet : gset K → gset_disj K
  | GSetBot : gset_disj K.
Arguments GSet {_ _ _} _.
Arguments GSetBot {_ _ _}.

Section gset_disj.
  Context `{Countable K}.
  Arguments op _ _ !_ !_ /.
  Arguments cmra_op _ !_ !_ /.
  Arguments ucmra_op _ !_ !_ /.

  Canonical Structure gset_disjO := leibnizO (gset_disj K).

  Instance gset_disj_valid : Valid (gset_disj K) := λ X,
    match X with GSet _ => True | GSetBot => False end.
  Instance gset_disj_unit : Unit (gset_disj K) := GSet ∅.
  Instance gset_disj_op : Op (gset_disj K) := λ X Y,
    match X, Y with
    | GSet X, GSet Y => if decide (X ## Y) then GSet (X ∪ Y) else GSetBot
    | _, _ => GSetBot
    end.
  Instance gset_disj_pcore : PCore (gset_disj K) := λ _, Some ε.

  Ltac gset_disj_solve :=
    repeat (simpl || case_decide);
    first [apply (f_equal GSet)|done|exfalso]; set_solver by eauto.

  Lemma gset_disj_included X Y : GSet X ≼ GSet Y ↔ X ⊆ Y.
  Proof.
    split.
    - move=> [[Z|]]; simpl; try case_decide; set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L.
      exists (GSet Z). gset_disj_solve.
  Qed.
  Lemma gset_disj_valid_inv_l X Y : ✓ (GSet X ⋅ Y) → ∃ Y', Y = GSet Y' ∧ X ## Y'.
  Proof. destruct Y; repeat (simpl || case_decide); by eauto. Qed.
  Lemma gset_disj_union X Y : X ## Y → GSet X ⋅ GSet Y = GSet (X ∪ Y).
  Proof. intros. by rewrite /= decide_True. Qed.
  Lemma gset_disj_valid_op X Y : ✓ (GSet X ⋅ GSet Y) ↔ X ## Y.
  Proof. simpl. case_decide; by split. Qed.

  Lemma gset_disj_ra_mixin : RAMixin (gset_disj K).
  Proof.
    apply ra_total_mixin; eauto.
    - intros [?|]; destruct 1; gset_disj_solve.
    - by constructor.
    - by destruct 1.
    - intros [X1|] [X2|] [X3|]; gset_disj_solve.
    - intros [X1|] [X2|]; gset_disj_solve.
    - intros [X|]; gset_disj_solve.
    - exists (GSet ∅); gset_disj_solve.
    - intros [X1|] [X2|]; gset_disj_solve.
  Qed.
  Canonical Structure gset_disjR := discreteR (gset_disj K) gset_disj_ra_mixin.

  Global Instance gset_disj_cmra_discrete : CmraDiscrete gset_disjR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma gset_disj_ucmra_mixin : UcmraMixin (gset_disj K).
  Proof. split; try apply _ || done. intros [X|]; gset_disj_solve. Qed.
  Canonical Structure gset_disjUR := UcmraT (gset_disj K) gset_disj_ucmra_mixin.

  Arguments op _ _ _ _ : simpl never.

  Lemma gset_disj_alloc_updateP_strong P (Q : gset_disj K → Prop) X :
    (∀ Y, X ⊆ Y → ∃ j, j ∉ Y ∧ P j) →
    (∀ i, i ∉ X → P i → Q (GSet ({[i]} ∪ X))) →
    GSet X ~~>: Q.
  Proof.
    intros Hfresh HQ.
    apply cmra_discrete_updateP=> ? /gset_disj_valid_inv_l [Y [->?]].
    destruct (Hfresh (X ∪ Y)) as (i&?&?); first set_solver.
    exists (GSet ({[ i ]} ∪ X)); split.
    - apply HQ; set_solver by eauto.
    - apply gset_disj_valid_op. set_solver by eauto.
  Qed.
  Lemma gset_disj_alloc_updateP_strong' P X :
    (∀ Y, X ⊆ Y → ∃ j, j ∉ Y ∧ P j) →
    GSet X ~~>: λ Y, ∃ i, Y = GSet ({[ i ]} ∪ X) ∧ i ∉ X ∧ P i.
  Proof. eauto using gset_disj_alloc_updateP_strong. Qed.

  Lemma gset_disj_alloc_empty_updateP_strong P (Q : gset_disj K → Prop) :
    (∀ Y : gset K, ∃ j, j ∉ Y ∧ P j) →
    (∀ i, P i → Q (GSet {[i]})) → GSet ∅ ~~>: Q.
  Proof.
    intros. apply (gset_disj_alloc_updateP_strong P); eauto.
    intros i; rewrite right_id_L; auto.
  Qed.
  Lemma gset_disj_alloc_empty_updateP_strong' P :
    (∀ Y : gset K, ∃ j, j ∉ Y ∧ P j) →
    GSet ∅ ~~>: λ Y, ∃ i, Y = GSet {[ i ]} ∧ P i.
  Proof. eauto using gset_disj_alloc_empty_updateP_strong. Qed.

  Section fresh_updates.
    Local Set Default Proof Using "Type*".
    Context `{!Infinite K}.

    Lemma gset_disj_alloc_updateP (Q : gset_disj K → Prop) X :
      (∀ i, i ∉ X → Q (GSet ({[i]} ∪ X))) → GSet X ~~>: Q.
    Proof.
      intro; eapply gset_disj_alloc_updateP_strong with (λ _, True); eauto.
      intros Y ?; exists (fresh Y). split. apply is_fresh. done.
    Qed.
    Lemma gset_disj_alloc_updateP' X :
      GSet X ~~>: λ Y, ∃ i, Y = GSet ({[ i ]} ∪ X) ∧ i ∉ X.
    Proof. eauto using gset_disj_alloc_updateP. Qed.

    Lemma gset_disj_alloc_empty_updateP (Q : gset_disj K → Prop) :
      (∀ i, Q (GSet {[i]})) → GSet ∅ ~~>: Q.
    Proof.
      intro. apply gset_disj_alloc_updateP. intros i; rewrite right_id_L; auto.
    Qed.
    Lemma gset_disj_alloc_empty_updateP' : GSet ∅ ~~>: λ Y, ∃ i, Y = GSet {[ i ]}.
    Proof. eauto using gset_disj_alloc_empty_updateP. Qed.
  End fresh_updates.

  Lemma gset_disj_dealloc_local_update X Y :
    (GSet X, GSet Y) ~l~> (GSet (X ∖ Y), GSet ∅).
  Proof.
    apply local_update_total_valid=> _ _ /gset_disj_included HYX.
    rewrite local_update_unital_discrete=> -[Xf|] _ /leibniz_equiv_iff //=.
    rewrite {1}/op /=. destruct (decide _) as [HXf|]; [intros[= ->]|done].
    by rewrite difference_union_distr_l_L
      difference_diag_L !left_id_L difference_disjoint_L.
  Qed.
  Lemma gset_disj_dealloc_empty_local_update X Z :
    (GSet Z ⋅ GSet X, GSet Z) ~l~> (GSet X, GSet ∅).
  Proof.
    apply local_update_total_valid=> /gset_disj_valid_op HZX _ _.
    assert (X = (Z ∪ X) ∖ Z) as HX by set_solver.
    rewrite gset_disj_union // {2}HX. apply gset_disj_dealloc_local_update.
  Qed.
  Lemma gset_disj_dealloc_op_local_update X Y Z :
    (GSet Z ⋅ GSet X, GSet Z ⋅ GSet Y) ~l~> (GSet X,GSet Y).
  Proof.
    rewrite -{2}(left_id ε _ (GSet Y)).
    apply op_local_update_frame, gset_disj_dealloc_empty_local_update.
  Qed.

  Lemma gset_disj_alloc_op_local_update X Y Z :
    Z ## X → (GSet X,GSet Y) ~l~> (GSet Z ⋅ GSet X, GSet Z ⋅ GSet Y).
  Proof.
    intros. apply op_local_update_discrete. by rewrite gset_disj_valid_op.
  Qed.
  Lemma gset_disj_alloc_local_update X Y Z :
    Z ## X → (GSet X,GSet Y) ~l~> (GSet (Z ∪ X), GSet (Z ∪ Y)).
  Proof.
    intros. apply local_update_total_valid=> _ _ /gset_disj_included ?.
    rewrite -!gset_disj_union //; last set_solver.
    auto using gset_disj_alloc_op_local_update.
  Qed.
  Lemma gset_disj_alloc_empty_local_update X Z :
    Z ## X → (GSet X, GSet ∅) ~l~> (GSet (Z ∪ X), GSet Z).
  Proof.
    intros. rewrite -{2}(right_id_L _ union Z).
    apply gset_disj_alloc_local_update; set_solver.
  Qed.
End gset_disj.

Arguments gset_disjO _ {_ _}.
Arguments gset_disjR _ {_ _}.
Arguments gset_disjUR _ {_ _}.


Require Import Lang.Syntax.
Require Import Lang.Bindings.
Require Import Lang.BindingsFacts.
Set Implicit Arguments.

Implicit Types EP EV LV V L : Set.

Section section_sk_is_map.

Fixpoint sk_is_EP_map
EP EP' EV LV L (f : EP → EP')
(Σ : is EP EV LV L) :
sk_is Σ = sk_is (EP_map_is f Σ).
Proof.
destruct Σ ; simpl.
+ auto.
+ erewrite sk_is_EP_map ; reflexivity.
Qed.

Fixpoint sk_is_L_map
EP EV LV L L' (f : L → L')
(Σ : is EP EV LV L) :
sk_is Σ = sk_is (L_map_is f Σ).
Proof.
destruct Σ ; simpl.
+ auto.
+ erewrite sk_is_L_map ; reflexivity.
Qed.

Fixpoint sk_is_LV_map
EP EV LV LV' L (f : LV → LV')
(Σ : is EP EV LV L) :
sk_is Σ = sk_is (LV_map_is f Σ).
Proof.
destruct Σ ; simpl.
+ auto.
+ erewrite sk_is_LV_map ; reflexivity.
Qed.

Fixpoint sk_is_EV_map
EP EV EV' LV L (f : EV → EV')
(Σ : is EP EV LV L) :
sk_is Σ = sk_is (EV_map_is f Σ).
Proof.
destruct Σ ; simpl.
+ auto.
+ erewrite sk_is_EV_map ; reflexivity.
Qed.

End section_sk_is_map.

Fixpoint sk_is_EP_bind
EP EP' EV LV L (f : EP → eff EP' EV LV L)
(Σ : is EP EV LV L) :
sk_is Σ = sk_is (EP_bind_is f Σ).
Proof.
destruct Σ ; simpl.
+ auto.
+ erewrite sk_is_EP_bind ; reflexivity.
Qed.


Set Warnings "-notation-overridden".

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Embed.Theory.Btree.

Require Import Equations.Type.Logic.
Require Import Equations.Type.Classes.
Require Import Equations.Type.Loader.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Section BtreeEquationsClasses.

Import Sigma_Notations.
Import Id_Notations.
Local Open Scope equations_scope.

(* TODO: why is this not imported properly? *)
Derive NoConfusion for btree.

Equations distribute_id_bnil {A} {x y : A} (xs : bnil x = bnil y) : x = y :=
distribute_id_bnil id_refl := id_refl.

Equations distribute_id_bcons {A} {x y z w : @btree A} (xs : bcons x y = bcons z w) : Datatypes.prod (x = z) (y = w) :=
distribute_id_bcons id_refl := pair id_refl id_refl.

Equations lift_id_bnil {A} {x y : A} :
  (x = y) + (x <> y) ->
  (bnil x = bnil y) + (bnil x <> bnil y) :=
lift_id_bnil (Logic.inl id_refl) := Logic.inl id_refl;
lift_id_bnil (Logic.inr pfXY) := Logic.inr (fun pfXYs => pfXY (distribute_id_bnil pfXYs)).

Equations lift_id_bcons {A} {x y z w : @btree A} :
  (x = y) + (x <> y) ->
  (z = w) + (z <> w) ->
  (bcons x z = bcons y w) + (bcons x z <> bcons y w) :=
lift_id_bcons (Logic.inl id_refl) (Logic.inl id_refl) := Logic.inl id_refl ;
lift_id_bcons (Logic.inl id_refl) (Logic.inr pfZW) :=
  Logic.inr (fun idXZW => pfZW (snd (distribute_id_bcons idXZW))) ;
lift_id_bcons (Logic.inr pfXY) (Logic.inl id_refl) :=
  Logic.inr (fun idXZY => pfXY (fst (distribute_id_bcons idXZY))) ;
lift_id_bcons (Logic.inr pfXY) (Logic.inr _) :=
  Logic.inr (fun pfXZYW => pfXY (fst (distribute_id_bcons pfXZYW))).

Lemma not_bnil_id_bcons : forall
  (A : Set)
  (wildcard : A)
  (xs ys : btree@{Set})
  (H : bnil@{Set} wildcard = bcons@{Set} xs ys), Empty.
intros.
inversion H.
Qed.

Lemma not_bcons_id_bnil : forall
  (A : Set)
  (wildcard : A)
  (xs ys : btree@{Set})
  (H : bcons@{Set} xs ys = bnil@{Set} wildcard), Empty.
intros.
inversion H.
Qed.

Equations dec_id_btree {A} {EqDecA : Classes.EqDec A} : Classes.EqDec (@btree A) :=
dec_id_btree (bnil xs) (bnil ys) := lift_id_bnil (EqDecA xs ys) ;
dec_id_btree (bnil _) (bcons xs ys) := Logic.inr (not_bnil_id_bcons _ _ _ _) ;
dec_id_btree (bcons xs ys) (bnil _) := Logic.inr (not_bcons_id_bnil _ _ _ _) ;
dec_id_btree (bcons xs ys) (bcons zs ws) := lift_id_bcons (dec_id_btree xs zs) (dec_id_btree ys ws).

Program Instance eqdec_btree {A : Type} `{eqDecA : Classes.EqDec A} : Classes.EqDec (@btree A) := {
  Classes.eq_dec := dec_id_btree
}.

Program Instance uip_btree {A : Type} `{eqDecA : Classes.EqDec A} : Classes.UIP (@btree A) := {}.
Next Obligation.
exact (Classes.UIP_hSet btree (EqDecInstances.eqdec_hset btree eqdec_btree) _ _ _ _).
Qed.

Local Close Scope equations_scope.

End BtreeEquationsClasses.


From Coq Require Import Arith Bool List.
From Giskard Require Import lib structures local global.

Import ListNotations.

Set Implicit Arguments.

(** * Safety property one: Prepare stage height injectivity *)

(** ** Prepare stage height injectivity definition *)

(** Recall that a block is in prepare stage in some local state iff it has
received quorum PrepareVote messages or a PrepareQC message in the current
view or some previous view. *)

(** The first safety property states that no two same height blocks can be
at prepare stage in the same view, i.e., prepare stage block height is injective
in the same view. The first safety property differs from the following two in that
it contains an additional premise restricting the view during which the two blocks
reached prepare stage. This is important because it is possible for multiple blocks
at the same height to reach prepare stage across different views in the case of
abnormal view changes. *)

(** In any global state i in a valid protocol trace tr that begins with the initial
state and respects the protocol transition rules, if there are two participating
nodes n and m, and two blocks b1 b2, such that b1 and b2 have the same height,
and both reach prepare stage for n and m's local state respectively in some view p,
but are not equal, then we can prove a contradiction. *)

Definition prepare_stage_same_view_height_injective_statement :=
  forall (tr : GTrace),
    protocol_trace tr ->
    forall (i : nat) (n m : node) (b1 b2 : block) (p : nat),
      In n participants ->
      In m participants ->
      b1 <> b2 ->
      prepare_stage_in_view (fst (tr i) n) p b1 ->
      prepare_stage_in_view (fst (tr i) m) p b2 ->
      b_height b1 = b_height b2 ->
      False.

(** ** Reducing the proof *)

(** Intuitively, the proof of this property follows directly from the definition of
non-Byzantine/honest voting behavior: honest nodes cannot vote for two conflicting
blocks during the same view. If two conflicting blocks reach prepare stage in the
same view, then two quorums of at least 2/3 validators voted for each block.
By the pigeonhole principle, there must exist a set of at least 1/3 validators who
voted for both conflicting blocks and are therefore Byzantine/dishonest. By assumption,
there are no more than 1/3 Byzantine/dishonest blocks. Therefore, we reach a contradiction. *)

(** The formal proof proceeds by identifying a series of conditions that can both prove
that there exist more than 1/3 dishonest nodes (bottom-up) and be proven from the
node-local premises (top-down), and leverages the global broadcast message buffer,
which can be viewed as a ghost variable. Starting with the bottom-up direciton, we
first identify the most obvious sufficient condition for a node to be dishonest:
a node n is dishonest if there exist two equivocating messages in its own local
out-message buffer. *)

(** Local evidence of malice. **)
Definition equivocating_in_state (s : NState) : Prop :=
  exists (msg1 msg2 : message),
    In msg1 (out_messages s) /\
    In msg2 (out_messages s) /\
    get_view msg1 = get_view msg2 /\
    get_message_type msg1 = PrepareVote /\
    get_message_type msg2 = PrepareVote /\
    get_block msg1 <> get_block msg2 /\
    b_height (get_block msg1) = b_height (get_block msg2).

(** However, it turns out that this obvious definition of local evidence of malice is
not the weakest precondition for a node being dishonest: there is a sufficient condition
yet for local evidence of malice. Giskard's transition rules forbid nodes from processing
PrepareBlock messages for conflicting blocks. This in turn prevents nodes from sending
PrepareVote messages for conflicting blocks at the get-go: nodes can only send a PrepareVote
message for a block if they have received the corresponding PrepareBlock message for that
block. Therefore, a malicious node can be detected by the presence of two conflicting
PrepareBlock messages in its processed message buffer. *)

(** If a node has sent a PrepareVote message for some block, then it must have
processed a PrepareBlock message for that block in the same view. *)
Lemma sent_PrepareVote_means_received_PrepareBlock :
  forall (tr : GTrace),
    protocol_trace tr ->
    forall (n : node) (i : nat) (msg : message),
      In n participants ->
      In msg (out_messages (fst (tr i) n)) ->
      get_message_type msg = PrepareVote ->
      exists (msg' : message),
        In msg' (counting_messages (fst (tr i) n)) /\
        get_message_type msg' = PrepareBlock /\
        get_block msg'= get_block msg /\
        get_view msg' = get_view msg.
Proof.
  intros tr H_prot n i msg H_part H_sent H_type.
  generalize dependent msg.
  induction i as [|i IH_prot]; intros.
  - destruct H_prot as [H_init _];
      rewrite H_init in H_sent;
      inversion H_sent.
  - destruct (In_dec message_eq_dec msg (out_messages (fst (tr i) n))) as [H_old | H_new].
    + spec IH_prot msg H_old H_type.
      destruct IH_prot as [msg' IH_prot].
      exists msg'; repeat split; try tauto.
      now apply counting_messages_monotonic.
    + clear IH_prot.
      assert (H_prot_copy := H_prot);
        destruct H_prot as [_ H_prot].
      spec H_prot i.
      destruct H_prot as [[n0 [H_in0 [p0 [msg0 [lm0 [H_step H_deliver]]]]]] | H_timeout].
      (* Establishing that n must be in lm0 *)
      assert (In msg lm0).
      apply (out_messages_change_means_sent H_prot_copy _ _ _ _ H_in0 H_deliver H_step _ H_part);
        try assumption.
      assert (n0 = n).
      apply (out_message_change_tells_sender H_prot_copy _ _ _ _ H_in0 H_deliver H_step n H_part).
      exists msg; tauto. rewrite H0 in *.
      (* Case analysis on transition made from i ~~> S i *)
      destruct p0;
        assert (H_step_copy := H_step);
        destruct H_step as [H_update [H_broadcast H_rest]];
        rewrite H_broadcast in H;
        try apply in_inv in H;
        (* For cases that do not send messages *)
        try tauto;
        try (apply make_PrepareBlocks_message_type in H;
             rewrite H_type in H; discriminate);
        repeat destruct H as [H | H];
        try (subst; rewrite H_type in H_rest;
             assert (PrepareVote = PrepareQC) by tauto;
             discriminate);
        try (rewrite <- H in H_type; discriminate);
        try inversion H.
      (* In the three cases where voting actually occurs,
       the existential witness is in H *)

      apply in_map_iff in H;
      destruct H as [msg' [H_eq' H_about_msg']];
      exists msg'; rewrite <- H_eq';
      apply filter_In in H_about_msg';
      destruct H_about_msg' as [H_in' H_about_msg'];
      apply andb_prop in H_about_msg'.
      destruct H_about_msg' as [H_view' H_type'].
      apply andb_prop in H_view'.
      destruct H_view' as [H_view' _].
      apply andb_prop in H_view'.
      destruct H_view' as [H_view' _].
      rewrite message_type_eqb_correct in H_type'.
      repeat split; try tauto.
      now apply counting_messages_monotonic.
      unfold view_valid in H_rest.
      rewrite Nat.eqb_eq in H_view'.
      rewrite H_view'. symmetry; easy.

      apply in_map_iff in H;
      destruct H as [msg' [H_eq' H_about_msg']];
      exists msg'; rewrite <- H_eq';
      apply filter_In in H_about_msg';
      destruct H_about_msg' as [H_in' H_about_msg'];
      apply andb_prop in H_about_msg'.
      destruct H_about_msg' as [H_view' H_type'].
      apply andb_prop in H_view'.
      destruct H_view' as [H_view' _].
      apply andb_prop in H_view'.
      destruct H_view' as [H_view' _].
      rewrite message_type_eqb_correct in H_type'.
      repeat split; try tauto.
      now apply counting_messages_monotonic.
      unfold view_valid in H_rest.
      rewrite Nat.eqb_eq in H_view'.
      rewrite H_view'. symmetry; easy.

      apply in_map_iff in H;
      destruct H as [msg' [H_eq' H_about_msg']];
      exists msg'; rewrite <- H_eq';
      apply filter_In in H_about_msg';
      destruct H_about_msg' as [H_in' H_about_msg'];
      apply andb_prop in H_about_msg'.
      destruct H_about_msg' as [H_view' H_type'].
      apply andb_prop in H_view'.
      destruct H_view' as [H_view' _].
      apply andb_prop in H_view'.
      destruct H_view' as [H_view' _].
      rewrite message_type_eqb_correct in H_type'.
      repeat split; try tauto.
      now apply counting_messages_monotonic.
      unfold view_valid in H_rest.
      rewrite Nat.eqb_eq in H_view'.
      rewrite H_view'. symmetry; easy.

      (* In the timeout case *)
      rewrite H_timeout in H_sent.
      apply is_member_correct in H_part;
        simpl in H_sent;
        rewrite H_part in H_sent;
        tauto.
Qed.

(** Thus, the following condition is sufficient to show local evidence of malice:
we say that a node is "pre-equivocating" if it has processed two PrepareBlock
messages for two different blocks of the same height in the same view. *)
Definition pre_equivocating_in_state (s : NState) : Prop :=
  exists (msg1 msg2 : message),
    In msg1 (counting_messages s) /\
    In msg2 (counting_messages s) /\
    get_view msg1 = get_view msg2 /\
    get_message_type msg1 = PrepareBlock /\
    get_message_type msg2 = PrepareBlock /\
    get_block msg1 <> get_block msg2 /\
    b_height (get_block msg1) = b_height (get_block msg2).

(** "Pre-equivocation" is a weaker notion than "equivocation". *)
Lemma pre_local_means_local_evidence_of_equivocation :
  forall (tr : GTrace),
    protocol_trace tr ->
    forall (n : node) (i : nat),
      In n participants ->
      equivocating_in_state (fst (tr i) n) ->
      pre_equivocating_in_state (fst (tr i) n).
Proof.
  intros tr H_prot n i H_part [msg1 [msg2 [H_sent1
   [H_sent2 [H_view [H_type1 [H_type2 [H_neq H_height_eq]]]]]]]].
  assert (H_received1 := @sent_PrepareVote_means_received_PrepareBlock
   tr H_prot n i msg1 H_part H_sent1 H_type1).
  assert (H_received2 := @sent_PrepareVote_means_received_PrepareBlock
   tr H_prot n i msg2 H_part H_sent2 H_type2).
  destruct H_received1 as [msg1' [H_processed1'
   [H_type1' [H_block1' H_view1']]]].
  destruct H_received2 as [msg2' [H_processed2'
   [H_type2' [H_block2' H_view2']]]].
  exists msg1', msg2'; repeat split; try tauto.
  now rewrite H_view1', H_view2'.
  now rewrite H_block1', H_block2'.
  now rewrite H_block1', H_block2'.
Qed.

(** Therefore, if we can prove dishonesty from pre-equivocation, then we can
prove dishonesty from equivocation. In other words, we must show the following: *)
Definition pre_local_evidence_of_equivocation_statement :=
  forall (tr : GTrace),
    protocol_trace tr ->
    forall (n : node) (i : nat),
      In n participants ->
      pre_equivocating_in_state (fst (tr i) n) ->
      ~ honest_node n.

(** The proof of the above proceeds by induction, which requires the following two cases: *)
Lemma pre_local_evidence_of_equivocation_middle_case :
 forall (tr : GTrace), protocol_trace tr ->
 forall (n : node) (i : nat), In n participants ->
 forall (msg1 msg2 : message),
  In msg1 (counting_messages (fst (tr (S i)) n)) ->
  In msg2 (counting_messages (fst (tr (S i)) n)) ->
  get_view msg1 = get_view msg2 ->
  get_message_type msg1 = PrepareBlock ->
  get_message_type msg2 = PrepareBlock ->
  get_block msg1 <> get_block msg2 ->
  b_height (get_block msg1) = b_height (get_block msg2) ->
  honest_node n ->
  In msg2 (counting_messages (fst (tr i) n)) ->
  ~ In msg1 (counting_messages (fst (tr i) n)) ->
  False.
Proof.
  intros tr H_prot n i H_part msg1 msg2 H_sent1 H_sent2
    H_view H_type1 H_type2 H_neq H_height_eq H_false H_old2 H_new1.
  assert (H_prot_copy := H_prot);
    destruct H_prot as [_ H_prot];
    spec H_prot i;
    destruct H_prot as [[n0 [H_in0 [p0 [msg0 [lm0 [H_step H_deliver]]]]]] | H_timeout].
  assert (n0 = n).
  apply counting_message_different_tells_receiver with tr i p0 msg0 lm0; try assumption.
  intros H_contra.
  rewrite H_contra in H_new1. contradiction.
  subst.
  assert (H_step_copy := H_step);
  destruct p0;
  destruct H_step as [H_update H_rest];
  rewrite H_update in H_sent1;
  (* In cases that do not process messages *)
  try contradiction;
  (* In cases where n is not honest *)
  try (rewrite (protocol_trace_state_sane H_prot_copy) in H_rest;
       tauto);
  try (simpl in H_sent1;
       destruct H_sent1 as [H_sent1 | H_sent1]);
  try contradiction;
  subst;
  try (rewrite H_type1 in H_rest;
       easy).
  (assert (H_contra : ~ exists_same_height_PrepareBlock (fst (tr i) n) (get_block msg1)) by tauto;
       apply H_contra;
       exists msg2; split; try tauto).
  (assert (H_contra : ~ exists_same_height_PrepareBlock (fst (tr i) n) (get_block msg1)) by tauto;
       apply H_contra;
       exists msg2; split; try tauto).
  simpl in H_type1. discriminate.
  destruct H_sent1 as [H_sent1 | H_sent1].
  subst.
  rewrite H_type1 in H_rest. easy.
  contradiction.
  destruct H_sent1 as [H_sent1 | H_sent1].
  subst.
  simpl in H_type1. discriminate.
  contradiction.
  rewrite H_timeout in H_sent1; simpl in H_sent1.
  apply is_member_correct in H_part.
  rewrite H_part in H_sent1; contradiction.
Qed.

Lemma pre_local_evidence_of_equivocation_last_case :
 forall (tr : GTrace), protocol_trace tr ->
 forall (n : node) (i : nat), In n participants ->
 forall (msg1 msg2 : message),
  In msg1 (counting_messages (fst (tr (S i)) n)) ->
  In msg2 (counting_messages (fst (tr (S i)) n)) ->
  get_view msg1 = get_view msg2 ->
  get_message_type msg1 = PrepareBlock ->
  get_message_type msg2 = PrepareBlock ->
  get_block msg1 <> get_block msg2 ->
  b_height (get_block msg1) = b_height (get_block msg2) ->
  honest_node n ->
  ~ In msg2 (counting_messages (fst (tr i) n)) ->
  ~ In msg1 (counting_messages (fst (tr i) n)) ->
  False.
Proof.
  intros tr H_prot n i H_part msg1 msg2 H_sent1 H_sent2 H_view
   H_type1 H_type2 H_neq H_height_eq H_false H_new2 H_new1.
  assert (H_prot_copy := H_prot);
    destruct H_prot as [_ H_prot];
    spec H_prot i;
    destruct H_prot as [[n0 [H_in0 [p0 [msg0 [lm0 [H_step H_deliver]]]]]] | H_timeout].
  assert (n0 = n).
  apply counting_message_different_tells_receiver with tr i p0 msg0 lm0; try assumption.
  intros H_contra.
  rewrite H_contra in H_new1. contradiction.
  subst.
  assert (H_step_copy := H_step);
    destruct p0;
    destruct H_step as [H_update H_rest];
    rewrite H_update in H_sent1;
    rewrite H_update in H_sent2;
    (* In cases that do not process messages *)
    try contradiction;
    (* In cases where n is not honest *)
    try (rewrite (protocol_trace_state_sane H_prot_copy) in H_rest;
         tauto);
    simpl in H_sent1, H_sent2;
      destruct H_sent1 as [H_sent1 | H_sent1];
      destruct H_sent2 as [H_sent2 | H_sent2];
      try contradiction;
      try (rewrite <- H_sent1, <- H_sent2 in H_neq; easy);
  try (rewrite <- H_sent1 in H_type1; simpl in H_type1; discriminate);
  try (rewrite <- H_sent2 in H_type2; simpl in H_type2; discriminate).
    simpl in H_sent1, H_sent2;
      destruct H_sent1 as [H_sent1 | H_sent1];
      destruct H_sent2 as [H_sent2 | H_sent2].
      try (rewrite <- H_sent1, <- H_sent2 in H_neq; easy).
      contradiction. contradiction. contradiction.
      destruct H_sent2 as [H_sent2 | H_sent2].
      rewrite <- H_sent2 in H_type2; simpl in H_type2; discriminate.
      contradiction.
      destruct H_sent1 as [H_sent1 | H_sent1].
      (rewrite <- H_sent1 in H_type1; simpl in H_type1; discriminate).
      contradiction.
      destruct H_sent2 as [H_sent2 | H_sent2].
      try (rewrite <- H_sent2 in H_type2; simpl in H_type2; discriminate).
      contradiction.
          rewrite H_timeout in H_sent1; simpl in H_sent1.
          apply is_member_correct in H_part.
          rewrite H_part in H_sent1; contradiction.
Qed.

(** Finally, we can show that evidence of "pre-equivocation" is sufficient
to show that a node is dishonest: *)
Lemma pre_local_evidence_of_equivocation :
  forall (tr : GTrace),
    protocol_trace tr ->
    forall (n : node) (i : nat),
      In n participants ->
      pre_equivocating_in_state (fst (tr i) n) ->
      ~ honest_node n.
Proof.
  intros tr H_prot n i H_part [msg1 [msg2 [H_sent1 [H_sent2
   [H_view [H_type1 [H_type2 [H_neq H_height_eq]]]]]]]] H_false.
  induction i as [|i IH_prot].
  - destruct H_prot as [H_init _].
    rewrite H_init in H_sent1.
    inversion H_sent1.
  - destruct (In_dec message_eq_dec msg2 (counting_messages (fst (tr i) n))) as [H_old2 | H_new2].
    + destruct (In_dec message_eq_dec msg1 (counting_messages (fst (tr i) n))) as [H_old1 | H_new1].
      * now apply IH_prot.
      * clear IH_prot.
        now apply pre_local_evidence_of_equivocation_middle_case with tr n i msg1 msg2.
    + destruct (In_dec message_eq_dec msg1 (counting_messages (fst (tr i) n))) as [H_old1 | H_new1].
      * apply pre_local_evidence_of_equivocation_middle_case with tr n i msg2 msg1; try assumption; try easy.
        intro H_eq. symmetry in H_eq. contradiction.
      * clear IH_prot.
        now apply pre_local_evidence_of_equivocation_last_case with tr n i msg1 msg2.
Qed.

(** And therefore, we can prove dishonesty from equivocation by weakning the premise: *)
Lemma local_evidence_of_equivocation :
  forall (tr : GTrace),
    protocol_trace tr ->
    forall (n : node) (i : nat),
    In n participants ->
    equivocating_in_state (fst (tr i) n) ->
    ~ honest_node n.
Proof.
  intros tr H_prot n i H_part H_equiv.
  apply pre_local_means_local_evidence_of_equivocation in H_equiv; try assumption.
  now apply pre_local_evidence_of_equivocation with tr i.
Qed.

(** Continuing to identify conditions from the bottom up, we have established that
in order to show that more than 1/3 participating nodes are dishonest, we must show
that more than 1/3 participating nodes show local evidence of malice. In order to
show local evidence of malice, it suffices to show global evidence of malice. *)

(** Global evidence of malice. **)
Definition equivocating_in_global_state (s : GState) (n : node) :=
  exists msg1 msg2 : message,
    In msg1 (snd s) /\
    In msg2 (snd s) /\
    get_sender msg1 = n /\
    get_sender msg2 = n /\
    get_view msg1 = get_view msg2 /\
    get_message_type msg1 = PrepareVote /\
    get_message_type msg2 = PrepareVote /\
    get_block msg1 <> get_block msg2 /\
    b_height (get_block msg1) = b_height (get_block msg2).

(** Proving that global evidence of malice is indeed a sufficient condition
for local evidence of malice: *)
Lemma global_equivocating_local :
  forall (tr : GTrace),
    protocol_trace tr ->
    forall (n : node) (i : nat),
      In n participants ->
      equivocating_in_global_state (tr i) n ->
      equivocating_in_state (fst (tr i) n).
Proof.
  intros tr H_prot n i H_part H_global.
  destruct H_global as [msg1 [msg2 H_global]].
  exists msg1, msg2; repeat split; try tauto;
    try
      (apply global_local_out_if; try assumption;
       apply filter_In; split; try tauto;
       apply node_eqb_correct; tauto).
Qed.

(** We identify yet another sufficient condition for global evidence of malice:
there exist two vote quorums for b1 and b2 in the global broadcast message buffer.
We show that this is indeed a sufficient condition by completing the following
chain of reasoning:
- we have two global vote quorums, which implies
- more than one third global evidence of malice, which implies
- more than one third local evidence of malice, which implies
- more than one third of nodes are dishonest. *)
Lemma vote_quorum_same_view_global_injective :
  forall (tr : GTrace),
    protocol_trace tr ->
    forall (i : nat) (b1 b2 : block) (p : nat),
      b1 <> b2 ->
      vote_quorum_in_view_global tr i b1 p ->
      vote_quorum_in_view_global tr i b2 p ->
      b_height b1 = b_height b2 ->
      False.
Proof.
  intros tr H_prot i b1 b2 p H_neq H_prepare1 H_prepare2 H_height.
  red in H_prepare1, H_prepare2.
  assert (H_useful := intersection_property).
  unfold quorum in H_prepare1, H_prepare2.
  spec H_useful (map get_sender (PrepareVote_about_block_in_view_global tr i b1 p))
    (map get_sender (PrepareVote_about_block_in_view_global tr i b2 p)) H_prepare1 H_prepare2.
  destruct H_useful as [l_inter [H_inter H_subset]].
  (* All overlapping nodes are participants *)
  assert (H_part : forall n, In n l_inter -> In n participants).
  { intros n H_in.
    spec H_subset n H_in.
    destruct H_subset as [H _].
    apply in_map_iff in H.
    destruct H as [msg [H_sender H_global]].
    apply filter_In in H_global.
    rewrite <- H_sender.
    apply participation_rights_global with tr i; try tauto. }
  (* All overlapping nodes are equivocating in global state *)
  assert (H_step1 : forall n, In n l_inter -> equivocating_in_global_state (tr i) n).
  { intros n H_in. spec H_subset n H_in.
    destruct H_subset as [H_in1 H_in2].
    apply in_map_iff in H_in1.
    destruct H_in1 as [msg1 [H_sender1  H_sent1]].
    apply in_map_iff in H_in2.
    destruct H_in2 as [msg2 [H_sender2 H_sent2]].
    apply filter_In in H_sent1;
      apply filter_In in H_sent2.
    destruct H_sent1 as [H_sent1 H_rest1].
    apply andb_prop in H_rest1.
    destruct H_rest1 as [H_type1 H_view1].
    apply andb_prop in H_type1.
    destruct H_type1 as [H_type1 H_block1].
    destruct H_sent2 as [H_sent2 H_rest2].
    apply andb_prop in H_rest2.
    destruct H_rest2 as [H_type2 H_view2].
    apply andb_prop in H_type2.
    destruct H_type2 as [H_type2 H_block2].
    apply Nat.eqb_eq in H_view1.
    apply Nat.eqb_eq in H_view2.
    apply message_type_eqb_correct in H_type1.
    apply message_type_eqb_correct in H_type2.
    apply block_eqb_correct in H_block1.
    apply block_eqb_correct in H_block2.
    exists msg1, msg2; repeat split; try tauto; try (subst; easy). }
  (* All overlapping nodes are equivocating in their local state *)
  assert (H_step2 : forall n, In n l_inter -> equivocating_in_state (fst (tr i) n)).
  { intros n H_in.
    spec H_step1 n H_in.
    apply global_equivocating_local; try assumption.
    spec H_subset n H_in.
    destruct H_subset as [H _].
    apply in_map_iff in H.
    destruct H as [msg [H_sender H_global]].
    apply filter_In in H_global.
    rewrite <- H_sender.
    apply participation_rights_global with tr i; try tauto. }
  (* All nodes equivocating in their local state are malicious *)
  assert (H_step3 : forall n, In n l_inter -> ~ honest_node n).
  { intros n H_in.
    spec H_part n H_in.
    spec H_step2 n H_in.
    now apply local_evidence_of_equivocation with tr i. }
  apply evil_participants.
  apply minority_subset with l_inter; try assumption.
  intros n H_in.
  apply filter_In. split.
  now apply H_part.
  apply negb_true_iff.
  apply H_step3 in H_in.
  case_eq (honest_nodeb n); auto.
  intro.
  apply honest_nodeb_correct in H; congruence.
Qed.

(** Finally, we close the gap from the top down direction by showing that from
our node-local <<prepare_stage_in_view>> assumption, we can prove the existence
of vote quorum in the global broadcast message buffer. There are two cases
of <<prepare_stage_in_view>>, either a vote quorum in the local processed
message buffer, or a PrepareQC message in the local processed message buffer.
We show the first case: *)
Lemma vote_quorum_local_means_vote_quorum_global :
  forall tr,
    protocol_trace tr ->
    forall (i : nat) (n : node) (b1 : block) (p : nat),
      In n participants ->
      vote_quorum_in_view (fst (tr i) n) p b1 ->
      vote_quorum_in_view_global tr i b1 p.
Proof.
  intros tr H_prot i n b1 p H_part H_local.
  red in H_local.
  apply quorum_subset with
      (processed_PrepareVote_in_view_about_block (fst (tr i) n) p b1);
    try assumption.
  intros msg H_in.
  apply filter_In;
  apply filter_In in H_in. destruct H_in as [H_in H_typeblockview].
  split. apply processed_means_sent_global with n; try assumption.
  assumption.
Qed.

Lemma vote_quorum_in_view_step_global :
  forall tr i b p,
    protocol_trace tr ->
    vote_quorum_in_view_global tr i b p ->
    vote_quorum_in_view_global tr (S i) b p.
Proof.
  intros tr i b p H_prot H_prepare.
  red.
  apply quorum_subset with (PrepareVote_about_block_in_view_global tr i b p).
  assumption. intros.
  apply filter_In in H. apply filter_In.
  split. destruct H. now apply global_messages_monotonic_step.
  tauto.
Qed.

Lemma witnessed_quorum_global :
  forall (tr : GTrace),
    protocol_trace tr ->
    forall (i : nat) (msg : message),
      In msg (snd (tr i)) ->
      get_message_type msg = PrepareQC ->
      vote_quorum_in_view_global tr i (get_block msg) (get_view msg).
Proof.
  intros tr H_prot i;
    induction i as [|i IH_prot];
    intros msg H_in H_type.
  - destruct H_prot as [H_init _];
      rewrite H_init in H_in;
      inversion H_in.
  -  destruct (In_dec message_eq_dec msg (snd (tr i))) as [H_old | H_new].
     + apply vote_quorum_in_view_global_step;
         try assumption.
       now apply IH_prot.
     + assert (H_prot_copy := H_prot);
         destruct H_prot as [_ H_prot];
         spec H_prot i;
         destruct H_prot as [[n0 [H_in0 [p0 [msg0 [lm0 [H_step H_deliver]]]]]] | H_timeout].
       * (* In the normal transition case *)
         assert (H_in_copy := H_in);
           rewrite H_deliver in H_in;
           simpl in H_in;
           rewrite in_app_iff in H_in;
           destruct H_in as [H_in | H_in];
           try contradiction.
         assert (H_step_copy := H_step);
           destruct p0;
           destruct H_step as [H_update [H_out H_rest]];
           rewrite H_out in H_in;
           (* For all cases that do not send messages *)
           try (simpl in H_in;
                contradiction);
           (* For all cases that send messages of the wrong type *)
           try (apply make_PrepareBlocks_message_type in H_in;
                rewrite H_in in H_type; discriminate);
           simpl in H_in;
           repeat destruct H_in as [H_in | H_in];
           try contradiction;
           try (apply pending_PrepareVote_correct in H_in;
                rewrite H_type in H_in;
                easy);
           try (rewrite <- H_in in H_type;
                simpl in H_type;
                discriminate).
         (* In the three cases that actually do send PrepareQC messages *)
         **  (* In the PrepareVote vote case *)
           assert (H_if : vote_quorum_in_view (fst (tr (S i)) n0) (get_view msg0) (get_block msg0)).
           assert (H_extract : vote_quorum_in_view (process (fst (tr i) n0) msg0)
             (get_view msg0) (get_block msg0)) by tauto.
           rewrite H_update.
           red in H_extract. apply quorum_subset with
            (processed_PrepareVote_in_view_about_block (process (fst (tr i) n0) msg0)
            (get_view msg0) (get_block msg0)).
           assumption. intros. apply filter_In in H.
           destruct H as [H_in' H_rest'].
           simpl in H_in'. destruct H_in' as [H_in' | H_in'].
           subst. apply filter_In. simpl. split. left; reflexivity.
           tauto. apply filter_In. simpl. split. right. tauto.
           tauto.
           apply vote_quorum_local_means_vote_quorum_global in H_if; try assumption.
           rewrite <- H_in. simpl.
           assert (H_view_eq : view_valid (fst (tr i) n0) msg0) by tauto.
           unfold view_valid in H_view_eq. rewrite H_view_eq. assumption.
         ** (* In the ViewChange case *)
           (* We want to show that the block contained in the highest ViewChange message
              has reached vote_quorum globally *)
           spec IH_prot {|
            get_message_type := PrepareQC;
            get_view := get_view msg0;
            get_sender := get_sender msg0;
            get_block := get_block (highest_ViewChange_message (process (fst (tr i) n0) msg0));
            get_piggyback_block := GenesisBlock |}.
           spec IH_prot.
           apply delivered_means_sent_global with n0; try assumption.
           tauto. spec IH_prot. reflexivity.
           apply vote_quorum_in_view_global_step; try assumption.
           simpl in IH_prot.
           rewrite <- H_in. simpl.
           assert (H_view_eq : view_valid (fst (tr i) n0) msg0) by tauto.
           rewrite H_view_eq. assumption.
       * rewrite H_timeout in H_in; simpl in H_in; contradiction.
Qed.

(** And the second case, with some help from the two lemmas above: *)
Lemma PrepareQC_local_means_vote_quorum_global :
  forall tr, protocol_trace tr ->
    forall (i : nat) (n : node) (b1 : block) (p : nat),
      In n participants ->
      PrepareQC_in_view (fst (tr i) n) p b1 ->
      vote_quorum_in_view_global tr i b1 p.
Proof.
  intros tr H_prot i n b1 p H_part H_local.
  assert (H_useful := witnessed_quorum_global).
  destruct H_local as [msg [H_processed [H_view [H_block H_type]]]].
  spec H_useful tr H_prot i msg.
  spec H_useful.
  apply processed_means_sent_global with n; try assumption.
  spec H_useful H_type.
  rewrite <- H_block. rewrite <- H_view.
  assumption.
Qed.

(** ** Proof of prepare stage height injectivity *)

(** Finally, we are ready to string everything together to prove the statement
of the first safety theorem: *)
Theorem prepare_stage_same_view_height_injective :
  prepare_stage_same_view_height_injective_statement.
Proof.
  intros tr H_prot i n m b1 b2 p H_part1 H_part2 H_neq H_prepare1 H_prepare2 H_height.
  unfold prepare_stage in H_prepare1, H_prepare2.
  destruct H_prepare1 as [H_vote1 | H_QC1];
    destruct H_prepare2 as [H_vote2 | H_QC2].
  - apply vote_quorum_local_means_vote_quorum_global in H_vote1; try assumption.
    apply vote_quorum_local_means_vote_quorum_global in H_vote2; try assumption.
    now apply vote_quorum_same_view_global_injective with tr i b1 b2 p.
  - apply vote_quorum_local_means_vote_quorum_global in H_vote1; try assumption.
    apply PrepareQC_local_means_vote_quorum_global in H_QC2; try assumption.
    now apply vote_quorum_same_view_global_injective with tr i b1 b2 p.
  - apply vote_quorum_local_means_vote_quorum_global in H_vote2; try assumption.
    apply PrepareQC_local_means_vote_quorum_global in H_QC1; try assumption.
    now apply vote_quorum_same_view_global_injective with tr i b1 b2 p.
  - apply PrepareQC_local_means_vote_quorum_global in H_QC1; try assumption.
    apply PrepareQC_local_means_vote_quorum_global in H_QC2; try assumption.
    now apply vote_quorum_same_view_global_injective with tr i b1 b2 p.
Qed.


From iris.base_logic Require Import lib.iprop.
From iris.proofmode Require Import tactics.

Fixpoint big_sepL3 {PROP : bi} {A B C}
    (Φ : A → B → C → PROP) (l1 : list A) (l2 : list B) (l3 : list C) : PROP :=
  match l1, l2, l3 with
  | [], [], [] => emp
  | x1 :: l1, x2 :: l2, x3 :: l3 => Φ x1 x2 x3 ∗ big_sepL3 Φ l1 l2 l3
  | _, _,_ => False
  end%I.

(* From iris Require Import bi.big_op. *)
(* From stdpp Require Import countable fin_sets functions. *)
(* From iris.algebra Require Export big_op. *)
(* From iris.algebra Require Import list gmap. *)
(* From iris.bi Require Import derived_laws_later. *)
(* From iris.prelude Require Import options. *)
(* Import interface.bi derived_laws.bi derived_laws_later.bi. *)

Section big_sepL3_alt.

  Context `{Σ : !gFunctors}.
  Context {A B C : Type}.

  Definition big_sepL3_alt
      (Φ : A → B → C → iProp Σ) (l1 : list A) (l2 : list B) (l3 : list C) : iProp Σ :=
    (⌜ length l1 = length l2 ⌝)%I ∧ big_sepL2 (fun _ ab c => Φ ab.1 ab.2 c) (zip l1 l2) l3.

  Lemma Forall3_same_length (l : list A) (k : list B) (m : list C) :
    Forall3 (λ _ _ _, True) l k m ↔ length l = length k ∧ length k = length m.
  Proof.
    split.
    - induction 1.
      + auto.
      + simpl. lia.
    - revert k m. induction l.
      + intros ?? [? ?]. rewrite -H in H0. simpl in *.
        destruct k, m; simpl in *; try by exfalso. constructor.
      + intros ?? [? ?]. rewrite -H in H0. simpl in *.
        destruct k, m; simpl in *; try by exfalso. constructor; first auto.
        apply IHl; lia.
  Qed.

  Lemma big_sepL3_alt_equiv
      (Φ : A → B → C → iProp Σ) (l1 : list A) (l2 : list B) (l3 : list C) :
    big_sepL3 Φ l1 l2 l3 ⊣⊢ big_sepL3_alt Φ l1 l2 l3.
  Proof.
    rewrite /big_sepL3_alt.
    apply (anti_symm _).
    - apply bi.and_intro.
      + revert l2 l3. induction l1 as [|x1 l1 IH]=> -[|x2 l2] -[|x3 l3] /=; auto.
        iIntros "[H1 H2]". iDestruct (IH with "H2") as %eq. iPureIntro. lia.
      + revert l2 l3. induction l1 as [|x1 l1 IH]=> -[|x2 l2] -[|x3 l3] /=; auto.
        iIntros "[H1 H2]". iFrame "H1". by iApply IH.
    - apply bi.pure_elim_l. intro eq1.
      iIntros "H". iDestruct (big_sepL2_length with "H") as %eq2.
      assert (Hl : Forall3 (fun _ _ _ => True) l1 l2 l3).
      { apply Forall3_same_length. split; auto.
        rewrite -eq2.
        rewrite -(fmap_length snd).
        rewrite snd_zip; auto. lia.
      }
      iInduction Hl as [|x1 x2 x3 l1 l2 l3 aa bb cc] "IH"; auto.
      simpl. iDestruct "H" as "[H1 H2]". iFrame "H1".
      simpl in *.
      assert (eq1' : length l1 = length l2); first lia.
      assert (eq2' : length (zip l1 l2) = length l3); first lia.
      iSpecialize ("IH" $! eq1' eq2').
      iApply ("IH" with "H2").
  Qed.

End big_sepL3_alt.

Section big_sepL3_lemmas.

  Context `{Σ : !gFunctors}.
  Context {A B C : Type}.

  Global Instance big_sepL3_nil_persistent (Φ : A → B → C → iProp Σ) :
    Persistent (big_sepL3 Φ [] [] []).
  Proof. simpl; apply _. Qed.
  Global Instance big_sepL3_persistent (Φ : A → B → C → iProp Σ) l1 l2 l3 :
    (∀ x1 x2 x3, Persistent (Φ x1 x2 x3)) →
    Persistent (big_sepL3 Φ l1 l2 l3).
  Proof.
    rewrite big_sepL3_alt_equiv /big_sepL3_alt. apply _.
  Qed.

  (* TODO; clean up versions using alt version *)
  Lemma big_sepL3_lookup
      (Φ : A → B → C → iProp Σ) l1 l2 l3 i x1 x2 x3 :
    l1 !! i = Some x1 → l2 !! i = Some x2 → l3 !! i = Some x3 →
    big_sepL3 Φ l1 l2 l3 ⊢ Φ x1 x2 x3.
  Proof.
    generalize dependent l3.
    generalize dependent l2.
    generalize dependent l1.
    induction i.
    - intros l1 l2 l3 H1 H2 H3. iIntros "H".
      destruct l1 as [|a1 k1]; inversion H1. destruct l2 as [|a2 k2]; inversion H2. destruct l3 as [|a3 k3]; inversion H3.
      simpl. iDestruct "H" as "[a b]". auto.
    - intros l1 l2 l3 H1 H2 H3.
      destruct l1 as [|a1 k1]; inversion H1. destruct l2 as [|a2 k2]; inversion H2. destruct l3 as [|a3 k3]; inversion H3.
      iIntros "H".
      iApply (IHi k1 k2 k3 H0 H4 H5).
      simpl. iDestruct "H" as "[a b]". auto.
  Qed.

  Lemma big_sepL3_length
      (Φ : A → B → C → iProp Σ) l1 l2 l3 : big_sepL3 Φ l1 l2 l3 ⊢ ⌜ length l1 = length l2 ⌝ ∧ ⌜ length l2 = length l3 ⌝.
  Proof.
    generalize dependent l3.
    generalize dependent l2.
    generalize dependent l1.
    induction l1.
    - intros. destruct l2; destruct l3; auto.
    - intros. destruct l2; destruct l3; auto.
      iIntros "H". simpl. rewrite IHl1. iDestruct "H" as "[H %I]". iPureIntro. lia.
  Qed.

  Lemma big_sepL3_fmap_l {A' : Type} (f : A → A') (Φ : A' → B → C → iProp Σ) l1 l2 l3 :
    big_sepL3 (fun a b c => Φ (f a) b c) l1 l2 l3
    ⊣⊢ big_sepL3 (fun a b c => Φ a b c) (f <$> l1) l2 l3.
  Proof.
    generalize dependent l3.
    generalize dependent l2.
    generalize dependent l1.
    induction l1.
    - intros. destruct l2; destruct l3; auto.
    - intros. destruct l2; destruct l3; auto. simpl. specialize (IHl1 l2 l3).
      iSplit; iIntros "[H1 H2]"; iFrame "H1"; by iApply IHl1.
  Qed.

  Lemma big_sepL3_fmap_r {C' : Type} (f : C → C') (Φ : A → B → C' → iProp Σ) l1 l2 l3 :
    big_sepL3 (fun a b c => Φ a b (f c)) l1 l2 l3
    ⊣⊢ big_sepL3 (fun a b c => Φ a b c) l1 l2 (f <$> l3).
  Proof.
    generalize dependent l3.
    generalize dependent l2.
    generalize dependent l1.
    induction l1.
    - intros. destruct l2; destruct l3; auto.
    - intros. destruct l2; destruct l3; auto. simpl. specialize (IHl1 l2 l3).
      iSplit; iIntros "[H1 H2]"; iFrame "H1"; by iApply IHl1.
  Qed.

  Lemma big_sepL3_impl (Φ Ψ : A → B → C → iProp Σ) l1 l2 l3 :
    ⊢ big_sepL3 Φ l1 l2 l3 -∗ □ (∀ x1 x2 x3, Φ x1 x2 x3 -∗ Ψ x1 x2 x3) -∗ big_sepL3 Ψ l1 l2 l3.
  Proof.
    generalize dependent l3.
    generalize dependent l2.
    generalize dependent l1.
    induction l1.
    - intros. destruct l2; destruct l3; auto.
    - intros. destruct l2; destruct l3; auto. simpl. specialize (IHl1 l2 l3).
      iIntros "[Habc Hl1l2l3] #Himpl". iSplitL "Habc". by iApply "Himpl". by iApply (IHl1 with "Hl1l2l3").
  Qed.

  Lemma big_sepL3_pure (Φ : A → B → C → Prop) l1 l2 l3 :
    @bi_emp_valid (uPredI (iResUR Σ)) (big_sepL3 (fun a b c => ⌜ Φ a b c ⌝) l1 l2 l3 -∗ ⌜ Forall3 Φ l1 l2 l3⌝)%I.
  Proof.
    generalize dependent l3.
    generalize dependent l2.
    generalize dependent l1.
    induction l1.
    - intros. destruct l2; destruct l3; auto. iPureIntro. constructor.
    - intros. destruct l2; destruct l3; auto. simpl.
      iIntros "[%Habc H]". iDestruct (IHl1 with "H") as "%Y". iPureIntro. by constructor.
  Qed.

  Lemma big_sepL3_superfluous_zip_r_l (Φ : A → B → (A * C) → iProp Σ) l1 l2 l3 :
    big_sepL3 (fun a b c => Φ a b (a , c)) l1 l2 l3 ⊢ big_sepL3 Φ l1 l2 (zip l1 l3).
  Proof.
    generalize dependent l3.
    generalize dependent l2.
    generalize dependent l1.
    induction l1.
    - intros. destruct l2; destruct l3; auto.
    - intros. destruct l2; destruct l3; auto. simpl. specialize (IHl1 l2 l3).
      iIntros "[H1 H2]". iFrame "H1". by iApply IHl1.
  Qed.

  Lemma big_sepL3_app_inv (Φ : A → B → C → iProp Σ) l1 l2 l1' l2' l1'' l2'' :
    (length l1 = length l1' ∧ length l1' = length l1'') ∨ (length l2 = length l2' ∧ length l2' = length l2'') →
    (big_sepL3 Φ (l1 ++ l2) (l1' ++ l2') (l1'' ++ l2'')) -∗
    (big_sepL3 Φ l1 l1' l1'') ∗ (big_sepL3 Φ l2 l2' l2'').
  Proof.
    revert l1' l1''. induction l1 as [|x1 l1 IH].
    - intros. destruct H as [[eq1 eq2]|[eq1 eq2]].
      + destruct l1'; [|by inversion eq1]. destruct l1'';[|by inversion eq2].
        rewrite !app_nil_l. simpl. auto.
      + iIntros "H". iDestruct (big_sepL3_length with "H") as "[%eq3 %eq4]".
        rewrite !app_length in eq3,eq4.
        destruct l1'; [|simpl in *; lia]. destruct l1'';[|simpl in *; lia].
        rewrite !app_nil_l. auto.
    - intros. destruct H as [[eq1 eq2]|[eq1 eq2]].
      + destruct l1' as [|x1' l1']; [by inversion eq1|].
        destruct l1'' as [|x1'' l1''];[by inversion eq2|].
        rewrite -!app_comm_cons. simpl.
        iIntros "[H1 H2]". iFrame "H1". iApply (IH with "H2"). left. split; eauto.
      + iIntros "H". iDestruct (big_sepL3_length with "H") as "[%eq3 %eq4]".
        rewrite !app_length in eq3, eq4.
        destruct l1' as [|x1' l1']; [simpl in *; lia|].
        destruct l1'' as [|x1'' l1''];[simpl in *; lia|].
        simpl. iDestruct "H" as "[H1 H2]". iFrame "H1". iApply (IH with "H2"). auto.
  Qed.

  Lemma big_sepL3_singleton (Φ : A → B → C → iProp Σ) (x1 : A) (x2 : B) (x3 : C) :
    (big_sepL3 Φ [x1] [x2] [x3]) ⊣⊢ Φ x1 x2 x3.
  Proof. simpl. iSplit; auto. by iIntros "[H _]". Qed.

  (* Lemma big_sepL3_impl (Φ Ψ : A → B → C → iProp Σ) l1 l2 l3 : *)
  (*   ⊢ □ (∀ x1 x2 x3, Φ x1 x2 x3 ∗-∗ Ψ x1 x2 x3) -∗ big_sepL3 Φ l1 l2 l3 ∗-∗ big_sepL3 Ψ l1 l2 l3. *)
  (* Proof. *)
  (*   generalize dependent l3. *)
  (*   generalize dependent l2. *)
  (*   generalize dependent l1. *)
  (*   induction l1. *)
  (*   - intros. destruct l2; destruct l3; auto. *)
  (*   - intros. destruct l2; destruct l3; auto. simpl. specialize (IHl1 l2 l3). *)
  (*     iIntros "#HΦΨ". *)
  (*     iSplit; iIntros "[H1 H2]"; iSplitL "H1 HΦΨ"; try iApply "HΦΨ"; auto; try by iApply IHl1. *)
  (* Qed. *)

End big_sepL3_lemmas.


Require Export Lattice.
Require Export Monads.
Require Export Strategy.
Require Export StrategyUtils.
Require Import FSetInterface.
Require Import FMapInterface.
Require Import Program.Basics.
Require Import Utf8.

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

Module Type CSysJoinSemiLat.
  Declare Module V : UsualDecidableTypeBoth.
  Declare Module D : JoinSemiLattice.

  Parameter F : V.t -> FuncType V.t D.t D.t.
End CSysJoinSemiLat.

Module Type CSys <: CSysJoinSemiLat.
  Declare Module V : UsualDecidableTypeBoth.
  Declare Module D : Lattice.

  Parameter F : V.t -> FuncType V.t D.t D.t.
  (*Parameter F :
    forall (M : monadType), V.t -> (V.t -> M D.t) -> M D.t.*)
End CSys.

(* TODO *)
Module Type WNCSys.
  Declare Module V : UsualDecidableTypeBoth.
  Declare Module D : WNLattice.

  Parameter F : forall (M : monadType), V.t -> (V.t -> M D.t) -> M D.t.
End WNCSys.

Module Type NatWNCSys.
  Declare Module V : UsualDecidableTypeBoth.
  Declare Module D : WNLattice.

  Parameter VarIsNat : V.t = nat.

  Parameter F : forall (M : monadType), V.t -> (V.t -> M D.t) -> M D.t.
End NatWNCSys.

(*Module Type CSysLocalSolver (Import C : CSys).
  Include D.

  Declare Module VSet : FSetInterface.WSfun (V).
  Declare Module VMap : FMapInterface.WSfun (V).

  Parameter solve : ∀ (X : VSet.t), VMap.t t.

  Infix "∈" := VSet.In (at level 65, no associativity).

  Infix "∈₁" := VMap.In (at level 65, no associativity).
  Infix "⊆" := VSet.Subset (at level 70, no associativity).
  Module PD := OptionLattice (D).
  Infix "⊑₁" := PD.Leq (at level 70, no associativity).

  Section correctness.
    Variable X : VSet.t.
    Let sol := solve X.
    Let σ   := λ x, VMap.find x sol .

    Variable x : V.t.
    Axiom A1: x ∈ X -> x ∈₁ sol.
    Axiom A2: x ∈₁ sol -> (@F Error x σ) ≠ None.
    Axiom A3: x ∈₁ sol -> (@F Error x σ) ⊑₁ σ x.
  End correctness.
End CSysLocalSolver.*)

(*Module HSys (Import C:WNCSys) <: WNCSys.
  Module V := V.
  Module D := D.
  Import D.
  Definition F (m:monadType) (v:V.t) (get:V.t->m t) : m t :=
    do old <- get v;
       do new <- @F m v get;
          return m (if leq new old then old Δ new else old ∇ new).
End HSys.*)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive bool : Set :=
| True : bool
| False : bool.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Fixpoint eqb (n : natural) (m : natural) {struct n} : bool :=
  match n with
  | Succ n' =>
    match m with
    | Succ m' => eqb n' m'
    | Zero => False
    end
  | Zero =>
    match m with
    | Succ _ => False
    | Zero => True
    end
  end.

Definition synth (lf2 : natural) (lf1 : natural) : natural := lf2.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal35.

From lfind Require Import LFind.
Lemma lfind_state  (y:natural):@eq natural (mult Zero y) (mult y Zero).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_mult_commut_85_mult_zero/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (y:natural) :=
 let lfind_var := "y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print y lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


(** * Reflective subcategories *)
(** ** Contents

  - Definition
 *)

Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.

Require Import UniMath.CategoryTheory.Adjunctions.Core.

Section Def.

  Context {C : category}.

  Definition is_reflective (D : hsubtype C) :=
    is_right_adjoint (sub_precategory_inclusion C (full_sub_precategory D)).

  Definition reflective_subcategory : UU :=
    ∑ D : hsubtype C, is_reflective D.

  Definition reflective_subcategory_to_hsubtype
            (D : reflective_subcategory) : hsubtype C :=
    pr1 D.

  Coercion reflective_subcategory_to_hsubtype :
    reflective_subcategory >-> hsubtype.

  Definition reflective_subcategory_to_precategory :
    reflective_subcategory -> precategory.
    intro D; exact (full_sub_precategory D).
  Defined.

  Coercion reflective_subcategory_to_precategory :
    reflective_subcategory >-> precategory.

  Definition localization (R : reflective_subcategory) :
    functor C (full_sub_precategory R) := left_adjoint (pr2 R).

End Def.

Arguments reflective_subcategory _ : clear implicits.

Lemma localization_is_idempotent {C : category} (R : reflective_subcategory C)
      (d : ob R) :
  z_iso (localization R (precategory_object_from_sub_precategory_object _ _ d)) d.
Proof.
  exists ((counit_from_left_adjoint (pr2 (pr2 R))) d).
  abstract (
        apply (@counit_is_z_iso_if_right_adjoint_is_fully_faithful
                 C (subcategory C (full_sub_precategory R)) _ _ (pr2 (pr2 R))),
        fully_faithful_sub_precategory_inclusion).
Defined.


From isla Require Import opsem.

Definition a30 : isla_trace :=
  Smt (DeclareConst 42%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R23" [] (RegVal_Base (Val_Symbolic 42%Z)) Mk_annot :t:
  Smt (DeclareConst 44%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R8" [] (RegVal_Base (Val_Symbolic 44%Z)) Mk_annot :t:
  Smt (DefineConst 75%Z (Manyop (Bvmanyarith Bvadd) [Unop (Extract 63%N 0%N) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 42%Z) Mk_annot) Mk_annot) Mk_annot; Unop (Extract 63%N 0%N) (Unop (ZeroExtend 64%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 44%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot) Mk_annot) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R24" [] (RegVal_Base (Val_Symbolic 75%Z)) Mk_annot :t:
  Smt (DeclareConst 76%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 76%Z)) Mk_annot :t:
  Smt (DefineConst 77%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 76%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 77%Z)) Mk_annot :t:
  tnil
.


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

Require Export CoRN.algebra.CPoly_Degree.
Require Export CoRN.algebra.COrdFields2.
Require Import Coq.Classes.Morphisms Coq.Sorting.Permutation.
Require MathClasses.implementations.ne_list.
Import CRing_Homomorphisms.coercions.
Import ne_list.notations ne_list.coercions.

Set Automatic Introduction.

(**
* Polynomials apart from zero *)

Definition distinct1 (A : CSetoid) (f : nat -> A) := forall i j, i <> j -> f i [#] f j.

Arguments distinct1 [A].

Section Poly_Representation.
(**
** Representation of polynomials
%\begin{convention}% Let [R] be a field, [RX] the ring of polynomials
over [R], [a_ : nat->R] with [(distinct1 a_)] and let [f] be a
polynomial over [R], [n] a natural with [(degree_le n f)], i.e. [f]
has degree at most [n].
%\end{convention}%
*)

Variable R : CField.
Variable a_ : nat -> R.
Hypothesis distinct_a_ : distinct1 a_.
Variable f : cpoly_cring R.
Variable n : nat.
Hypothesis degree_f : degree_le n f.

Add Ring cpolycring_th : (cpoly_ring_th R).

(* begin hide *)
Notation RX := (cpoly_cring R).
(* end hide *)

Load "Transparent_algebra".

Lemma poly_linear_shifted : forall (a : R) (f : RX),
 {f' : RX | {f'' : R | f [=] (_X_[-]_C_ a) [*]f'[+]_C_ f''}}.
Proof.
 intros.
 induction  f0 as [| s f0 Hrecf0]; intros.
  exists (cpoly_zero R).
  exists ([0]:R).
  simpl in |- *.
  algebra.
 elim Hrecf0. intro g'. intros H.
 elim H. intro g''. intros H0.
 exists (_X_[*]g'[+]_C_ g'').
 exists (a[*]g''[+]s).
 astepl (_X_[*]f0[+]_C_ s).
 astepl (_X_[*] ((_X_[-]_C_ a) [*]g'[+]_C_ g'') [+]_C_ s).
 apply eq_symmetric_unfolded.
 cut (_C_ (a[*]g''[+]s) [=] _C_ a[*]_C_ g''[+]_C_ s). intro.
  astepl ((_X_[-]_C_ a) [*] (_X_[*]g'[+]_C_ g'') [+] (_C_ a[*]_C_ g''[+]_C_ s)).
  unfold cg_minus. ring.
 Step_final (_C_ (a[*]g'') [+]_C_ s).
Qed.
Load "Opaque_algebra".

Lemma poly_linear_factor : forall (f : RX) a, f ! a [=] [0] -> {f' : RX | f [=] (_X_[-]_C_ a) [*]f'}.
Proof.
 intros.
 elim (poly_linear_shifted a f0). intro f'. intros H0.
 elim H0. intro f''. intros H1.
 exists f'.
 cut (_C_ f'' [=] [0]). intro.
  astepl ((_X_[-]_C_ a) [*]f'[+]_C_ f'').
  Step_final ((_X_[-]_C_ a) [*]f'[+][0]).
 astepr (_C_ ([0]:R)).
 apply cpoly_const_eq.
 astepl ([0][+]f'').
 astepl ([0][*]f' ! a[+]f'').
 astepl ((a[-]a) [*]f' ! a[+]f'').
 astepl ((_X_ ! a[-] (_C_ a) ! a) [*]f' ! a[+]f'').
 astepl ((_X_[-]_C_ a) ! a[*]f' ! a[+]f'').
 astepl (((_X_[-]_C_ a) [*]f') ! a[+]f'').
 astepl (((_X_[-]_C_ a) [*]f') ! a[+] (_C_ f'') ! a).
 astepl ((_X_[-]_C_ a) [*]f'[+]_C_ f'') ! a.
 Step_final f0 ! a.
Qed.

Lemma zero_poly : forall n,
  (forall i j: nat, i <= n -> j <= n -> i <> j -> a_ i[#]a_ j) ->
  forall (f : RX),
 degree_le n f -> (forall i, i <= n -> f ! (a_ i) [=] [0]) -> f [=] [0].
Proof with auto.
 intro.
 clear degree_f n distinct_a_.
 intro distinct_a_.
 induction  n0 as [| n0 Hrecn0]; intros.
  elim (degree_le_zero _ _ H). intros.
  astepl (_C_ x).
  astepr (_C_ ([0]:R)).
  apply cpoly_const_eq.
  apply eq_transitive_unfolded with f0 ! (a_ 0).
   Step_final (_C_ x) ! (a_ 0).
  apply H0...
 cut (f0 ! (a_ (S n0)) [=] [0])... intro.
 elim (poly_linear_factor f0 (a_ (S n0)) H1). intro f'. intros.
 astepl ((_X_[-]_C_ (a_ (S n0))) [*]f').
 cut (f' [=] [0]). intro.
  Step_final ((_X_[-]_C_ (a_ (S n0))) [*][0]).
 apply Hrecn0.
   intuition.
  apply degree_le_mult_imp with (_X_[-]_C_ (a_ (S n0))) 1.
   apply degree_minus_lft with 0...
    apply degree_le_c_.
   apply degree_x_.
  apply degree_le_wd with f0...
 intros.
 apply mult_cancel_lft with (a_ i[-]a_ (S n0)).
  apply minus_ap_zero.
  apply distinct_a_...
  intro; rewrite H3 in H2; exact (le_Sn_n _ H2).
 astepr ([0]:R).
 cut (a_ i[-]a_ (S n0) [=] (_X_[-]_C_ (a_ (S n0))) ! (a_ i)). intro.
  astepl ((_X_[-]_C_ (a_ (S n0))) ! (a_ i) [*]f' ! (a_ i)).
  astepl ((_X_[-]_C_ (a_ (S n0))) [*]f') ! (a_ i).
  astepl f0 ! (a_ i)...
 Step_final (_X_ ! (a_ i) [-] (_C_ (a_ (S n0))) ! (a_ i)).
Qed.

Lemma identical_poly :
  (forall i j: nat, i <= n -> j <= n -> i <> j -> a_ i[#]a_ j) ->
  forall f g : RX, degree_le n f -> degree_le n g ->
   (forall i, i <= n -> f ! (a_ i) [=] g ! (a_ i)) -> f [=] g.
Proof.
 intros.
 apply cg_inv_unique_2.
 apply zero_poly with n.
   assumption.
  apply degree_le_minus; auto.
 intros.
 astepl (f0 ! (a_ i) [-]g ! (a_ i)).
 Step_final (f0 ! (a_ i) [-]f0 ! (a_ i)).
Qed.

Definition poly_01_factor' (n : nat) := _X_[-]_C_ (a_ n).

Lemma poly_01_factor'_degree : forall n, degree_le 1 (poly_01_factor' n).
Proof.
 intros.
 unfold poly_01_factor' in |- *.
 apply degree_imp_degree_le.
 apply degree_minus_lft with 0.
   apply degree_le_c_.
  apply degree_x_.
 auto.
Qed.

Lemma poly_01_factor'_zero : forall n, (poly_01_factor' n) ! (a_ n) [=] [0].
Proof.
 intros.
 unfold poly_01_factor' in |- *.
 astepl (_X_ ! (a_ n0) [-] (_C_ (a_ n0)) ! (a_ n0)).
 Step_final (a_ n0[-]a_ n0).
Qed.

Lemma poly_01_factor'_apzero :
 forall n i, i <> n -> (poly_01_factor' n) ! (a_ i) [#] [0].
Proof.
 intros.
 unfold poly_01_factor' in |- *.
 astepl (_X_ ! (a_ i) [-] (_C_ (a_ n0)) ! (a_ i)).
 astepl (a_ i[-]a_ n0). algebra.
Qed.

Hint Resolve poly_01_factor'_zero.

Definition poly_01_factor n i (H : i <> n) :=
 poly_01_factor' n[*]
   _C_ ([1][/] (poly_01_factor' n) ! (a_ i) [//]poly_01_factor'_apzero n i H).

Lemma poly_01_factor_degree : forall n i H, degree_le 1 (poly_01_factor n i H).
Proof.
 intros.
 unfold poly_01_factor in |- *.
 replace 1 with (1 + 0).
  apply degree_le_mult.
   apply poly_01_factor'_degree.
  apply degree_le_c_.
 auto.
Qed.

Lemma poly_01_factor_zero : forall n i H, (poly_01_factor n i H) ! (a_ n) [=] [0].
Proof.
 intros.
 unfold poly_01_factor in |- *.
 astepl ((poly_01_factor' n0) ! (a_ n0) [*] (_C_
   ([1][/] (poly_01_factor' n0) ! (a_ i) [//]poly_01_factor'_apzero n0 i H)) ! (a_ n0)).
 Step_final ([0][*] (_C_ ([1][/] (poly_01_factor' n0) ! (a_ i) [//]poly_01_factor'_apzero n0 i H))
   ! (a_ n0)).
Qed.

Lemma poly_01_factor_one : forall n i H, (poly_01_factor n i H) ! (a_ i) [=] [1].
Proof.
 intros.
 unfold poly_01_factor in |- *.
 astepl ((poly_01_factor' n0) ! (a_ i) [*] (_C_
   ([1][/] (poly_01_factor' n0) ! (a_ i) [//]poly_01_factor'_apzero n0 i H)) ! (a_ i)).
 astepl ((poly_01_factor' n0) ! (a_ i) [*]
   ([1][/] (poly_01_factor' n0) ! (a_ i) [//]poly_01_factor'_apzero n0 i H)).
 apply div_1'.
Qed.

Hint Resolve poly_01_factor_zero poly_01_factor_one: algebra.

Fixpoint poly_01 (i n : nat) {struct n} : cpoly_cring R :=
  match eq_nat_dec i n with
  | left  _  => [1]
  | right ne => poly_01_factor n i ne
  end
  [*]
  match n with
  | O   => [1]
  | S m => poly_01 i m
  end.

Lemma poly_01_degree' : forall n i, degree_le (S n) (poly_01 i n).
Proof.
 intros.
 induction  n0 as [| n0 Hrecn0]. intros.
  simpl in |- *.
  elim (eq_nat_dec i 0); intro y.
   apply degree_le_wd with (_C_ ([1]:R)).
    Step_final ([1]:cpoly_cring R).
   apply degree_le_mon with 0.
    auto with arith.
   apply degree_le_c_.
  apply degree_le_wd with (poly_01_factor 0 i y).
   algebra.
  apply poly_01_factor_degree.
 simpl in |- *.
 elim (eq_nat_dec i (S n0)); intro.
  apply degree_le_mon with (S n0).
   auto.
  apply degree_le_wd with (poly_01 i n0).
   algebra.
  auto.
 replace (S (S n0)) with (1 + S n0).
  apply degree_le_mult.
   apply poly_01_factor_degree.
  auto.
 auto.
Qed.

Lemma poly_01_degree : forall n i, i <= n -> degree_le n (poly_01 i n).
Proof.
 intros.
 induction  n0 as [| n0 Hrecn0]; intros.
  simpl in |- *.
  elim (eq_nat_dec i 0); intro y.
   apply degree_le_wd with (_C_ ([1]:R)).
    Step_final ([1]:cpoly_cring R).
   apply degree_le_c_.
  cut (i = 0). intro.
   elim (y H0).
  auto with arith.
 simpl in |- *.
 elim (eq_nat_dec i (S n0)); intro.
  apply degree_le_wd with (poly_01 i n0).
   algebra.
  apply poly_01_degree'.
 pattern (S n0) at 1 in |- *.
 replace (S n0) with (1 + n0).
  apply degree_le_mult.
   apply poly_01_factor_degree.
  apply Hrecn0.
  elim (le_lt_eq_dec _ _ H); auto with arith.
  intro; elim (b b0).
 auto.
Qed.

Lemma poly_01_zero : forall n i j, j <= n -> j <> i -> (poly_01 i n) ! (a_ j) [=] [0].
Proof.
 intros.
 induction  n0 as [| n0 Hrecn0]; intros.
  rewrite <- (le_n_O_eq j H).
  rewrite <- (le_n_O_eq j H) in H0.
  simpl in |- *.
  elim (eq_nat_dec i 0); intro y.
   rewrite y in H0.
   elim (H0 (refl_equal 0)).
  astepl ((poly_01_factor 0 i y) ! (a_ 0) [*][1] ! (a_ 0)).
  astepl ((poly_01_factor 0 i y) ! (a_ 0) [*][1]).
  astepl (poly_01_factor 0 i y) ! (a_ 0).
  apply poly_01_factor_zero.
 elim (eq_nat_dec j (S n0)); intro y.
  simpl in |- *.
  rewrite <- y.
  elim (eq_nat_dec i j); intro y0.
   rewrite y0 in H0.
   elim (H0 (refl_equal j)).
  astepl ((poly_01_factor j i y0) ! (a_ j) [*] (poly_01 i n0) ! (a_ j)).
  Step_final ([0][*] (poly_01 i n0) ! (a_ j)).
 cut (j <= n0). intro.
  simpl in |- *.
  elim (eq_nat_dec i (S n0)); intro y0.
   astepl ([1] ! (a_ j) [*] (poly_01 i n0) ! (a_ j)).
   Step_final ([1] ! (a_ j) [*][0]).
  astepl ((poly_01_factor (S n0) i y0) ! (a_ j) [*] (poly_01 i n0) ! (a_ j)).
  Step_final ((poly_01_factor (S n0) i y0) ! (a_ j) [*][0]).
 elim (le_lt_eq_dec _ _ H); auto with arith.
 intro; elim (y b).
Qed.

Lemma poly_01_one : forall n i, (poly_01 i n) ! (a_ i) [=] [1].
Proof.
 intros.
 induction  n0 as [| n0 Hrecn0]; intros.
  simpl in |- *.
  elim (eq_nat_dec i 0); intro y.
   astepl ([1] ! (a_ i) [*][1] ! (a_ i)).
   Step_final ([1][*] ([1]:R)).
  astepl ((poly_01_factor 0 i y) ! (a_ i) [*][1] ! (a_ i)).
  astepl ((poly_01_factor 0 i y) ! (a_ i) [*][1]).
  astepl (poly_01_factor 0 i y) ! (a_ i).
  apply poly_01_factor_one.
 simpl in |- *.
 elim (eq_nat_dec i (S n0)); intro y.
  astepl ([1] ! (a_ i) [*] (poly_01 i n0) ! (a_ i)).
  astepl ([1][*] (poly_01 i n0) ! (a_ i)).
  Step_final ([1][*] ([1]:R)).
 astepl ((poly_01_factor (S n0) i y) ! (a_ i) [*] (poly_01 i n0) ! (a_ i)).
 astepl ((poly_01_factor (S n0) i y) ! (a_ i) [*][1]).
 astepl (poly_01_factor (S n0) i y) ! (a_ i).
 apply poly_01_factor_one.
Qed.

Hint Resolve poly_01_zero poly_01_one: algebra.

Lemma poly_representation'' : forall (a : nat -> R) i,
 i <= n -> (forall j, j <> i -> a j [=] [0]) -> Sum 0 n a [=] a i.
Proof.
 intro. intro.
 elim i.
  intros.
  astepl (a 0[+]Sum 1 n a).
  astepr (a 0[+][0]).
  apply bin_op_wd_unfolded.
   algebra.
  apply Sum_zero.
   auto with arith.
  intros.
  apply H0.
  intro; rewrite H3 in H1; inversion H1.
 intro i'.
 intros.
 astepl (Sum 0 i' a[+]Sum (S i') n a).
 astepr ([0][+]a (S i')).
 apply bin_op_wd_unfolded.
  apply Sum_zero.
   auto with arith.
  intros.
  apply H1.
  intro; rewrite H4 in H3; exact (le_Sn_n _ H3).
 astepl (a (S i') [+]Sum (S (S i')) n a).
 astepr (a (S i') [+][0]).
 apply bin_op_wd_unfolded.
  algebra.
 apply Sum_zero.
  auto with arith.
 intros.
 apply H1.
 intro; rewrite H4 in H2; exact (le_Sn_n _ H2).
Qed.

Lemma poly_representation' : forall (f_ : nat -> RX) k,
 k <= n -> (Sum 0 n (fun i => f_ i[*]poly_01 i n)) ! (a_ k) [=] (f_ k) ! (a_ k).
Proof.
 intros.
 apply eq_transitive_unfolded with (Sum 0 n (fun i : nat => (f_ i[*]poly_01 i n) ! (a_ k))).
  apply Sum_cpoly_ap with (f := fun i : nat => f_ i[*]poly_01 i n).
 astepl (Sum 0 n (fun i : nat => (f_ i) ! (a_ k) [*] (poly_01 i n) ! (a_ k))).
 astepr ((f_ k) ! (a_ k) [*][1]).
 astepr ((f_ k) ! (a_ k) [*] (poly_01 k n) ! (a_ k)).
 apply poly_representation'' with (a := fun i : nat => (f_ i) ! (a_ k) [*] (poly_01 i n) ! (a_ k)).
  auto.
 intros.
 Step_final ((f_ j) ! (a_ k) [*][0]).
Qed.

Lemma poly_representation : f [=] Sum 0 n (fun i => _C_ f ! (a_ i) [*]poly_01 i n).
Proof.
 apply identical_poly; auto.
  apply Sum_degree_le. auto with arith. intros.
   replace n with (0 + n).
   apply degree_le_mult.
    apply degree_le_c_.
   apply poly_01_degree.
   auto.
  auto with arith.
 intros.
 apply eq_symmetric_unfolded.
 astepr (_C_ f ! (a_ i)) ! (a_ i).
 apply poly_representation' with (f_ := fun i : nat => _C_ f ! (a_ i)).
 auto.
Qed.

Hint Resolve poly_representation: algebra.

Lemma Cpoly_choose_apzero : f [#] [0] -> {i : nat | i <= n | f ! (a_ i) [#] [0]}.
Proof.
 intros H.
 cut (Sum 0 n (fun i : nat => _C_ f ! (a_ i) [*]poly_01 i n) [#] [0]). intros H0.
  elim (Sum_apzero _ (fun i : nat => _C_ f ! (a_ i) [*]poly_01 i n) 0 n ( le_O_n n) H0).
  intro i. intro H1.
  elim H1. intros H2 H3. intro H4.
  exists i.
   auto.
  apply poly_c_apzero.
  apply cring_mult_ap_zero with (poly_01 i n).
  auto.
 astepl f. auto.
Qed.

End Poly_Representation.

Section Characteristic_zero.

(**
If we are in a field of characteristic zero, the previous result can be
strengthened.
*)

Variable R:CField.
(* begin show *)
Hypothesis H : (Char0 R).
(* end show *)
(* begin hide *)
Notation RX := (cpoly_cring R).
(* end hide *)

Lemma poly_apzero : forall f : RX, f [#] [0] -> {c : R | f ! c [#] [0]}.
Proof.
 intros f H0.
 elim (Cpoly_ex_degree _ f). intro n. intro H1. (* Set_ not necessary *)
 cut (distinct1 (fun i : nat => nring i:R)). intro H2.
  elim (Cpoly_choose_apzero _ (fun i : nat => nring i:R) H2 f n H1 H0).
  (* Set_ not necessary *)
  intro i. intros.
  exists (nring i:R).
  auto.
 unfold distinct1 in |- *.
 intros.
 apply nring_different; auto.
Qed.

(**
Also, in this situation polynomials are extensional functions.
*)

Lemma poly_extensional : forall p q : RX, (forall x, p ! x [=] q ! x) -> p [=] q.
Proof.
 intros p q H0.
 apply cg_inv_unique_2.
 apply not_ap_imp_eq. unfold Not in |- *. intros H1.
 elim (poly_apzero  (p[-]q)). intros x H2.
  cut ((p[-]q) ! x [=] [0]). intro.
   elim (eq_imp_not_ap _ _ _ H3 H2).
  astepl (p ! x[-]q ! x).
  Step_final (p ! x[-]p ! x).
 auto.
Qed.

End Characteristic_zero.

(**
** Polynomials are nonzero on any interval
*)

Section Poly_ApZero_Interval.

Variable R : COrdField.
(* begin hide *)
Notation RX := (cpoly_cring R).
(* end hide *)

Lemma Cpoly_apzero_interval : forall f : RX, f [#] [0] ->
 forall a b, a [<] b -> {c : R | a [<=] c /\ c [<=] b | f ! c [#] [0]}.
Proof.
 intros f H a b H0.
 assert (H1 := poly_degree_lth _ f).
 set (n := lth_of_poly f) in *.
 cut ([0] [<] (nring n:R)). intros H2.
  cut (nring n [#] ([0]:R)). intros H3.
   cut (distinct1 (fun i : nat => nring i[*]a[+] (nring n[-]nring i) [*]b[/] nring n[//]H3)).
    intro H4.
    elim (Cpoly_choose_apzero _ (fun i : nat => nring i[*]a[+] (nring n[-]nring i) [*]b[/] nring n[//]H3)
      H4 f n H1 H).
    intro i. intros H6 H7.
    exists (nring i[*]a[+] (nring n[-]nring i) [*]b[/] nring n[//]H3).
     split.
      apply shift_leEq_div.
       auto.
      rstepl (nring i[*]a[+] (nring n[-]nring i) [*]a).
      apply plus_resp_leEq_lft.
      apply mult_resp_leEq_lft.
       apply less_leEq. auto.
       apply shift_leEq_minus. astepl (nring (R:=R) i).
      apply nring_leEq.
      auto.
     apply shift_div_leEq.
      auto.
     rstepr (nring i[*]b[+] (nring n[-]nring i) [*]b).
     apply plus_resp_leEq.
     apply mult_resp_leEq_lft.
      apply less_leEq. auto.
      astepl (nring 0:R).
     apply nring_leEq.
     auto with arith.
    auto.
   unfold distinct1 in |- *.
   intros.
   unfold cf_div in |- *. apply mult_rht_resp_ap.
   apply zero_minus_apart.
    rstepl ((nring i[-]nring j) [*] (a[-]b)).
    apply mult_resp_ap_zero.
     apply minus_ap_zero.
     apply nring_apart. auto.
     apply minus_ap_zero.
    apply less_imp_ap.
    auto.
   apply f_rcpcl_resp_ap_zero.
  apply pos_ap_zero. auto.
  astepl (nring 0:R).
 apply nring_less.
 unfold n in |- *.
 generalize H; clear H1 H; case f.
  intro H; inversion H.
 intros; simpl in |- *.
 auto with arith.
Qed.

End Poly_ApZero_Interval.

Global Instance: forall {R: CRing} (n: nat), Proper (@st_eq _ ==> iff) (@degree_le R n).
Proof. split; apply degree_le_wd; [| symmetry]; assumption. Qed.

Section interpolation.

  Context {F: CField}.

  Definition interpolates (l: list (F * F)) (p: cpoly F): Prop :=
    forall xy, In xy l -> p ! (fst xy) [=] snd xy.

  Definition interpolates_economically (l: ne_list (F * F)) (p: cpoly F): Prop :=
    interpolates l p /\ degree_le (length (tl l)) p.

  Global Instance: Proper (@Permutation _ ==> @st_eq _ ==> iff) interpolates.
  Proof with auto.
   cut (forall x y: list (F * F), Permutation x y ->
    forall p q: cpoly F, p [=] q -> interpolates x p -> interpolates y q).
    split; apply H; auto; symmetry...
   unfold interpolates.
   intros ?? E ?? G ??.
   rewrite <- E, <- G...
  Qed.

  Global Instance: Proper (ne_list.Permutation ==> @st_eq _ ==> iff) interpolates_economically.
  Proof with auto.
   intros ?? E ?? U.
   unfold interpolates_economically.
   rewrite U.
   rewrite (ne_list.Permutation_ne_tl_length x y)...
   rewrite E.
   reflexivity.
  Qed.

  Lemma interpolation_unique (l: ne_list (F * F)): CNoDup (@cs_ap _) (map (@fst _ _) l) ->
    forall p q: cpoly F,
      interpolates_economically l p ->
      interpolates_economically l q ->
        p [=] q.
  Proof with auto with arith.
   intros ??? [A ?] [B ?].
   apply (identical_poly F (fun i => fst (nth i l ([0], [0]))) (length (tl l)))...
    repeat intro.
    rewrite <- map_nth.
    rewrite <- (map_nth (@fst _ _) l).
    simpl @fst.
    apply CNoDup_indexed...
      intros. apply ap_symmetric.
     rewrite map_length. rewrite <- ne_list.tl_length...
    rewrite map_length. rewrite <- ne_list.tl_length...
   intros.
   transitivity (snd (nth i l ([0], [0]))).
    apply A, nth_In... rewrite <- ne_list.tl_length...
   symmetry.
   apply B, nth_In... rewrite <- ne_list.tl_length...
  Qed.

End interpolation.