(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * Homomorphism.v : Module types of groups and special homomorphisms *)

Require Export PrimeLib.
Require Export Types.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope nat_scope.

(** A family of multiplicative abelian finite groups *)
Module Type GROUP.

 Parameter t : nat -> Type.

 (** The group is finite and non-empty *)
 Parameter elems : forall k, list (t k).
 (* TODO : this parameter is not needed (e is in the group) *)
 Parameter elems_not_nil : forall k, elems k <> nil.
 Parameter elems_full : forall k (x:t k), In x (elems k).
 Parameter elems_nodup : forall k, NoDup (elems k).

 (** Equality is decidable *)
 Parameter eqb : forall k, t k -> t k -> bool.
 Parameter eqb_spec : forall k (x y:t k), if eqb x y then x = y else x <> y.

 (** Identity element *)
 Parameter e : forall k, t k.

 (** Operations: product, inverse *)
 Parameter mul : forall k, t k -> t k -> t k.
 Parameter inv : forall k, t k -> t k.

 (** Specification *)
 Parameter mul_assoc : forall k (x y z:t k), mul x (mul y z) = mul (mul x y) z.
 Parameter mul_e_l : forall k (x:t k), mul (e k) x = x.
 Parameter mul_inv_l : forall k (x:t k), mul (inv x) x = e k.
 Parameter mul_comm : forall k (x y:t k), mul x y = mul y x.

 (* Power *)
 Fixpoint pow (k:nat) (x:t k) (n:nat) : t k :=
  match n with
  | O => e k
  | S n => mul x (pow x n)
  end.

 Fixpoint powZ (k:nat) (x:t k) (n:Z) {struct n}: t k :=
  match n with
  | Z0 => pow x 0
  | Zpos p => pow x (nat_of_P p)
  | Zneg p => inv (pow x (nat_of_P p))
  end.

 (* Cost *)
 Parameter order_poly : polynomial.

 Parameter order_size_nat : forall k,
  size_nat (length (elems k)) < peval order_poly k.

 Parameter cost_mul : forall k (x y:t k), nat.
 Parameter cost_pow : forall k (x:t k) (n:Z), nat.
 Parameter cost_inv : forall k (x:t k), nat.

 Parameter cost_mul_poly : polynomial.
 Parameter cost_pow_poly : polynomial.
 Parameter cost_inv_poly : polynomial.

 Parameter cost_mul_poly_spec : forall k (x y:t k),
  cost_mul x y <= peval cost_mul_poly k.

 Parameter cost_pow_poly_spec : forall k (x:t k) (n:Z),
  cost_pow x n <= peval cost_pow_poly k.

 Parameter cost_inv_poly_spec : forall k (x:t k),
  cost_inv x <= peval cost_inv_poly k.

End GROUP.

(** Module type for special homomorphisms *)
Module Type HOMOMORPHISM (G H:GROUP).

 Parameter phi : forall k, G.t k -> H.t k.

 Parameter cost_phi : forall k (x:G.t k), nat.

 Parameter cost_phi_poly : polynomial.

 Parameter cost_phi_poly_spec : forall k (x:G.t k),
  cost_phi x <= peval cost_phi_poly k.

 Parameter phi_homo : forall k (x y:G.t k),
  phi (G.mul x y) = H.mul (phi x) (phi y).

 (* [phi] is a special homomorphism *)
 Parameter special_v : nat -> Z.

 Parameter special_v_spec : forall k, special_v k <> 0%Z.

 Parameter special_v_poly : polynomial.

 Parameter size_nat_special_v : forall k,
  size_nat (Zabs_nat (special_v k)) <= peval special_v_poly k.

 Parameter cost_special_v : nat -> nat.

 Parameter cost_special_v_poly : polynomial.

 Parameter cost_special_v_poly_spec : forall k,
  cost_special_v k <= peval cost_special_v_poly k.

 Parameter special_u : forall k, H.t k -> G.t k.

 Parameter cost_special_u : forall k (x:H.t k), nat.

 Parameter cost_special_u_poly : polynomial.

 Parameter cost_special_u_poly_spec : forall k (x:H.t k),
  cost_special_u x <= peval cost_special_u_poly k.

 Parameter phi_special : forall k (x:H.t k),
  phi (special_u x) = H.powZ x (special_v k).

End HOMOMORPHISM.

(** Module type for the challenge set of a Sigma-phi protocol *)
Module Type CHALLENGE_SET (G H:GROUP) (HM:HOMOMORPHISM G H).

 (** Challenge set : {0,..,c+} *)
 Parameter cplus : nat -> nat.

 Parameter cplus_poly : polynomial.

 Parameter size_nat_cplus : forall k,
  size_nat (cplus k) <= peval cplus_poly k.

 Parameter cplus_spec : forall k p,
  prime p -> ( (p | HM.special_v k) -> Z_of_nat (cplus k) < p)%Z.

End CHALLENGE_SET.

(** * Derived properties of abelian groups *)
Module Group_Properties (G:GROUP).

 Import G.

 Lemma eqb_refl : forall k (x:t k), eqb x x.
 Proof.
  intros k x.
  generalize (eqb_spec x x).
  case (eqb x x); [ | intro H; elim H]; trivial.
 Qed.

 Lemma mul_pow_plus : forall k (x:t k) n m,
  mul (pow x n) (pow x m) = pow x (n + m).
 Proof.
  induction n; intros; simpl.
  simpl; apply mul_e_l.
  simpl; rewrite <- mul_assoc, IHn; trivial.
 Qed.

 Lemma cancellation : forall k (x y z:t k), mul x y = mul x z -> y = z.
 Proof.
  intros.
  rewrite <- (mul_e_l y), <- (mul_e_l z).
  rewrite <- (mul_inv_l x), <- mul_assoc, <- mul_assoc, H; trivial.
 Qed.

 Lemma mul_e_r : forall k (x:t k), mul x (e k) = x.
 Proof.
  intros; rewrite mul_comm, mul_e_l; trivial.
 Qed.

 Lemma mul_inv_r : forall k (x:t k), mul x (inv x) = e k.
 Proof.
  intros; rewrite mul_comm, mul_inv_l; trivial.
 Qed.

 Lemma inv_mul : forall k (a b : t k), inv (mul a b) = mul (inv a) (inv b).
 Proof.
  intros.
  apply cancellation with (mul a b).
  rewrite mul_inv_r, (mul_comm a b), <- mul_assoc.
  rewrite (mul_assoc a (inv a)), mul_inv_r, mul_e_l, mul_inv_r; trivial.
 Qed.

 Lemma inv_e : forall k, inv (e k) = e k.
 Proof.
  intros.
  apply cancellation with (e k).
  rewrite mul_inv_r, mul_e_l; trivial.
 Qed.

 Lemma inv_inv : forall k (x:t k), inv (inv x) = x.
 Proof.
  intros.
  apply cancellation with (inv x).
  rewrite mul_inv_l, <- inv_mul, mul_inv_r.
  apply inv_e.
 Qed.

 Lemma pow_e : forall k n, pow (e k) n = e k.
 Proof.
  induction n; intros; simpl.
  trivial.
  rewrite mul_e_l; trivial.
 Qed.

 Lemma pow_mul_distr : forall k (x y:t k) n,
  pow (mul x y) n = mul (pow x n) (pow y n).
 Proof.
  induction n; intros.
  simpl; rewrite mul_e_r; trivial.
  simpl; rewrite mul_assoc.
  rewrite (mul_comm x (pow x n)).
  rewrite <- (mul_assoc (pow x n)).
  rewrite (mul_comm (pow x n)).
  repeat rewrite <- mul_assoc.
  rewrite IHn; trivial.
 Qed.

 Lemma pow_pow : forall k (x:t k) n m, pow (pow x n) m = pow x (n * m).
 Proof.
  induction n; intros; simpl.
  rewrite pow_e; trivial.
  rewrite <- mul_pow_plus, <- IHn; apply pow_mul_distr.
 Qed.

 Lemma pow_inv : forall k (x:t k) n, pow (inv x) n = inv (pow x n).
 Proof.
  induction n; simpl.
  rewrite inv_e; trivial.
  rewrite IHn, inv_mul; trivial.
 Qed.

 Lemma pow_minus : forall k (x:t k) m n,
  n > m ->
  pow x (n - m) = mul (pow x n) (inv (pow x m)).
 Proof.
  intros.
  replace n with (m + (n - m)) by omega.
  rewrite <- mul_pow_plus, <- mul_assoc, mul_comm, <- mul_assoc.
  rewrite mul_inv_l, mul_e_r, minus_plus; trivial.
 Qed.

 Lemma mul_powZ_plus : forall k (x:t k) n m,
  mul (powZ x n) (powZ x m) = powZ x (n + m).
 Proof.
  intros.
  case n; intros; simpl.
   apply mul_e_l.
   case m; intros; simpl.
    apply mul_e_r.

    rewrite nat_of_P_plus_morphism; apply mul_pow_plus.

    case_eq ((p ?= p0)%positive Eq); intro H; simpl.
     apply Pcompare_Eq_eq in H; rewrite H; rewrite mul_inv_r; trivial.

     apply ZC2 in H.
     rewrite nat_of_P_minus_morphism; trivial.
     rewrite pow_minus, mul_comm, inv_mul, inv_inv; trivial.
     apply nat_of_P_gt_Gt_compare_morphism in H; trivial.

     rewrite nat_of_P_minus_morphism; trivial.
     rewrite pow_minus; trivial.
     apply nat_of_P_gt_Gt_compare_morphism in H; trivial.

   case m; intros; simpl.
    apply mul_e_r.

    case_eq ((p ?= p0)%positive Eq); intro H; simpl.
     apply Pcompare_Eq_eq in H; rewrite H; rewrite mul_inv_l; trivial.

     apply ZC2 in H.
     rewrite nat_of_P_minus_morphism; trivial.
     rewrite pow_minus, mul_comm; trivial.
     apply nat_of_P_gt_Gt_compare_morphism in H; trivial.

     rewrite nat_of_P_minus_morphism; trivial.
     rewrite pow_minus, inv_mul, inv_inv; trivial.
     apply nat_of_P_gt_Gt_compare_morphism in H; trivial.

   rewrite nat_of_P_plus_morphism.
   rewrite <- inv_mul, mul_pow_plus; trivial.
 Qed.

 Lemma powZ_e : forall k n, powZ (e k) n = e k.
 Proof.
  induction n; simpl.
  trivial.
  apply pow_e.
  rewrite pow_e, inv_e; trivial.
 Qed.

 Lemma powZ_mul_distr : forall k (x y:t k) n,
  powZ (mul x y) n = mul (powZ x n) (powZ y n).
 Proof.
  destruct n; intros.
  simpl; rewrite mul_e_r; trivial.
  apply pow_mul_distr.
  simpl.
  rewrite <- inv_mul, pow_mul_distr; trivial.
 Qed.

 Lemma powZ_powZ : forall k (x:t k) n m, powZ (powZ x n) m = powZ x (n * m).
 Proof.
  induction n; intros; simpl.
  apply powZ_e.
  case m; intros; simpl.
   trivial.
   rewrite pow_pow, nat_of_P_mult_morphism; trivial.
   rewrite pow_pow, nat_of_P_mult_morphism; trivial.
  case m; intros; simpl.
   trivial.
   rewrite pow_inv, pow_pow, nat_of_P_mult_morphism; trivial.
   rewrite pow_inv, pow_pow, inv_inv, nat_of_P_mult_morphism; trivial.
 Qed.

 Lemma powZ_pow : forall k (x:t k) n,
  powZ x (Z_of_nat n) = pow x n.
 Proof.
  induction n; simpl.
  trivial.
  rewrite nat_of_P_o_P_of_succ_nat_eq_succ; simpl; trivial.
 Qed.

 Lemma powZ_minus : forall k (x : t k) n,
   powZ x (- n) = inv (powZ x n).
 Proof.
   intros k x n;case n; simpl; trivial.
   rewrite inv_e; trivial.
   intro p; rewrite inv_inv; trivial.
 Qed.

End Group_Properties.

(** Derived properties of special homomorphisms *)
Module Homomorphism_Properties (G H:GROUP) (HM:HOMOMORPHISM G H).

 Module GP := Group_Properties G.
 Module HP := Group_Properties H.
 Export GP HP.
 Export HM.

 Lemma phi_e : forall k,
  phi (@G.e k) = H.e k.
 Proof.
  intros.
  apply HP.cancellation with (phi (G.e k)).
  rewrite <- phi_homo, G.mul_e_l, HP.mul_e_r; trivial.
 Qed.

 Lemma phi_inv : forall k (x:G.t k),
  phi (G.inv x) = H.inv (phi x).
 Proof.
  intros.
  apply HP.cancellation with (phi x).
  rewrite <- phi_homo, HP.mul_inv_r, GP.mul_inv_r.
  apply phi_e.
 Qed.

 Lemma phi_pow : forall k (x:G.t k) a,
  phi (G.pow x a) = H.pow (phi x) a.
 Proof.
  induction a; simpl.
  apply phi_e.
  rewrite <- IHa, phi_homo; trivial.
 Qed.

 Lemma phi_powZ : forall k (x:G.t k) a,
  phi (G.powZ x a) = H.powZ (phi x) a.
 Proof.
  induction a; simpl.
  apply phi_e.
  apply phi_pow.
  rewrite phi_inv, phi_pow; trivial.
 Qed.

End Homomorphism_Properties.

(** Direct product of two groups *)
Module Group_Prod (G1 G2:GROUP) <: GROUP.

 Definition t k := (G1.t k * G2.t k)%type.

 Definition elems k := list_prod (G1.elems k) (G2.elems k).

 Lemma elems_not_nil : forall k, elems k <> nil.
 Proof.
  unfold elems; intros k H.
  apply (f_equal (@length _)) in H.
  rewrite prod_length in H.
  destruct (mult_is_O _ _ H).
  apply (G1.elems_not_nil (length_nil _ H0)).
  apply (G2.elems_not_nil (length_nil _ H0)).
 Qed.

 Lemma elems_full : forall k (x:t k), In x (elems k).
 Proof.
  intros k x; unfold elems; elim x; intros a b.
  apply in_prod.
  exact (G1.elems_full a).
  exact (G2.elems_full b).
 Qed.

 Lemma elems_nodup : forall k, NoDup (elems k).
 Proof.
  intros k; unfold elems.
  apply NoDup_list_prod.
  exact (G1.elems_nodup k).
  exact (G2.elems_nodup k).
 Qed.

 Definition eqb k (x y:t k) : bool :=
  andb (G1.eqb (fst x) (fst y)) (G2.eqb (snd x) (snd y)).

 Lemma eqb_spec : forall k (x y: t k), if eqb  x y then x = y else x <> y.
 Proof.
  intros k (x1,y1) (x2,y2).
  unfold eqb; simpl.
  generalize (G1.eqb_spec x1 x2).
  generalize (G2.eqb_spec y1 y2).
  case (G1.eqb x1 x2); simpl.
  case (G2.eqb y1 y2); simpl.
  intros; subst; trivial.
  intros; injection; auto.
  intros; injection; auto.
 Qed.

 Definition e k := (G1.e k, G2.e k).

 Definition inv k (x:t k) := (G1.inv (fst x), G2.inv (snd x)).

 Definition mul k (x y:t k) := (G1.mul (fst x) (fst y), G2.mul (snd x) (snd y)).

 Lemma mul_assoc : forall k (x y z:t k), mul x (mul y z) = mul (mul x y) z.
 Proof.
  intros k x y z; unfold mul; simpl.
  rewrite G1.mul_assoc, G2.mul_assoc; trivial.
 Qed.

 Lemma mul_e_l : forall k (x:t k), mul (e k) x = x.
 Proof.
  destruct x.
  intros; unfold mul; rewrite G1.mul_e_l, G2.mul_e_l; trivial.
 Qed.

 Lemma mul_inv_l : forall k (x:t k), mul (inv x) x = e k.
 Proof.
  destruct x.
  intros; unfold mul; simpl; rewrite G1.mul_inv_l, G2.mul_inv_l; trivial.
 Qed.

 Lemma mul_comm : forall k (x y:t k), mul x y = mul y x.
 Proof.
  intros.
  unfold mul; rewrite G1.mul_comm, G2.mul_comm; trivial.
 Qed.

 Fixpoint pow (k:nat) (x:t k) (n:nat) : t k :=
  match n with
  | O => e k
  | S n => mul x (pow x n)
  end.

 Fixpoint powZ (k:nat) (x:t k) (n:Z) {struct n}: t k :=
  match n with
  | Z0 => pow x 0
  | Zpos p => pow x (nat_of_P p)
  | Zneg p => inv (pow x (nat_of_P p))
  end.

 Lemma pow_equiv: forall k (x:t k) n,
  pow x n = (G1.pow (fst x) n , G2.pow (snd x) n).
 Proof.
  induction n; simpl.
  trivial.
  rewrite IHn; trivial.
 Qed.

 Lemma powZ_equiv: forall k (x:t k) n,
  powZ x n = (G1.powZ (fst x) n , G2.powZ (snd x) n).
 Proof.
  destruct n; simpl.
  trivial.
  apply pow_equiv.
  rewrite pow_equiv; trivial.
 Qed.

 Definition order_poly := pplus G1.order_poly G2.order_poly.

 Lemma order_size_nat : forall k,
  size_nat (length (elems k)) < peval order_poly k.
 Proof.
  intros k; unfold order_poly, elems.
  rewrite pplus_spec, prod_length.
  apply le_lt_trans with
   (size_nat (length (G1.elems k)) + size_nat (length (G2.elems k))).
  apply size_nat_mult.
  apply plus_lt_compat.
  exact (G1.order_size_nat k).
  exact (G2.order_size_nat k).
 Qed.

 Definition cost_mul k (x y:t k) :=
  G1.cost_mul (fst x) (fst y) + G2.cost_mul (snd x) (snd y).

 Definition cost_pow k (x:t k) (n:Z) :=
  G1.cost_pow (fst x) n + G2.cost_pow (snd x) n.

 Definition cost_inv k (x:t k) :=
  G1.cost_inv (fst x) + G2.cost_inv (snd x).

 Definition cost_mul_poly := pplus G1.cost_mul_poly G2.cost_mul_poly.
 Definition cost_pow_poly := pplus G1.cost_pow_poly G2.cost_pow_poly.
 Definition cost_inv_poly := pplus G1.cost_inv_poly G2.cost_inv_poly.

 Lemma cost_mul_poly_spec : forall k (x y:t k),
  cost_mul x y <= peval cost_mul_poly k.
 Proof.
  intros k x y; unfold cost_mul, cost_mul_poly.
  rewrite pplus_spec.
  apply plus_le_compat.
  exact (G1.cost_mul_poly_spec (fst x) (fst y)).
  exact (G2.cost_mul_poly_spec (snd x) (snd y)).
 Qed.

 Lemma cost_pow_poly_spec : forall k (x:t k) (n:Z),
  cost_pow x n <= peval cost_pow_poly k.
 Proof.
  intros k x n; unfold cost_pow, cost_pow_poly.
  rewrite pplus_spec.
  apply plus_le_compat.
  exact (G1.cost_pow_poly_spec (fst x) n).
  exact (G2.cost_pow_poly_spec (snd x) n).
 Qed.

 Lemma cost_inv_poly_spec : forall k (x:t k),
  cost_inv x <= peval cost_inv_poly k.
 Proof.
  intros k x; unfold cost_inv, cost_inv_poly.
  rewrite pplus_spec.
  apply plus_le_compat.
  exact (G1.cost_inv_poly_spec (fst x)).
  exact (G2.cost_inv_poly_spec (snd x)).
 Qed.

End Group_Prod.

(** Direct product of two special homomorphisms *)
Module Homomorphism_Prod (G1 H1 G2 H2:GROUP)
 (HM1:HOMOMORPHISM G1 H1) (HM2:HOMOMORPHISM G2 H2).

 Module GG := Group_Prod G1 G2.
 Module HH := Group_Prod H1 H2.

 Module HP1 := Homomorphism_Properties G1 H1 HM1.
 Module HP2 := Homomorphism_Properties G2 H2 HM2.

 Definition phi k : GG.t k -> HH.t k :=
  fun a => let (x, y) := a in (HM1.phi x, HM2.phi y).

 Definition cost_phi k (x:GG.t k) := HM1.cost_phi (fst x) + HM2.cost_phi (snd x).

 Definition cost_phi_poly := pplus HM1.cost_phi_poly HM2.cost_phi_poly.

 Lemma cost_phi_poly_spec : forall k (x:GG.t k),
  cost_phi x <= peval cost_phi_poly k.
 Proof.
  intros k x; unfold cost_phi, cost_phi_poly.
  rewrite pplus_spec.
  apply plus_le_compat.
  exact (HM1.cost_phi_poly_spec (fst x)).
  exact (HM2.cost_phi_poly_spec (snd x)).
 Qed.

 Lemma phi_homo : forall k (x y:GG.t k),
  phi (GG.mul x y) = HH.mul (phi x) (phi y).
 Proof.
  destruct x; destruct y; simpl.
  rewrite HM1.phi_homo, HM2.phi_homo; trivial.
 Qed.

 (* [phi] is a special homomorphism *)
 Definition special_v k := Zlcm (HM1.special_v k) (HM2.special_v k).

 Lemma special_v_spec : forall k, special_v k <> 0%Z.
 Proof.
  intro k; apply Zlcm_neq_0.
  exact (@HM1.special_v_spec k).
  exact (@HM2.special_v_spec k).
 Qed.

 Definition special_v_poly := pplus HM1.special_v_poly HM2.special_v_poly.

 Lemma size_nat_special_v : forall k,
  size_nat (Zabs_nat (special_v k)) <= peval special_v_poly k.
 Proof.
  intro; unfold special_v, special_v_poly.
  rewrite pplus_spec.
  assert (H1:=HM1.size_nat_special_v k).
  assert (H2:=HM2.size_nat_special_v k).
  assert (H3:=@HM1.special_v_spec k).
  assert (H4:=@HM2.special_v_spec k).

  apply le_trans with
   (size_nat (Zabs_nat (Zabs ((HM1.special_v k) * (HM2.special_v k))))).
  apply size_nat_monotonic.
  apply Zabs_nat_le; split.
  apply Zlcm_is_pos.
  apply Zdivide_le.
  apply Zlcm_is_pos.
  apply Zle_lt.
  apply Zabs_neq_0.
  apply Zmult_neq_0; trivial.
  apply Zabs_pos.
  rewrite Zlcm_gcd.
  apply Zdivide_factor_l.

  rewrite Zabs_Zmult.
  rewrite Zabs_nat_mult.
  repeat rewrite Zabs_nat_Zabs.
  apply le_trans with
   (size_nat (Zabs_nat (HM1.special_v k)) + size_nat (Zabs_nat (HM2.special_v k))).
  apply size_nat_mult.
  apply plus_le_compat; trivial.
 Qed.

 Definition cost_special_v k := HM1.cost_special_v k + HM2.cost_special_v k.

 Definition cost_special_v_poly :=
  pplus HM1.cost_special_v_poly HM2.cost_special_v_poly .

 Lemma cost_special_v_poly_spec : forall k,
  cost_special_v k <= peval cost_special_v_poly k.
 Proof.
  intro; unfold cost_special_v, cost_special_v_poly.
  rewrite pplus_spec.
  apply plus_le_compat.
  exact (HM1.cost_special_v_poly_spec k).
  exact (HM2.cost_special_v_poly_spec k).
 Qed.

 Definition special_u k : HH.t k -> GG.t k :=
  fun x => let (x1, x2) := x in
   let v1 := HM1.special_v k in
   let v2 := HM2.special_v k in
   let v := special_v k in
   let y1 := G1.powZ (HM1.special_u x1) (v / v1) in
   let y2 := G2.powZ (HM2.special_u x2) (v / v2) in  (y1, y2).

 Definition cost_special_u k (x:HH.t k) :=
  HM1.cost_special_u (fst x) + HM2.cost_special_u (snd x).

 Definition cost_special_u_poly :=
  pplus HM1.cost_special_u_poly HM2.cost_special_u_poly.

 Lemma cost_special_u_poly_spec : forall k (x:HH.t k),
  cost_special_u x <= peval cost_special_u_poly k.
 Proof.
  intros; unfold cost_special_u, cost_special_u_poly.
  rewrite pplus_spec.
  apply plus_le_compat.
  exact (HM1.cost_special_u_poly_spec (fst x)).
  exact (HM2.cost_special_u_poly_spec (snd x)).
 Qed.

 Lemma phi_special : forall k (x:HH.t k),
  phi (special_u x) = HH.powZ x (special_v k).
 Proof.
  destruct x; simpl.
  rewrite HP1.phi_powZ, HP2.phi_powZ, HM1.phi_special, HM2.phi_special.
  rewrite HP1.HP.powZ_powZ, HP2.HP.powZ_powZ.
  rewrite <- Zdivide_Zdiv_eq_full, <- Zdivide_Zdiv_eq_full; trivial.
  rewrite HH.powZ_equiv; simpl; trivial.
  apply HM2.special_v_spec.
  apply Zlcm_div_r.
  apply HM1.special_v_spec.
  apply Zlcm_div_l.
 Qed.

End Homomorphism_Prod.

(** Largest challenge set for a Sigma-phi protocol *)
Module Largest_Challenge_Set (G H:GROUP) (HM:HOMOMORPHISM G H) : CHALLENGE_SET G H HM.

 Import HM.
 Open Scope Z_scope.

 Definition cplus k :=
  if Z_eq_dec (Zabs (special_v k)) 1
   then 1%nat
   else Zabs_nat (smallest_prime_divisor (Zabs (special_v k)) - 1).

 Definition cplus_poly := special_v_poly.

 Lemma size_nat_cplus : forall k,
  (size_nat (cplus k) <= peval cplus_poly k)%nat.
 Proof.
  intro k.
  eapply le_trans; [ | apply size_nat_special_v].
  apply size_nat_monotonic.

  assert (Hv:=@special_v_spec k).
  unfold cplus.
  case (Z_eq_dec (Zabs (special_v k)) 1); intro Heq.
  rewrite <- (Zabs_nat_Zabs (special_v k)), Heq; trivial.

  assert (H:1 < Zabs (special_v k)).
  apply Zabs_neq_0 in Hv.
  generalize (Zabs_pos (special_v k)); omega.

  destruct (smallest_prime_divisor_spec _ H) as [H0 [H1 _] ].
  set (p:=smallest_prime_divisor (Zabs (special_v k))) in *.
  assert (Hle:0 <= p) by (apply prime_ge_2 in H0; omega).

  unfold cplus; fold p.
  apply Zdivide_le in H1; [ | omega | omega].
  rewrite <- (Zabs_nat_Zabs (special_v k)).
  apply prime_ge_2 in H0.
  apply Zabs_nat_le; omega.
 Qed.

 Lemma cplus_spec : forall k p,
  prime p -> ( (p | special_v k) -> Z_of_nat (cplus k) < p)%Z.
 Proof.
  intros k p' H H0.
  assert (Hv:=@special_v_spec k).
  unfold cplus.
  case (Z_eq_dec (Zabs (special_v k)) 1); intro Heq.
  destruct (Zabs_spec (special_v k)) as [ [H1 H2] | [H1 H2] ].
  rewrite Heq in H2.
  rewrite <- H2 in H0.
  apply prime_ge_2 in H.
  apply Zdivide_le in H0; omega.

  rewrite Heq in H2.
  apply (f_equal Zopp) in H2.
  rewrite Zopp_involutive in H2.
  rewrite <- H2 in H0.
  apply Zdivide_opp_r_rev in H0.
  apply prime_ge_2 in H.
  apply Zdivide_le in H0; omega.

  assert (H1:1 < Zabs (special_v k)).
  apply Zabs_neq_0 in Hv.
  generalize (Zabs_pos (special_v k)); omega.

  unfold cplus.
  destruct (smallest_prime_divisor_spec _ H1).
  set (p:=smallest_prime_divisor (Zabs (special_v k))) in *.

  apply prime_ge_2 in H2.
  apply Zlt_le_trans with p.
  rewrite inj_Zabs_nat.
  rewrite Zabs_eq; omega.

  apply H3.
  trivial.
  apply Zdivide_trans with (special_v k); [trivial | apply Zabs_div].
 Qed.

End Largest_Challenge_Set.


Require Import IA.
Require Import parser.

Definition Prod:IA := parse
"IA [s0,s1,s2,s3,s4,s5] (s0) [name,ISBN,incdn,inus]
[cdnprice,usprice,author] []
[s0->(name)s1, s0->(ISBN)s1, s1->(inus)s2, s1->(incdn)s3,
s2->(usprice)s4, s3->(cdnprice)s4, s4->(author)s5]".

Definition Pay:IA := parse
"IA [s0,s1,s2,s3] (s0) [creditno,usprice,cdnprice]
[refno,errno] []
[s0->(cdnprice)s1, s1->(creditno)s2,
s2->(refno)s3, s2->(errno)s3]".

Definition GenPay:IA := parse
"IA [s0,s1,s2,s3] (s0) [creditno,usprice,cdnprice]
[refno,errno] []
[s0->(usprice)s1, s0->(cdnprice)s1, s1->(creditno)s2,
s2->(errno)s3, s2->(refno)s3]".

Definition c1: IA := IAutomaton.composition Prod GenPay.
Definition c2: IA := IAutomaton.composition Prod Pay.

Eval compute in :> c1.
Eval compute in :> c2.

Eval compute in IAutomaton.bRefine c2 c1.


(*Require Export IND_DEFINITIONS.*)
Load "IND_DEFINITIONS".

Fixpoint not_occurn_atdk_bool (n : nat )(t:Bool) : bool :=
 match t with
| Bvar n' => if (beq_nat n' n) then false else true
| FAlse => true
| TRue => true
| EQ_B  b1 b2 =>  andb (not_occurn_atdk_bool n b1)  (not_occurn_atdk_bool n b2)
| EQ_M t1 t2 => andb (not_occurn_atdk_msg n t1) ( not_occurn_atdk_msg n t2)
| if_then_else_B t1 t2 t3 => andb ( not_occurn_atdk_bool n t1)  (andb (not_occurn_atdk_bool n t2)(not_occurn_atdk_bool n t3) )
| EQL t1 t2 => andb (not_occurn_atdk_msg n t1) ( not_occurn_atdk_msg n t2)
 end
with not_occurn_atdk_msg (n : nat )(t:message) : bool :=
 match t with
| if_then_else_M b3 t1 t2 => andb (not_occurn_atdk_bool n b3) (andb (not_occurn_atdk_msg n  t1)( not_occurn_atdk_msg n t2))
| (Mvar n') => if (beq_nat n' n) then false else true
| O => true
| N n'=> if (beq_nat n' n) then false else true
|new => true
| exp t1 t2 t3 => andb ( not_occurn_atdk_msg n t1) (andb ( not_occurn_atdk_msg n t2) (not_occurn_atdk_msg n t3))
| pair t1 t2 => andb( not_occurn_atdk_msg n t1) ( not_occurn_atdk_msg n t2)
| pi1 t1 => ( not_occurn_atdk_msg n t1)
| pi2 t1 => ( not_occurn_atdk_msg n t1)
| ggen t1 => ( not_occurn_atdk_msg n t1)
| act t1 => ( not_occurn_atdk_msg n t1)
|r n' => if (beq_nat n' n) then false else true
| m t1 => ( not_occurn_atdk_msg n t1)
|enc t1 t2 t3 =>  andb ( not_occurn_atdk_msg n t1) (andb ( not_occurn_atdk_msg n t2) ( not_occurn_atdk_msg n t3))
|dec t1 t2 => ( not_occurn_atdk_msg n t2)
| k t1 => (not_occurn_atdk_msg n t1)
| pk t1 => ( not_occurn_atdk_msg n t1)
| sk t1 => ( not_occurn_atdk_msg n t1)
| nonce t1 => (not_occurn_atdk_msg n t1)
end.

Eval compute in (not_occurn_atdk_msg 1 (m (dec (N 1) (N 1)))).

Definition not_occurn_atdk_oursum (n :nat) (t:oursum) : bool :=
match t with
| msg t1 => (not_occurn_atdk_msg n t1 )
| bol t1 => (not_occurn_atdk_bool n t1 )
end.

Eval compute in (not_occurn_atdk_oursum 1 (msg (dec (N 1) O))).

Fixpoint not_occurn_atdk_mylist {m:nat} (n:nat) (ml:mylist m): bool :=

match ml with
| [] => true
| h :: t => (andb (not_occurn_atdk_oursum n h) (not_occurn_atdk_mylist n t))
end.

Eval compute in (not_occurn_atdk_mylist 1 [msg (dec (N 1) O)]).

Axiom Eq1:  forall (m:nat) (w : mylist m) (x:message), (add_elt_last_mylist  (bol (EQ_M x x)) w ) ~ (add_elt_last_mylist (bol TRue) w ).
Check [msg (N 1)].
Axiom encCCA1 : forall (n1 n2 n m  :nat)(u u1 u2:message)(v: mylist m), (Fresh [n1 ; n2] (v ++ [ msg u ; msg u1 ; msg u2 ; msg (pk (N n)) ;  msg (sk (N n))] ) = true) /\  (not_occurn_atdk_mylist n (v++ [ msg u ; msg u1 ; msg u2 ]) = true )->
(add_elt_last_mylist (msg (if_then_else_M (EQL u u1) (enc u (pk (N n)) (r n1)) u2))v) ~ (add_elt_last_mylist (msg (if_then_else_M (EQL u u1) (enc u1 (pk (N n)) (r n2)) u2)) v)  .

Axiom encKP: forall (n1 n2 n3 n4 :nat) (m:nat)(v: mylist m) (u:message), (Fresh [n1 ; n2] (v ++ [ msg u; msg (pk (N n3)) ; msg (sk (N n3)); msg (pk (N n4)) ; msg (sk (N n4))]) = true) /\ (not_occurn_atdk_mylist n3 (v++ [ msg u  ]) = true ) /\ (not_occurn_atdk_mylist n4 (v++ [ msg u  ]) = true )  ->
 (add_elt_last_mylist (msg (enc u (pk (N n3)) (r n1))) v) ~ (add_elt_last_mylist (msg (enc u (pk (N n4)) (r n2))) v).

Theorem comp_soundness: forall (n1 n2 n3: nat)(g: message -> message -> message -> message -> message), (msg (if_then_else_M (EQ_M (pi1  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) (nonce (N n1))) (pk (N n3)) (r 1))) (sk (N n3)))) (pk (N n1))) (if_then_else_M (EQL (pair (pi2  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) (nonce (N n1))) (pk (N n3)) (r 1))) (sk (N n3)))) (nonce (N 0))) (pair (nonce (N 0)) (nonce (N n3))))
(enc  (pair (pi2  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) (N n1)) (pk (N n3)) (r 1))) (sk (N n3)))) (nonce (N n3)) (pk (N n1)) (r 1)) (enc (pair (nonce 1)(nonce 1)) (pk (N n1)) (r 1)))
(enc (pair (nonce 1)(nonce 1)) (pk (N n1)) (r 1))))+++[msg (pk (N n1));msg (pk (N n2));msg (pk (N n3)); msg (enc (pair (pk (N n1)), N n1) (pk (N n3)) (r 1)) ]
 ~ (msg (if_then_else_M (EQ_M (pi1  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) N n1) (pk (N n3)) (r 1))) (sk (N n3)))) (pk (N n2))) (if_then_else_M (EQL (pair (pi2  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) N n1) (pk (N n3)) (r 1)))) (sk (N n3))) (nonce (N n3))) (pair (nonce N n3) (nonce N n3)))
(enc  (pair (pi2  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n2)) (enc (pair (pk (N n1)) N n1) (pk (N n3)) (r 1))) (sk (N n3)))) (nonce n3)) (pk (N n1)) (r 1)) (enc (pair (nonce 1)(nonce 1)) (pk (N n1)) (r 1)))
(enc (pair (nonce 1)(nonce 1)) (pk (N n1)) (r 1)))) +++ [msg (pk (N n1));msg (pk (N n2));msg (pk (N n3)); msg (enc (pair (pk (N n1)), N n1) (pk (N n3)) (r 1)) ]).

Theorem comp_soundness: forall (n1 n2 n3: nat)(g: message -> message -> message -> message -> message), (msg (if_then_else_M (EQ_M (pi1  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) (nonce (N n1))) (pk (N n3)) (r 1))) (sk (N n3)))) (pk (N n1))) (if_then_else_M (EQL (pair (pi2  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) (nonce (N n1))) (pk (N n3)) (r 1))) (sk (N n3)))) (nonce (N 0))) (pair (nonce (N 0)) (nonce (N 0)))) (enc (pair (pi2  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) (nonce (N n1))) (pk (N n3)) (r 1))) (sk (N n3)))) (nonce (N 0))) (pk (N n3)) (r 1)) (enc
 (nonce (N 0))) (pair (nonce (N 0)) (nonce (N n3))))
(enc  (pair (pi2  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) (N n1)) (pk (N n3)) (r 1))) (sk (N n3)))) (nonce (N n3)) (pk (N n1)) (r 1)) (enc (pair (nonce 1)(nonce 1)) (pk (N n1)) (r 1)))
(enc (pair (nonce 1)(nonce 1)) (pk (N n1)) (r 1))))+++[msg (pk (N n1));msg (pk (N n2));msg (pk (N n3)); msg (enc (pair (pk (N n1)), N n1) (pk (N n3)) (r 1)) ]
 ~ (msg (if_then_else_M (EQ_M (pi1  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) N n1) (pk (N n3)) (r 1))) (sk (N n3)))) (pk (N n2))) (if_then_else_M (EQL (pair (pi2  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n3)) (enc (pair (pk (N n1)) N n1) (pk (N n3)) (r 1)))) (sk (N n3))) (nonce (N n3))) (pair (nonce N n3) (nonce N n3)))
(enc  (pair (pi2  (dec (g (pk (N n1)) (pk (N n2))  (pk (N n2)) (enc (pair (pk (N n1)) N n1) (pk (N n3)) (r 1))) (sk (N n3)))) (nonce n3)) (pk (N n1)) (r 1)) (enc (pair (nonce 1)(nonce 1)) (pk (N n1)) (r 1)))
(enc (pair (nonce 1)(nonce 1)) (pk (N n1)) (r 1)))) +++ [msg (pk (N n1));msg (pk (N n2));msg (pk (N n3)); msg (enc (pair (pk (N n1)), N n1) (pk (N n3)) (r 1)) ]).


Require Import Reals Psatz Omega.
From Coq Require Export Sorted.
From iris.program_logic Require Export weakestpre prob_adequacy.
From iris.base_logic.lib Require Export invariants.
From iris.heap_lang Require Export lang adequacy.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac_auth auth gset gmap agree.
From iris.heap_lang Require Import proofmode notation par spin_lock.
From mathcomp Require Import seq fintype.
Set Default Proof Using "Type".

From iris.tests.skiplist Require Import code misc idxval spec_raw.
From discprob.idxval Require Import pidist_post_cond pidist_fin_singleton fin_extrema.
From discprob.idxval Require Import fin_ival fin_ival_dist.

Module Skiplist_Expected (Params: SKIPLIST_PARAMS).
  Import Params.
  Module Raw_spec := Skiplist_Raw_Spec Params.
  Import Raw_spec.

  Lemma cost_bounded1 l lt lb:
    NoDup l →
    pspec (skiplist l lt lb) (λ ls, length (fst ls) <= length l + length lt ∧
                                    length (snd ls) <= length l + length lb)%nat.
  Proof.
    intros HNoDup.
    rewrite skiplist_equiv_single; last first.
    { apply NoDup_ListNoDup; auto. }
    clear HNoDup.
    revert lt lb. induction l => lt lb.
    - rewrite //= singleton_mret. apply pspec_mret.
      rewrite //= -?Permuted_sort; split; try omega.
    - rewrite /single_skiplist -/single_skiplist singleton_bind.
      eapply pspec_mbind with (P := λ l, (length l <= length lt + 1)%nat).
      * rewrite singleton_plus ?singleton_mret.
        apply pspec_pidist_plus; apply pspec_mret; rewrite //=; omega.
      * intros lt' Hle. eapply pspec_conseq; first eapply IHl.
        intros (ls1&ls2) => //=.
        intros (?&?); split; omega.
  Qed.

  Local Open Scope nat_scope.

  Lemma cost_top_bounded_length l k:
    cost_top l k <= S (length l).
  Proof.
    induction l => //=.
    rewrite /cost_top //=.
    destruct Zbetween => //=; rewrite /cost_top in IHl; omega.
  Qed.

  Lemma cost_bottom_bounded_length lt l k:
    cost_bottom lt l k <= S (length l).
  Proof.
    induction l => //=.
    rewrite /cost_bottom //=.
    destruct Zbetween => //=; rewrite /cost_bottom in IHl; omega.
  Qed.

  Lemma cost_bounded2 l k:
    NoDup l →
    pspec (skiplist l [::] [::]) (λ ls, skip_cost (fst ls) (snd ls) k <= S (length l) + S (length l)).
  Proof.
    intros HNoDup.
    eapply pspec_conseq; first eapply cost_bounded1; eauto.
    intros (l1&l2) => //=. intros (Hle1&Hle2).
    rewrite /skip_cost/level2_cost.
    specialize (cost_top_bounded_length l1 k).
    specialize (cost_bottom_bounded_length l1 l2 k).
    destruct (decide _); omega.
  Qed.

  Import misc.
  Import monad.
  Import fin_ival_dist.

  Lemma top_remaining_large l l1 l2 k:
    (∀ x, In x l → x >= k)%Z →
    Ex_ivd (λ ls, INR (cost_top (fst ls) k)) (single_skiplist l l1 l2) = (INR (cost_top l1 k)).
  Proof.
    revert l1 l2.
    induction l => l1 l2.
    - intros. rewrite /single_skiplist/cost_top.
      rewrite {2}(Permuted_sort l1).
      apply: Ex_ival_mret.
    - intros Hin.
      rewrite /single_skiplist -/single_skiplist.
      setoid_rewrite ivd_plus_bind.
      setoid_rewrite Ex_ivd_ivdplus.
      rewrite ?ivd_left_id.
      rewrite IHl; last first.
      { intros. eapply Hin. by right. }
      rewrite IHl; last first.
      { intros. eapply Hin. by right. }
      rewrite {2}/cost_top/list_between.
      simpl filter. destruct Zbetween.
      { exfalso. cut (a >= k)%Z; first by omega.
        eapply Hin. by left.
      }
      rewrite //=/list_between//=. nra.
  Qed.

  Local Open Scope R.
  Lemma top_split_list l1 l2 lt lb k:
    (∀ x, In x l1 → INT_MIN < x < k)%Z →
    (∀ x, In x l2 → x >= k)%Z →
    Ex_ivd (λ ls, INR (cost_top (fst ls) k)) (single_skiplist (l1 ++ l2) lt lb)
    = (INR (cost_top lt k) + INR (length l1) / 2)%R.
  Proof.
    revert lt lb.
    induction l1 => lt lb Hle Hge.
    - rewrite top_remaining_large //=; field.
    - rewrite cat_cons. rewrite /single_skiplist -/single_skiplist.
      setoid_rewrite ivd_plus_bind.
      setoid_rewrite Ex_ivd_ivdplus.
      rewrite ?ivd_left_id.
      rewrite IHl1; last first.
      { intros. eapply Hge. auto. }
      { intros. eapply Hle. by right. }
      rewrite IHl1; last first.
      { intros. eapply Hge. auto. }
      { intros. eapply Hle. by right. }
      rewrite {2}/cost_top/list_between.
      simpl filter. destruct Zbetween; last first.
      { exfalso. cut (INT_MIN < a < k)%Z; first by omega.
        eapply Hle. by left.
      }
      rewrite /cost_top. rewrite S_INR.
      rewrite S_INR. simpl length. rewrite ?S_INR.
      rewrite //=/list_between//=. ring_simplify. nra.
  Qed.

  Lemma list_between_split l k1 k2:
    ∃ l1 l2, Permutation l (l1 ++ list_between l k1 k2 ++ l2) ∧
             (∀ x, In x l1 → x <= k1)%Z ∧ (∀ x, In x l2 → x >= k2)%Z.
  Proof.
    induction l.
    - exists [::], [::] => //=.
    - destruct IHl as (l1&l2&Hperm&Hl&Hg).
      simpl list_between. destruct Zbetween as [|Hngt].
      * exists l1, l2; split; auto.
        rewrite {1}Hperm.
        rewrite app_cat. rewrite Permutation_app_comm.
        rewrite app_comm_cons.
        rewrite Permutation_app_comm.
        rewrite app_comm_cons. done.
      * assert (a <= k1 ∨ a >= k2)%Z as [Hle|Hge] by omega.
        ** exists (a :: l1), l2.
           split_and!; eauto.
           *** rewrite {1}Hperm //=.
           *** intros ? [[]|]; eauto; try omega.
        ** exists l1, (a :: l2).
           split_and!; eauto.
           *** rewrite {1}Hperm //=.
               rewrite app_cat. rewrite app_assoc Permutation_app_comm.
               rewrite app_comm_cons. rewrite Permutation_app_comm -app_assoc //=.
           *** intros ? [[]|]; eauto; try omega.
  Qed.

  Lemma list_between_In_inv1 l k1 k2:
    (∀ x, In x (list_between l k1 k2) → k1 < x ∧ x < k2)%Z.
  Proof.
    induction l => //=.
    intros x. destruct Zbetween; eauto.
    intros [[]|Hin]; auto.
  Qed.

  Lemma list_between_In l k1 k2:
    (∀ x, In x l → k1 < x → x < k2 → In x (list_between l k1 k2))%Z.
  Proof.
    induction l => //=.
    intros x [[]|Hin]; destruct Zbetween; eauto; intros; try omega.
    * by left.
    * right. eapply IHl; eauto.
  Qed.

  Lemma Ex_cost_top l k:
    (∀ x, In x l → INT_MIN < x < INT_MAX)%Z →
    Ex_ivd (λ ls, INR (cost_top (fst ls) k)) (single_skiplist l [::] [::])
    = 1 + INR (length (list_between l INT_MIN k)) / 2.
  Proof.
    intros Hin.
    edestruct (list_between_split l INT_MIN k) as (l1&l2&Hperm&Hl1&Hg2).
    assert (l1 = [::]).
    {  destruct l1 as [| z l1]; auto. exfalso. cut (INT_MIN < z ∧ z <= INT_MIN)%Z; first by omega.
       split.
       * eapply Hin. rewrite Hperm. apply in_app_iff.
         do 2 left => //=.
       * apply Hl1. by left.
    }
    subst. rewrite //= in Hperm. rewrite {1}Hperm.
    rewrite top_split_list //=.
    intros x Hin'. eapply list_between_In_inv1; eauto.
  Qed.

  Global Instance ret_top_perm_Proper:
    Proper (Permutation ==> eq ==> eq) ret_top.
  Proof.
    intros l1 l2 Hperm k ? <-.
    rewrite /ret_top.
    rewrite Hperm //=.
  Qed.

  Lemma cost_bottom_cons1 l1 l2 a k:
    (INT_MIN < a)%Z →
    (a >= k ∨ (∃ i', In i' l1 ∧ a <= i' < k))%Z →
    cost_bottom l1 (a :: l2) k = cost_bottom l1 l2 k.
  Proof.
    intros Hmin.
    induction l1 as [| a' l1'].
    - rewrite //=/cost_bottom. intros [Hge|Hcase].
      * simpl list_between => //=. destruct Zbetween.
        ** omega.
        ** done.
      * firstorder.
    - rewrite /cost_bottom. intros [Hge|Hcase].
      * simpl list_between => //=. destruct Zbetween.
        ** omega.
        ** done.
      * simpl list_between => //=. destruct Zbetween as [Hb|Hnb].
        ** exfalso.  destruct Hb as (Hret&?).
           destruct Hcase as (i'&Hin&?&?).
           cut (i' <= ret_top (a' :: l1') k)%Z; first by omega.
           rewrite /ret_top.
           apply seq_ext.fold_left_Zmax_ub.
           apply list_between_In; eauto.
           omega.
        ** done.
  Qed.

  Lemma ret_top_cons1 l a k:
    (a >= k)%Z →
    ret_top (a :: l) k = ret_top l k.
  Proof.
    intros Hge.
    rewrite /ret_top. simpl list_between. destruct Zbetween; try omega.
  Qed.

  Lemma ret_top_cons2 l a k:
    (∃ i', In i' l ∧ a <= i' < k)%Z →
    ret_top (a :: l) k = ret_top l k.
  Proof.
    intros Hge.
    rewrite /ret_top. simpl list_between. destruct Hge as (i'&Hin&?&?).
    destruct Zbetween; try omega.
    apply Z.le_antisymm.
    * apply seq_ext.fold_left_Zle_max_lub.
      ** intros r' Hin'.
         destruct Hin' as [[]|Hin'].
         *** transitivity i'; auto. apply seq_ext.fold_left_Zmax_ub.
             apply list_between_In; auto; omega.
         *** apply seq_ext.fold_left_Zmax_ub; auto.
      ** apply seq_ext.fold_left_Zmax_init.
    * apply seq_ext.fold_left_Zmax_cons.
  Qed.

  Lemma cost_bottom_cons2 l1 l2 a k:
    (INT_MIN < a)%Z →
    (a >= k ∨ (∃ i', In i' l1 ∧ a <= i' < k))%Z →
    cost_bottom (a :: l1) (a :: l2) k = cost_bottom l1 l2 k.
  Proof.
    intros Hmin.
    induction l1 as [| a' l1'].
    - rewrite //=/cost_bottom. intros [Hge|Hcase].
      * simpl list_between => //=. destruct Zbetween as [|Hnzb].
        ** omega.
        ** rewrite ret_top_cons1 //=.
      * firstorder.
    - rewrite /cost_bottom. intros [Hge|Hcase].
      * simpl list_between => //=. destruct Zbetween as [|Hnzb].
        ** omega.
        ** rewrite ret_top_cons1 //=.
      * simpl list_between => //=. destruct Zbetween as [Hb|Hnb].
        ** exfalso.  destruct Hb as (Hret&?).
           destruct Hcase as (i'&Hin&?&?).
           cut (i' <= ret_top (a :: a' :: l1') k)%Z; first by omega.
           rewrite /ret_top.
           apply seq_ext.fold_left_Zmax_ub.
           apply list_between_In; eauto.
           *** right. done.
           *** omega.
        ** rewrite ret_top_cons2 //=.
  Qed.

  Lemma bottom_remaining_large l l1 l2 k:
    (∀ x, In x l → INT_MIN < x < INT_MAX)%Z →
    (∀ x, In x l → x >= k ∨ (∃ i', In i' l1 ∧ x <= i' < k))%Z →
    Ex_ivd (λ ls, INR (cost_bottom (fst ls) (snd ls) k))
           (single_skiplist l l1 l2) = (INR (cost_bottom l1 l2 k)).
  Proof.
    revert l1 l2.
    induction l => l1 l2.
    - intros. rewrite /single_skiplist/cost_bottom.
      rewrite {2}(Permuted_sort l1).
      rewrite {2}(Permuted_sort l2).
      apply: Ex_ival_mret.
    - intros Hin1 Hin2.
      rewrite /single_skiplist -/single_skiplist.
      setoid_rewrite ivd_plus_bind.
      setoid_rewrite Ex_ivd_ivdplus.
      rewrite ?ivd_left_id.
      rewrite IHl; last first.
      { intros. eapply Hin2. by right. }
      { intros. eapply Hin1; by right. }
      rewrite IHl; last first.
      { intros. destruct (Hin2 x) as [|Hin']; first by right.
        * auto.
        * right. destruct Hin' as (i'&?&?&?). exists i'; split; auto. by right.
      }
      { intros; eapply Hin1; by right. }
      rewrite cost_bottom_cons1; last first.
      { eapply Hin2. by left. }
      { eapply Hin1. by left. }
      rewrite cost_bottom_cons2; last first.
      { eapply Hin2. by left. }
      { eapply Hin1. by left. }
      nra.
  Qed.

  Import countable.
  Import Series Hierarchy.

  Lemma ret_top_single a k:
    (INT_MIN < a < k)%Z →
    ret_top [:: a] k = a.
  Proof.
    intros (?&?). rewrite /ret_top//=.
    destruct Zbetween; last omega.
    rewrite /fold_left//=. rewrite Z.max_r //=. omega.
  Qed.

  Lemma bottom_split_list l1 l2 lb k:
    (k < INT_MAX)%Z →
    (∀ x, In x l1 → INT_MIN < x < k)%Z →
    (∀ x, In x l2 → x >= k ∧ INT_MIN < x < INT_MAX)%Z →
    (∀ x, In x l1 → ∀ x', In x' lb → x < x')%Z →
    (∀ x, In x lb → INT_MIN < x < k)%Z →
    StronglySorted Zgt l1 →
    Ex_ivd (λ ls, INR (cost_bottom (fst ls) (snd ls) k)) (single_skiplist (l1 ++ l2) [::] lb)
    = INR (length lb) + sum_n (fun i => (/2)^i) (length l1).
  Proof.
    revert lb. induction l1 => lb Hk Hl1_range Hl2_range Hl1_lb Hlb Hsort.
    - simpl single_skiplist. rewrite bottom_remaining_large; last first.
      { intros. left.  eapply Hl2_range. auto. }
      { intros. eapply Hl2_range. auto. }
      rewrite S_INR.
      rewrite /cost_bottom/ret_top//=.
      rewrite sum_O.
      replace (/2^0) with 1 by field.
      repeat f_equal.
      apply list_between_all_in_range; eauto.
    - rewrite cat_cons.
      rewrite /single_skiplist -/single_skiplist.
      setoid_rewrite ivd_plus_bind.
      setoid_rewrite Ex_ivd_ivdplus.
      rewrite ?ivd_left_id.
      rewrite IHl1; last first; eauto.
      { apply StronglySorted_inv in Hsort; intuition. }
      { intros x [[]|Hin]; eauto.
        eapply Hl1_range; by left. }
      { intros x Hin x' [[]|Hin']; eauto.
        ** apply StronglySorted_inv in Hsort as (?&Hsort).
           rewrite Forall_forall in Hsort * => Hsort.
           cut (a > x)%Z; first by omega.
           eapply Hsort. apply elem_of_list_In; eauto.
        ** eapply Hl1_lb; eauto. by right. }
      { intros. eapply Hl1_range; by right. }
      simpl length. rewrite S_INR.
      rewrite bottom_remaining_large; last first.
      { intros x. rewrite in_app_iff. intros [Hin1|Hin2].
         * right. eexists; split; first by left.
           split.
           ** apply StronglySorted_inv in Hsort as (?&Hsort).
              rewrite Forall_forall in Hsort * => Hsort.
              cut (a > x)%Z; first by omega.
              eapply Hsort. apply elem_of_list_In; eauto.
           ** eapply Hl1_range; by left.
         * left. eapply Hl2_range; auto.
       }
      { intros x. rewrite in_app_iff. intros [Hin1|Hin2].
        * feed pose proof (Hl1_range x); first by right.
          omega.
        * eapply Hl2_range; auto.
      }
      rewrite /cost_bottom.
      rewrite ret_top_single; last first.
      { apply Hl1_range. by left. }
      simpl list_between.
      destruct Zbetween; first omega.
      rewrite list_between_all_in_range; last first.
      { intros i Hin; split.
        * apply Hl1_lb; auto; by left.
        * apply Hlb; auto.
      }
      rewrite S_INR.
      ring_simplify.
      feed pose proof (sum_n_mult_l (1/2) (λ i, (/2) ^ i) (length l1)) as Hscal.
      rewrite /mult//= in Hscal.
      rewrite -Hscal.
      rewrite /sum_n.
      feed pose proof (sum_n_m_S (λ a, (/2)^a) 0 (length l1)) as Hshift.
      rewrite [a in a + _ + _ = _](sum_n_m_ext _ (λ a, (/2) ^ S a)); last first.
      { intros n'. rewrite //=. field. }
      rewrite Hshift.
      replace 1 with ((/2)^O); last by (rewrite //=; field).
      rewrite Rplus_assoc. rewrite Rplus_comm Rplus_assoc.
      f_equal.
  Qed.

  Lemma Ex_cost_bottom l k:
    NoDup l →
    (k < INT_MAX)%Z →
    (∀ x, In x l → INT_MIN < x < INT_MAX)%Z →
    Ex_ivd (λ ls, INR (cost_bottom (fst ls) (snd ls) k)) (single_skiplist l [::] [::])
    = 2 * (1 - (/2) ^ S (length (list_between l INT_MIN k))).
  Proof.
    intros HNoDup Hk Hin.
    edestruct (list_between_split l INT_MIN k) as (l1&l2&Hperm&Hl1&Hg2).
    assert (l1 = [::]).
    {  destruct l1 as [| z l1]; auto. exfalso. cut (INT_MIN < z ∧ z <= INT_MIN)%Z; first by omega.
       split.
       * eapply Hin. rewrite Hperm. apply in_app_iff.
         do 2 left => //=.
       * apply Hl1. by left.
    }
    subst. rewrite //= in Hperm. rewrite {1}Hperm.
    rewrite (ZSortGe.Permuted_sort (list_between l INT_MIN k)).
    rewrite bottom_split_list; last first.
    { apply Sorted_StronglySorted; first eauto with *.
      apply Sorted_Zge_NoDup_Zgt.
      * apply Sorted_ZorderGe_Zge, Sorted_sort_ge_folded.
      * rewrite -ZSortGe.Permuted_sort.
        rewrite /list_between.
        rewrite -filter_ssr_filter.
        apply NoDup_filter; auto.
    }
    { intros ? []. }
    { intros ? ? ? []. }
    { intros; split; eauto. eapply Hin.
      rewrite Hperm. apply in_app_iff. by right. }
    { intros x. rewrite -ZSortGe.Permuted_sort.
      apply list_between_In_inv1. }
    { auto. }
    simpl length. replace (INR 0) with 0 by auto. rewrite Rplus_0_l.
    rewrite sum_n_Reals tech3; last by nra.
    field.
  Qed.

  Lemma Ex_level2_cost l k:
    NoDup l →
    (k < INT_MAX)%Z →
    (∀ x, In x l → INT_MIN < x < INT_MAX)%Z →
    Ex_ivd (λ ls, INR (level2_cost (fst ls) (snd ls) k)) (single_skiplist l [::] [::])
                  = 1 + INR (length (list_between l INT_MIN k)) / 2 +
                    2 * (1 - (/2) ^ S (length (list_between l INT_MIN k))).
  Proof.
    intros.
    rewrite /level2_cost. setoid_rewrite plus_INR.
    rewrite Ex_ivd_sum.
    rewrite Ex_cost_top //= Ex_cost_bottom //=.
  Qed.

  Lemma Ex_skip_cost l k:
    NoDup l →
    (k < INT_MAX)%Z →
    (∀ x, In x l → INT_MIN < x < INT_MAX)%Z →
    Ex_ivd (λ ls, INR (skip_cost (fst ls) (snd ls) k)) (single_skiplist l [::] [::])
                  <= 1 + INR (length (list_between l INT_MIN k)) / 2 +
                    2 * (1 - (/2) ^ S (length (list_between l INT_MIN k))).
  Proof.
    intros. rewrite -Ex_level2_cost //.
    apply Ex_ival_mono. intros (lt&lb).
    apply le_INR. rewrite /skip_cost/level2_cost.
    destruct (decide _); omega.
  Qed.

  Lemma skiplist_ex_Ex (Skeys: gset Z) k:
    extrema.ex_Ex_extrema (λ ls, INR (skip_cost (fst ls) (snd ls) k))
                          (skiplist (elements Skeys) [::] [::]).
  Proof.
    apply extrema.ex_Ex_extrema_bounded_supp_fun.
    apply pspec_bounded. exists (INR (S (length (elements Skeys)) + S (length (elements Skeys)))).
    eapply pspec_conseq; first eapply (cost_bounded2 (elements Skeys) k).
    { eapply NoDup_elements. }
    intros (ls1&ls2). rewrite Rabs_right; last apply Rle_ge, pos_INR.
    intros Hle. apply le_INR. auto.
  Qed.

  Import Rbar.
  Lemma Rbar_le_finite (x y: R) :
    Rbar_le x y → x <= y.
  Proof. rewrite //=. Qed.

  Lemma skiplist_Ex_max (Skeys: gset Z) k:
    (k < INT_MAX)%Z →
    (∀ x, x ∈ Skeys → INT_MIN < x < INT_MAX)%Z →
    Rbar_le (extrema.Ex_max (λ ls, INR (skip_cost (fst ls) (snd ls) k))
                            (skiplist (elements Skeys) [::] [::]))
            (Rbar.Finite (1 + INR (length (list_between (elements Skeys) INT_MIN k)) / 2 +
                 2 * (1 - (/2) ^ S (length (list_between (elements Skeys) INT_MIN k))))).
  Proof.
    intros Hk Hin.
    rewrite skiplist_equiv_single; last first.
    { apply NoDup_ListNoDup, NoDup_elements. }
    rewrite Ex_max_singleton.
    rewrite //=.
    apply Ex_skip_cost.
    * apply NoDup_elements.
    * auto.
    * intros x ?%elem_of_list_In. eapply Hin.
      apply elem_of_elements; auto.
  Qed.

End Skiplist_Expected.


Require Export aes.spec_utils_LL.
Require Export aes.tablesLL.
Local Open Scope Z.

Definition mbed_tls_fround_col (col0 col1 col2 col3 : int) (rk : Z) : int :=
  (Int.xor (Int.xor (Int.xor (Int.xor (Int.repr rk)
    (Znth (byte0 col0) FT0))
    (Znth (byte1 col1) FT1))
    (Znth (byte2 col2) FT2))
    (Znth (byte3 col3) FT3)).

Definition mbed_tls_final_fround_col (col0 col1 col2 col3 : int) (rk : Z) : int :=
  (Int.xor (Int.xor (Int.xor (Int.xor (Int.repr rk)
             (Znth (byte0 col0) FSb)              )
    (Int.shl (Znth (byte1 col1) FSb) (Int.repr 8)))
    (Int.shl (Znth (byte2 col2) FSb) (Int.repr 16)))
    (Int.shl (Znth (byte3 col3) FSb) (Int.repr 24))).

Definition four_ints := (int * (int * (int * int)))%type.

Definition col (i : Z) (s : four_ints) : int := match i with
| 0 => fst s
| 1 => fst (snd s)
| 2 => fst (snd (snd s))
| 3 => snd (snd (snd s))
| _ => Int.zero (* should not happen *)
end.

Lemma split_four_ints: forall (S: four_ints),
  S = (col 0 S, (col 1 S, (col 2 S, col 3 S))).
Proof.
  intros. destruct S as [c1 [c2 [c3 c4]]]. reflexivity.
Qed.

Lemma split_four_ints_eq: forall S c0 c1 c2 c3,
  S = (c0, (c1, (c2, c3))) -> c0 = col 0 S /\ c1 = col 1 S /\ c2 = col 2 S /\ c3 = col 3 S.
Proof.
  intros. destruct S as [d0 [d1 [d2 d3]]]. inversion H. auto.
Qed.

Definition mbed_tls_initial_add_round_key_col (col_id : Z) (plaintext : list Z) (rks : list Z) :=
  Int.xor (get_uint32_le plaintext (col_id * 4)) (Int.repr (Znth col_id rks)).

Definition mbed_tls_fround (cols : four_ints) (rks : list Z) (i : Z) : four_ints :=
match cols with (col0, (col1, (col2, col3))) =>
  ((mbed_tls_fround_col col0 col1 col2 col3 (Znth  i    rks)),
  ((mbed_tls_fround_col col1 col2 col3 col0 (Znth (i+1) rks)),
  ((mbed_tls_fround_col col2 col3 col0 col1 (Znth (i+2) rks)),
   (mbed_tls_fround_col col3 col0 col1 col2 (Znth (i+3) rks)))))
end.

Definition mbed_tls_final_fround (cols : four_ints) (rks : list Z) (i : Z) : four_ints :=
match cols with (col0, (col1, (col2, col3))) =>
  ((mbed_tls_final_fround_col col0 col1 col2 col3 (Znth  i    rks)),
  ((mbed_tls_final_fround_col col1 col2 col3 col0 (Znth (i+1) rks)),
  ((mbed_tls_final_fround_col col2 col3 col0 col1 (Znth (i+2) rks)),
   (mbed_tls_final_fround_col col3 col0 col1 col2 (Znth (i+3) rks)))))
end.

Fixpoint mbed_tls_enc_rounds (n : nat) (state : four_ints) (rks : list Z) (i : Z) : four_ints :=
match n with
| O => state
| S m => mbed_tls_fround (mbed_tls_enc_rounds m state rks i) rks (i+4*Z.of_nat m)
end.

(* plaintext: array of bytes
   rks: expanded round keys, array of Int32 *)
Definition mbed_tls_initial_add_round_key (plaintext : list Z) (rks : list Z) : four_ints :=
((mbed_tls_initial_add_round_key_col 0 plaintext rks),
((mbed_tls_initial_add_round_key_col 1 plaintext rks),
((mbed_tls_initial_add_round_key_col 2 plaintext rks),
((mbed_tls_initial_add_round_key_col 3 plaintext rks))))).

Definition output_four_ints_as_bytes (s : four_ints) :=
  (put_uint32_le (col 0 s)) ++
  (put_uint32_le (col 1 s)) ++
  (put_uint32_le (col 2 s)) ++
  (put_uint32_le (col 3 s)).

Definition mbed_tls_aes_enc (plaintext : list Z) (rks : list Z) : list int :=
  let state0  := mbed_tls_initial_add_round_key plaintext rks in
  let state13 := mbed_tls_enc_rounds 13 state0 rks 4 in
  let state14 := mbed_tls_final_fround state13 rks 56 in
  output_four_ints_as_bytes state14.


(**************************************************************************)
(**   Mechanised Framework for Local Interactions & Distributed Algorithms

   T. Balabonski, P. Courtieu, L. Rieg, X. Urbain

   PACTOLE project

   This file is distributed under the terms of the CeCILL-C licence
                                                                        *)
(**************************************************************************)

Require Import Bool.
Require Import Arith.Div2.
Require Import Lia Field.
Require Import Rbase Rbasic_fun R_sqrt Rtrigo_def.
Require Import List.
Require Import SetoidList.
Require Import Relations.
Require Import RelationPairs.
Require Import Morphisms.
Require Import Psatz.
Require Import Inverse_Image.
Require Import Pactole.Setting.
Require Import Pactole.Models.Flexible.
Require Import Pactole.Models.NoByzantine.
Require Import Pactole.Observations.MultisetObservation.
Require Import Pactole.Spaces.R2.
Require Import Pactole.CaseStudies.Gathering.WithMultiplicity.
Require Import Pactole.CaseStudies.Gathering.Definitions.

Import Permutation.
Set Implicit Arguments.
Typeclasses eauto := (bfs) 10.

(** *  The Gathering Problem  **)

(** Vocabulary: we call a [location] the coordinates of a robot.
    We call a [configuration] a function from robots to configuration.
    An [execution] is an infinite (coinductive) stream of [configuration]s.
    A [demon] is an infinite stream of [demonic_action]s. *)

(** **  Framework of the correctness proof: a finite set with at least two elements  **)
Section GatheringInR2.

Variable n : nat.
Hypothesis size_G : (2 <= n)%nat.

(** There are n good robots and no byzantine ones. *)
Instance MyRobots : Names := Robots n 0.
Instance NoByz : NoByzantine.
Proof using . now split. Qed.

Instance Loc : Location := make_Location R2.
Instance Loc_VS : @RealVectorSpace location location_Setoid location_EqDec := R2_VS.
Instance Loc_ES : @EuclideanSpace location location_Setoid location_EqDec Loc_VS := R2_ES.
Remove Hints R2_EqDec : typeclass_instances.

(* Refolding typeclass instances *)
Ltac changeR2 :=
  change R2 with location in *;
  change R2_Setoid with location_Setoid in *;
  change state_Setoid with location_Setoid in *;
  change R2_EqDec with location_EqDec in *;
  change state_EqDec with location_EqDec in *;
  change R2_VS with Loc_VS in *;
  change R2_ES with Loc_ES in *.

(** We are in a flexible formalism with no other info than the location,
    so the demon only chooses the move ratio. *)
Instance Info : State location := OnlyLocation (fun _ => True).
Instance FlexChoice : update_choice ratio := Flexible.OnlyFlexible.
(* NB: The inactive instance actually does not matter since we are in a FSYNC setting,
       so we could instead leave it as a parameter. *)
Instance InactiveChoice : inactive_choice unit := NoChoiceIna.

(** The robots choose the path they want to follow to a target. *)
Instance Robot : robot_choice (path location) := { robot_choice_Setoid := path_Setoid location }.

(** In a flexible setting, the minimum distance that robots are allowed to move is delta. *)
Variable delta : R.

Lemma inactive_proper : Proper (equiv ==> eq ==> equiv ==> equiv)
  (fun (config : configuration) (id : ident) (_ : unit) => config id).
Proof using . repeat intro; subst; auto. Qed.

Instance UpdFun : update_function (path location) (Similarity.similarity location) ratio :=
  FlexibleUpdate delta.

Instance InaFun : inactive_function unit := NoChoiceInaFun.

(* Trying to avoid notation problem with implicit arguments *)
Notation "!! config" := (@obs_from_config _ _ Info MyRobots multiset_observation config origin) (at level 1).
Notation "x == y" := (equiv x y).
Notation observation := (@observation location Loc Info MyRobots multiset_observation).
Notation robogram := (@robogram location Loc Info MyRobots multiset_observation).
Notation configuration := (@configuration Loc location Info MyRobots).
Notation config_list := (@config_list Loc location Info MyRobots).
Notation round := (@round location Loc Info MyRobots multiset_observation _ _ _ _ _).
Notation execution := (@execution location Loc Info MyRobots).
Notation Madd := (MMultisetInterface.add).

Implicit Type config : configuration.
Implicit Type da : similarity_da.
Implicit Type d : similarity_demon.
Arguments origin : simpl never.
Arguments dist : simpl never.

(* The robot trajectories are straight paths. *)
Definition path_R2 := path location.
Definition paths_in_R2 : location -> path_R2 := local_straight_path.
Coercion paths_in_R2 : location >-> path_R2.

Instance paths_in_R2_compat : Proper (@equiv _ location_Setoid ==> equiv) paths_in_R2.
Proof using . intros pt1 pt2 Heq. now rewrite Heq. Qed.

Lemma no_byz_eq : forall config1 config2 : configuration,
  (forall g, get_location (config1 (Good g)) == get_location (config2 (Good g))) ->
  config1 == config2.
Proof using . intros. apply no_byz_eq. intro. now apply WithMultiplicity.no_info. Qed.

Lemma config_list_alls : forall pt, config_list (fun _ => pt) = alls pt nG.
Proof using .
intro. rewrite config_list_spec, map_cst.
setoid_rewrite names_length. simpl. now rewrite plus_0_r.
Qed.

(** Define one robot to get their location whenever they are gathered. *)
Definition g1 : G.
Proof.
exists 0%nat. abstract (pose (Hle := size_G); lia).
Defined.

(* Definition Spect_map f s := Spect.M.fold (fun e acc => Spect.M.add (f e) acc) s Spect.M.empty. *)

Lemma map_sim_elements : forall (sim : similarity location) s,
  PermutationA equiv (elements (map sim s)) (List.map (fun xn => (sim (fst xn), snd xn)) (elements s)).
Proof using . intros. apply map_injective_elements; autoclass; apply Similarity.injective. Qed.

(** Spectra can never be empty as the number of robots is non null. *)
Lemma obs_non_nil : forall config, !! config =/= empty.
Proof using size_G. apply obs_non_nil. apply size_G. Qed.

Lemma support_non_nil : forall config, support (!! config) <> nil.
Proof using size_G. intro. rewrite support_nil. apply obs_non_nil. Qed.

(* We need to unfold [obs_is_ok] for rewriting *)
Definition obs_from_config_spec : forall (config : configuration) pt,
  (!! config)[pt] = countA_occ equiv equiv_dec pt (List.map get_location (config_list config))
  := WithMultiplicity.obs_from_config_spec.

(** **  Definition of the robogram  **)

Open Scope R_scope.
(* Open Scope VectorSpace_scope. *)

(** The robogram solving the gathering problem in R². *)
Definition ffgatherR2_pgm (s : observation) : @path location location_Setoid :=
  paths_in_R2 (barycenter (List.map (fun xn => (fst xn, INR (snd xn))) (elements s))).

Instance ffgatherR2_pgm_compat : Proper (equiv ==> equiv) ffgatherR2_pgm.
Proof using .
intros ? ? Heq. unfold ffgatherR2_pgm, paths_in_R2.
assert (Hf : Proper (equiv * eq ==> equiv * eq) (fun xn : location * nat => (fst xn, INR (snd xn)))).
{ intros [] [] [Heq1 Heq2]. hnf in *; simpl in *. auto. }
now apply local_straight_path_compat, barycenter_compat,
          (PermutationA_map _ Hf), elements_compat.
Qed.

Definition ffgatherR2 : robogram := {| pgm := ffgatherR2_pgm |}.

(** **  Decreasing measure ensuring termination  **)

(** ***  Global decreasing measure  **)

Definition max_dist_obs (s : observation) : R :=
  max_dist_list_list (support s) (support s).

Instance max_dist_obs_compat : Proper (equiv ==> eq) max_dist_obs.
Proof using . intros ? ? Heq. unfold max_dist_obs. now rewrite Heq. Qed.

Lemma max_dist_obs_le :
  forall (s : observation) pt0 pt1,
    InA equiv pt0 (support s) ->
    InA equiv pt1 (support s) ->
    dist pt0 pt1 <= max_dist_obs s.
Proof using . intros. now apply max_dist_list_list_le. Qed.

Lemma max_dist_obs_ex :
  forall (s : observation),
    support s <> nil ->
    exists pt0 pt1,
      InA equiv pt0 (support s)
      /\ InA equiv pt1 (support s)
      /\ dist pt0 pt1 = max_dist_obs s.
Proof using . intros. unfold max_dist_obs. now apply max_dist_list_list_ex. Qed.

(** **  Main result for termination: the measure decreases after a step where a robot moves  *)

(** A non-negative measure *)
Definition measure (conf: configuration) : R :=
  max_dist_obs (!! conf).

Instance measure_compat : Proper (equiv ==> eq) measure.
Proof using . intros ? ? Heq. unfold measure. now rewrite Heq. Qed.

Lemma measure_nonneg : forall config, 0 <= measure config.
Proof using size_G.
intros config. unfold measure.
destruct (support (!! config)) as [| pt l] eqn:Heq.
+ rewrite support_nil in Heq. elim (obs_non_nil _ Heq).
+ rewrite <- (R2_dist_defined_2 pt). apply max_dist_obs_le; rewrite Heq; now left.
Qed.

(** The minimum value 0 is reached only on gathered configurations. *)
Lemma gathered_support : forall config pt,
  gathered_at pt config <-> PermutationA (@equiv _ location_Setoid) (support (!! config)) (pt :: nil).
Proof using size_G.
intros config pt.
split; intro Hgather.
* apply NoDupA_equivlistA_PermutationA; autoclass.
  + apply support_NoDupA.
  + repeat constructor. intro Hin. inv Hin.
  + intro pt'.
    rewrite support_spec, (obs_from_config_In config pt').
	split; intro Hin.
    - destruct Hin as [id Hid]. revert Hid. pattern id. apply no_byz. clear id; intros g Hid.
      specialize (Hgather g). rewrite Hgather in Hid. rewrite Hid. now left.
    - inv Hin; try inv H0; []. exists (Good g1). apply Hgather.
* intro id.
  assert (Hin : InA equiv (get_location (config (Good id))) (support (!! config))).
  { rewrite support_spec. apply (obs_from_config_In config). eexists; reflexivity. }
  rewrite Hgather in Hin. now inv Hin.
Qed.

Lemma gathered_measure : forall config, measure config = 0 <-> exists pt, gathered_at pt config.
Proof using size_G.
intros config. split; intro H.
* unfold measure, max_dist_obs in *.
  assert (Hnil := obs_non_nil config).
  hnf in Hnil. rewrite <- (support_nil (!! config)) in Hnil.
  assert (Hdup := support_NoDupA (!! config)).
  setoid_rewrite gathered_support.
  induction (support (!! config)) as [| pt l]; try tauto; [].
  exists pt. destruct l as [| pt' l]; try reflexivity.
  inv Hdup. destruct IHl as [? Hperm]; discriminate || auto.
  + apply antisymmetry.
    - rewrite <- H. apply max_dist_list_list_cons_le.
    - rewrite <- (R2_dist_defined_2 pt'). apply max_dist_list_list_le; now left.
  + assert (l = nil).
    { rewrite <- length_zero_iff_nil.
      cut (length (pt' :: l) = length (x :: nil)); try (simpl; lia).
      f_equiv; eauto. }
    subst. rewrite PermutationA_1 in Hperm; autoclass; [].
    elim H2. left.
    cbn in H. do 2 rewrite R2_dist_defined_2 in H.
    rewrite (Rmax_left 0 0) in H; try reflexivity; [].
    rewrite dist_sym in H. rewrite (Rmax_comm 0) in H.
    match type of H with Rmax ?x ?x = 0 => rewrite (Rmax_left x) in H; try reflexivity end.
    rewrite (Rmax_left _ 0), Rmax_left in H.
    - now rewrite dist_defined in H.
    - apply dist_nonneg.
    - rewrite Rmax_left; apply dist_nonneg.
* destruct H as [pt Hgather]. unfold measure.
  destruct (max_dist_obs_ex _ (support_non_nil config)) as [pt1 [pt2 [Hpt1 [Hpt2 Heq]]]].
  rewrite <- Heq, dist_defined. rewrite gathered_support in Hgather. rewrite Hgather in *.
  repeat match goal with H : InA equiv _ _ |- _ => inv H end.
  now transitivity pt.
Qed.

Lemma lift_update_swap : forall da config1 config2 g target,
  @equiv location _
    (lift (existT precondition (frame_choice_bijection (change_frame da config1 g ⁻¹))
                               (precondition_satisfied_inv da config1 g))
          (update config2
           g (change_frame da config1 g) target (choose_update da config2 g target)))
    (update (map_config (lift (existT precondition (frame_choice_bijection (change_frame da config1 g ⁻¹))
                                      (precondition_satisfied_inv da config1 g)))
                        config2)
            g Similarity.id
            (lift_path (frame_choice_bijection (change_frame da config1 g ⁻¹)) target)
            (choose_update da config2 g target)).
Proof using .
intros da config1 config2 g target. cbn -[inverse]. unfold id.
rewrite Similarity.dist_prop, Rmult_1_l.
destruct_match_eq Hle; destruct_match_eq Hle'; try reflexivity; [|];
rewrite Rle_bool_true_iff, Rle_bool_false_iff in *;
exfalso; revert_one not; intro Hgoal; apply Hgoal.
- assert (Hzoom := Similarity.zoom_pos (change_frame da config1 g)).
  eapply Rmult_le_reg_l; eauto; []. simpl.
  rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l; trivial; [].
  changeR2. lra.
- assert (Hzoom := Similarity.zoom_pos (change_frame da config1 g ⁻¹)).
  eapply Rmult_le_reg_l; eauto; []. simpl.
  rewrite <- Rmult_assoc, Rinv_l, Rmult_1_l; trivial; [].
  changeR2. generalize (Similarity.zoom_pos (change_frame da config1 g)). lra.
Qed.

(** Rewriting the [round] function in the global setting. *)
Theorem round_simplify : forall da config, FSYNC_da da ->
  round ffgatherR2 da config
  == fun id => match id with
                 | Byz b => config (Byz b) (* dummy case *)
                 | Good g => let global_trajectory :=
                               straight_path (get_location (config (Good g)))
                                             (barycenter (List.map (fun xn => (fst xn, INR (snd xn)))
                                                                   (elements (!! config)))) in
                             let choice := da.(choose_update) config g global_trajectory in
                             update config g Similarity.id global_trajectory choice
               end.
Proof.
intros da config Hfsync. rewrite FSYNC_round_simplify; trivial; [].
apply no_byz_eq. intro g. cbn beta iota zeta.
assert (supp_nonempty := support_non_nil config).
assert (Hda := similarity_center da config g).
remember (change_frame da config g) as sim.
change (inverse (frame_choice_bijection sim)) with (frame_choice_bijection (sim ⁻¹)).
assert (Hsim : Proper (equiv ==> equiv) sim). { intros ? ? Heq. now rewrite Heq. }
Local Opaque lift. Local Opaque map_config.
assert (Hperm : PermutationA (equiv * eq)%signature
                       (List.map (fun xn => (sim (fst xn), snd xn)) (elements (!! config)))
                       (elements (elt := location) (!! (map_config (lift (existT precondition sim
                                                         (precondition_satisfied da config g))) config)))).
{ rewrite <- map_injective_elements, obs_from_config_map, obs_from_config_ignore_snd;
  autoclass; reflexivity || apply Bijection.injective. }
rewrite obs_from_config_ignore_snd.
simpl pgm. unfold ffgatherR2_pgm. changeR2.
remember (elements (!! config)) as E.
apply (@PermutationA_map _ _ _ (equiv * eq)%signature _ (fun xn => (fst xn, INR (snd xn)))) in Hperm;
  try (now intros ? ? []; split; auto; hnf in *; simpl; f_equal); [].
rewrite map_map, <- (map_map (fun xn => (fst xn, INR (snd xn))) (fun xn => (sim (fst xn), snd xn))) in Hperm.
apply barycenter_compat, paths_in_R2_compat in Hperm.
rewrite barycenter_sim_morph in Hperm;
try (intro Habs; apply map_eq_nil in Habs; rewrite HeqE, elements_nil in Habs; now apply obs_non_nil in Habs); [].
subst sim. changeR2.
rewrite lift_update_swap, <- Hperm.
remember (change_frame da config g) as sim.
remember (List.map (fun xn : location * nat => (fst xn, INR (snd xn))) E) as E'.
assert (lift_path (frame_choice_bijection (sim ⁻¹)) (paths_in_R2 (sim (barycenter E')))
        == straight_path (get_location (config (Good g))) (barycenter E')).
{ intro r. cbn [path_f lift_path straight_path paths_in_R2 local_straight_path].
simpl frame_choice_bijection.
  assert (Heq := sim_mul (sim ⁻¹) r). rewrite Heq. clear Heq. changeR2.
  change (sim ⁻¹ (sim (barycenter E')))%VS with ((sim ⁻¹ ∘ sim) (barycenter E'))%VS.
  rewrite Similarity.compose_inverse_l. change (Similarity.id (barycenter E')) with (barycenter E').
  rewrite Hda. unfold Rminus.
  rewrite mul_distr_add, <- add_morph, minus_morph, mul_opp, mul_1, 2 add_assoc.
  apply RealVectorSpace.add_compat; try reflexivity; []. apply RealVectorSpace.add_comm. }
apply get_location_compat, update_compat; auto.
+ transitivity (map_config id config); try apply map_config_id; [].
  rewrite map_config_merge.
  - f_equiv. intros x y Hxy.
    changeR2. rewrite <- Heqsim.
    transitivity (get_location (lift (existT precondition (frame_choice_bijection (sim ⁻¹))
                                                          (precondition_satisfied_inv da config g))
                                     (lift (existT precondition (frame_choice_bijection sim)
                                           (precondition_satisfied da config g)) x))); try reflexivity; [].
    rewrite 2 get_location_lift. simpl. rewrite Bijection.retraction_section. apply Hxy.
  - autoclass.
  - apply lift_compat. intros x y Hxy. now rewrite Hxy.
+
Admitted. (* Peleg's gathering in FSYNC: round_simplify -> hypothesis missing on the demon *)
(* Mathis Bouverot : See Weber/gathering_flex_ssync.v for a solution. *)

(** If possible, the measure decreases by at least delta at each step. *)
Theorem round_lt_config : forall da config,
    delta > 0 ->
    FSYNC_da da ->
    delta <= measure config ->
    measure (round ffgatherR2 da config) <= measure config - delta.
Proof using size_G.
intros da config Hdelta HFSync Hnotdone.
set (elems := support (!! config)).
set (relems := List.map (fun xn => (fst xn, INR (snd xn))) (elements (!! config))).
set (C := barycenter relems).
assert (Hfst : PermutationA equiv (List.map fst relems) elems).
{ unfold relems, elems. now rewrite map_map, support_map_elements. }
assert (forall p : R2 * R, InA (equiv * eq)%signature p relems -> 0 < snd p).
{ unfold relems, elems. intros ? Hin.
  rewrite (@InA_map_iff _ _ (equiv * eq)%signature) in Hin; autoclass;
    try (intros ? ? [[] ?]; hnf in *; simpl in *; split; auto); [].
  destruct Hin as [[] [Heq Hin]]. rewrite <- Heq.
  apply elements_pos in Hin. now apply lt_0_INR. }
remember (support (!! (round ffgatherR2 da config))) as nxt_elems.
assert (Hantec : forall KP, InA equiv KP nxt_elems ->
                 exists Pid, InA equiv (get_location (config Pid)) elems
                            /\ get_location (round ffgatherR2 da config Pid) == KP).
{ intros [KP k'] HinKP.
  rewrite Heqnxt_elems, support_spec, obs_from_config_In in HinKP.
  destruct HinKP as [Pid HPid].
  exists Pid. split; trivial; [].
  unfold elems. rewrite support_spec, obs_from_config_In.
  now exists Pid. }

assert (Hrobot_move_less_than_delta:
          forall id,
            InA equiv (get_location (config id)) elems ->
            delta > dist (get_location (config id)) C ->
            get_location (round ffgatherR2 da config id) == C).
{ intro id. pattern id. apply no_byz. clear id.
  intros g Hin HdeltaP.
  rewrite (round_simplify _ _ HFSync (Good g)).
  cbn zeta.
  edestruct (ratio_spec config g) as [Heq | [Heq Hle]]; try rewrite Heq.
  + rewrite straight_path_1. reflexivity.
  + exfalso.
    rewrite Heq in Hle. clear Heq.
    remember (move_ratio (choose_update da config g (straight_path
               (get_location (config (Good g))) (barycenter (List.map
                        (fun xn : location * nat => (fst xn, INR (snd xn)))
                        (elements !! config)))))) as r.
    cbn [straight_path path_f] in Hle.
    rewrite <- add_origin in Hle at 1. setoid_rewrite RealVectorSpace.add_comm in Hle.
    rewrite dist_translation in Hle.
    rewrite mul_distr_add, mul_opp, dist_sym, <- R2dist_ref_0, dist_homothecy in Hle.
    assert (0 <= r <= 1) by (destruct r as [r Hr]; apply Hr).
    rewrite Rabs_pos_eq in Hle; try tauto; [].
    apply (Rlt_irrefl delta). eapply Rle_lt_trans; [| eassumption].
    rewrite dist_sym. setoid_rewrite <- Rmult_1_l.
    etransitivity; try apply Hle; []. apply Rmult_le_compat_r.
    - apply dist_nonneg.
    - tauto. }

assert (Hrobot_move:
          forall g,
            InA equiv (get_location (config (Good g))) elems ->
            delta <= dist (get_location (config (Good g))) C ->
            exists r : ratio, get_location (round ffgatherR2 da config (Good g))
                              == (get_location (config (Good g)) + r * (C - (get_location (config (Good g)))))%VS
                   /\ delta <= norm (r * (C - (get_location (config (Good g)))))%VS).
{ intros g Hin HdeltaP.
  setoid_rewrite (round_simplify _ _ HFSync (Good g)).
  cbn zeta.
  edestruct (ratio_spec config g) as [Heq | [Heq Hle]]; try setoid_rewrite Heq.
  + exists ratio_1. setoid_rewrite straight_path_1.
    split; try reflexivity; [].
    now rewrite mul_1, <- norm_dist, dist_sym.
  + remember (move_ratio (choose_update da config g (straight_path
     (get_location (config (Good g))) (barycenter (List.map
                     (fun xn : location * nat => (fst xn, INR (snd xn)))
                     (elements !! config)))))) as r.
    exists r. split; try reflexivity; [].
    rewrite Heq in Hle. cbn [straight_path path_f] in Hle.
    rewrite norm_dist, opp_distr_add, add_assoc, add_opp in Hle.
    rewrite RealVectorSpace.add_comm, RealVectorSpace.add_origin,
    norm_opp, Rmult_1_l in Hle. apply Hle. }

assert (MainArgument: forall KP KQ, InA equiv KP nxt_elems -> InA equiv KQ nxt_elems ->
        dist KP KQ <= max_dist_obs (!! config) - delta).
{ intros KP KQ HinKP HinKQ.
  apply Hantec in HinKP.
  apply Hantec in HinKQ.
  destruct HinKP as [[Pid | []] [HinP HroundP]]; try lia; [].
  destruct HinKQ as [[Qid | []] [HinQ HroundQ]]; try lia; [].
  destruct (Rle_dec delta (dist (get_location (config (Good Pid))) C)),
           (Rle_dec delta (dist (get_location (config (Good Qid))) C)).
  * (* Both P and Q are more than delta away from C *)
    assert (HinPP := HinP).
    apply Hrobot_move in HinP; [|assumption].
    assert (HinQQ := HinQ).
    apply Hrobot_move in HinQ; [|assumption].
    destruct HinP as [kp [kp_def Hkplow]],
             HinQ as [kq [kq_def Hkqlow]].
    rewrite kp_def in HroundP.
    rewrite kq_def in HroundQ.

    assert (HPnotC : get_location (config (Good Pid)) =/= C).
    { intro Heq.
      apply (Rlt_irrefl 0).
      eapply Rlt_le_trans; eauto; [].
      apply dist_defined in Heq.
      now rewrite Heq in *. }
    assert (HQnotC: get_location (config (Good Qid)) =/= C).
    { intro Heq.
      apply (Rlt_irrefl 0).
      eapply Rlt_le_trans; eauto; [].
      apply dist_defined in Heq.
      now rewrite Heq in *. }

    assert (0 <= kp <= 1) by apply ratio_bounds.
    assert (0 <= kq <= 1) by apply ratio_bounds.
    (* Wlog. we assume that kp <= kq *)
    destruct (Rle_dec kp kq).
    + apply Rle_trans with (r2 := (1 - kp) * (max_dist_obs (!! config))).
      - rewrite <- HroundP in *. rewrite <- HroundQ in *. clear HroundP HroundQ KP KQ.
        apply distance_after_move; try assumption.
        ++ eapply barycenter_dist_decrease.
           -- apply H.
           -- setoid_rewrite Hfst. apply max_dist_obs_le.
           -- rewrite Hfst. unfold elems. rewrite support_spec. apply pos_in_config.
        ++ apply max_dist_obs_le; now subst elems.
        ++ cut (proj_ratio kp <> 0%R); try lra; [].
           intro Habs. rewrite Habs, mul_0, norm_origin in Hkplow. lra.
        ++ tauto.
      - cut (delta <= kp * max_dist_obs !! config); try lra; [].
        apply (Rle_trans _ _ _ Hkplow).
        rewrite norm_mul, Rabs_pos_eq; try tauto; [].
        apply Rmult_le_compat_l; try tauto; [].
        rewrite <- norm_dist, dist_sym.
        apply barycenter_dist_decrease.
        ++ assumption.
        ++ setoid_rewrite Hfst. apply max_dist_obs_le.
        ++ rewrite Hfst. unfold elems. rewrite support_spec. apply pos_in_config.
    + apply Rle_trans with (r2 := (1 - kq) * (max_dist_obs (!! config))).
      - rewrite <- HroundP in *. rewrite <- HroundQ in *. clear HroundP HroundQ KP KQ.
        rewrite dist_sym.
        apply distance_after_move; try assumption || lra.
        ++ apply barycenter_dist_decrease.
           -- assumption.
           -- setoid_rewrite Hfst. apply max_dist_obs_le.
           -- rewrite Hfst. unfold elems. rewrite support_spec. apply pos_in_config.
        ++ apply max_dist_obs_le; now subst elems.
        ++ cut (proj_ratio kq <> 0%R); try lra.
           intro Habs. rewrite Habs, mul_0, norm_origin in Hkqlow. lra.
      - cut (delta <= kq * max_dist_obs !! config); try lra; [].
        apply (Rle_trans _ _ _ Hkqlow).
        rewrite norm_mul, Rabs_pos_eq; try tauto; [].
        apply Rmult_le_compat_l; try tauto; [].
        rewrite <- norm_dist, dist_sym.
        apply barycenter_dist_decrease.
        ++ assumption.
        ++ setoid_rewrite Hfst. apply max_dist_obs_le.
        ++ rewrite Hfst. unfold elems. rewrite support_spec. apply pos_in_config.
  * (* Q is close to C but not P *)
    assert (HinPP := HinP).
    apply Hrobot_move in HinP; [|assumption].
    assert (HinQQ := HinQ).
    apply Hrobot_move_less_than_delta in HinQ; try lra; [].
    destruct HinP as [kp [kp_def Hkplow]].
    assert (0 <= kp <= 1) by apply ratio_bounds.
    rewrite kp_def in HroundP.
    rewrite HinQ in HroundQ.
    rewrite <- HroundP in *. rewrite <- HroundQ in *. clear HroundP HroundQ KP KQ.
    apply Rle_trans with (r2 := dist (get_location (config (Good Pid))) C - delta).
    + rewrite norm_dist.
      assert (Heq : (config (Good Pid) + kp * (C - config (Good Pid)) - C
                     == (1 + - kp) * -(C - config (Good Pid)))%VS).
      { symmetry. rewrite <- add_morph, mul_1.
        now rewrite RealVectorSpace.mul_opp, minus_morph, opp_opp, <- add_assoc, opp_distr_add, opp_opp,
                    (RealVectorSpace.add_comm (-C)), <- add_assoc, (RealVectorSpace.add_comm (-C)). }
      rewrite Heq, norm_mul, norm_opp, dist_sym, norm_dist, Rabs_pos_eq,
              Rmult_plus_distr_r, Rmult_1_l, <- Ropp_mult_distr_l; try lra; [].
      apply Rplus_le_compat_l, Ropp_le_contravar.
      rewrite norm_mul, Rabs_pos_eq in Hkplow; trivial; lra.
    + apply Rplus_le_compat_r.
      apply barycenter_dist_decrease.
      - assumption.
      - setoid_rewrite Hfst. apply max_dist_obs_le.
      - rewrite Hfst. unfold elems. rewrite support_spec. apply pos_in_config.
  * (* P is close to C but not Q *)
    assert (HinPP := HinP).
    apply Hrobot_move_less_than_delta in HinP; try lra; [].
    assert (HinQQ := HinQ).
    apply Hrobot_move in HinQ; [|assumption].
    destruct HinQ as [kq [kq_def Hkqlow]].
    assert (0 <= kq <= 1) by apply ratio_bounds.
    rewrite HinP in HroundP.
    rewrite kq_def in HroundQ.
    rewrite <- HroundP in *. rewrite <- HroundQ in *. clear HroundP HroundQ KP KQ.
    apply Rle_trans with (r2 := dist (get_location (config (Good Qid))) C - delta).
    + rewrite dist_sym, norm_dist.
      assert (Heq : (get_location (config (Good Qid)) + kq * (C - get_location (config (Good Qid))) - C
                     == (1 + - kq) * -(C - get_location (config (Good Qid))))%VS).
      { symmetry. rewrite <- add_morph, mul_1.
        now rewrite RealVectorSpace.mul_opp, minus_morph, opp_opp, <- add_assoc, opp_distr_add, opp_opp,
                    (RealVectorSpace.add_comm (-C)), <- add_assoc, (RealVectorSpace.add_comm (-C)). }
      rewrite Heq, norm_mul, norm_opp, dist_sym, norm_dist, Rabs_pos_eq,
              Rmult_plus_distr_r, Rmult_1_l, <- Ropp_mult_distr_l; try lra; [].
      apply Rplus_le_compat_l, Ropp_le_contravar.
      rewrite norm_mul, Rabs_pos_eq in Hkqlow; trivial; lra.
    + apply Rplus_le_compat_r.
      apply barycenter_dist_decrease.
      - assumption.
      - setoid_rewrite Hfst. apply max_dist_obs_le.
      - rewrite Hfst. unfold elems. rewrite support_spec. apply pos_in_config.
  * (* Both P and Q are close to C *)
    apply Hrobot_move_less_than_delta in HinP; try lra; [].
    apply Hrobot_move_less_than_delta in HinQ; try lra; [].
    rewrite <- HroundP in *. rewrite <- HroundQ in *. clear HroundP HroundQ KP KQ.
    rewrite HinP, HinQ.
    assert (Heq0 : dist C C = 0) by now rewrite dist_defined.
    rewrite Heq0.
    unfold measure in Hnotdone. lra. }

unfold measure.
generalize (max_dist_obs_ex (!! (round ffgatherR2 da config))).
intros Hmax_dist_ex.
assert (Hobs_non_nil : nxt_elems <> nil).
{ rewrite Heqnxt_elems. apply support_non_nil. }
rewrite <- Heqnxt_elems in Hmax_dist_ex.
destruct (Hmax_dist_ex Hobs_non_nil) as [pt0 [pt1 [Hin0 [Hin1 Hdist]]]].
rewrite <- Hdist.
now auto.
Qed.

(** If the measure is too small, it saturates at 0. *)
Theorem round_last_step : forall da config,
    delta > 0 ->
    FSYNC_da da ->
    measure config <= delta ->
    measure (round ffgatherR2 da config) == 0.
Proof using size_G.
intros da config Hdelta HFSync Hlt.
unfold measure.
set (elems := support (!! config)).
set (relems := List.map (fun xn => (fst xn, INR (snd xn))) (elements (!! config))).
set (C := barycenter relems).
assert (Hfst : PermutationA equiv (List.map fst relems) elems).
{ unfold relems, elems. now rewrite map_map, support_map_elements. }
assert (Hrelems : forall p : R2 * R, InA (equiv * eq)%signature p relems -> 0 < snd p).
{ unfold relems, elems. intros ? Hin.
  rewrite (@InA_map_iff _ _ (equiv * eq)%signature) in Hin; autoclass;
    try (intros ? ? []; hnf in *; simpl in *; split; auto); [].
  destruct Hin as [[] [Heq Hin]]. rewrite <- Heq.
  apply elements_pos in Hin. now apply lt_0_INR. }
remember (support (!! (round ffgatherR2 da config))) as nxt_elems.
assert (Hantec : forall KP, InA equiv KP nxt_elems ->
                 exists g, InA equiv (get_location (config (Good g))) elems
                        /\ get_location (round ffgatherR2 da config (Good g)) == KP).
{ intros [KP k'] HinKP.
  rewrite Heqnxt_elems, support_spec, obs_from_config_In in HinKP.
  destruct HinKP as [[g | []] Hg]; try lia; [].
  exists g. split; trivial; [].
  unfold elems. rewrite support_spec, obs_from_config_In.
  now exists (Good g). }
assert (HonlyC: forall KP, InA equiv KP nxt_elems -> KP == C).
{ intros KP HinKP.
  destruct (Hantec KP HinKP) as [g [Hin Hround]].
  rewrite <- Hround in *. clear Hround KP.
  rewrite (round_simplify _ _ HFSync (Good g)).
  fold relems. cbn zeta.
  edestruct (ratio_spec config g) as [Hupdate | Hupdate]; try rewrite Hupdate.
  + (* valid case: mvt smaller than delta *)
    rewrite straight_path_1. reflexivity.
  + (* mvt at least delta: it is exactly delta *)
    destruct Hupdate as [Hupdate Hle]. rewrite Hupdate in *.
    remember (move_ratio (choose_update da config g
               (straight_path (get_location (config (Good g))) (barycenter relems)))) as r.
    cbn [straight_path path_f] in Hle.
    rewrite <- add_origin in Hle at 1. setoid_rewrite RealVectorSpace.add_comm in Hle.
    rewrite dist_translation in Hle.
    rewrite mul_distr_add, mul_opp, dist_sym, <- R2dist_ref_0, dist_homothecy in Hle.
    assert (0 <= r <= 1) by apply ratio_bounds.
    rewrite Rabs_pos_eq in Hle; try tauto; [].
    assert (Hmeasure : forall p1 p2, InA equiv p1 elems -> InA equiv p2 elems -> dist p1 p2 <= measure config).
    { intros p1 p2 Hin1 Hin2. now apply max_dist_obs_le. }
    setoid_rewrite <- Hfst in Hmeasure. rewrite <- Hfst in Hin.
    assert (Hle' := barycenter_dist_decrease relems (measure config) Hrelems Hmeasure _ Hin).
    clear Hupdate Heqr Hmeasure. rewrite dist_sym in Hle'.
    assert (Hr : r == ratio_1).
    { apply (Rmult_eq_reg_r delta); try lra; [].
      rewrite Rmult_1_l. apply antisymmetry.
      - rewrite <- Rmult_1_l. apply Rmult_le_compat_r; lra || tauto.
      - rewrite Rmult_1_l in Hle. etransitivity; eauto; [].
        apply Rmult_le_compat_l; try tauto; []. etransitivity; eauto. }
    rewrite Hr. rewrite straight_path_1. reflexivity. }
destruct (max_dist_obs_ex _ (support_non_nil (round ffgatherR2 da config)))
  as [pt0 [pt1 [Hinpt0 [Hinpt1 Hdist]]]].
rewrite <- Hdist, HonlyC, (HonlyC pt1); try (now subst); [].
now apply dist_defined.
Qed.

Definition lt_config delta x y :=
  lt (Z.to_nat (up (measure x / delta))) (Z.to_nat (up (measure y / delta))).

Lemma wf_lt_config (Hdeltapos: delta > 0) : well_founded (lt_config delta).
Proof using . unfold lt_config. apply wf_inverse_image, lt_wf. Qed.

Lemma lt_config_decrease : forall config1 config2, 0 < delta ->
  measure config1 <= measure config2 - delta -> lt_config delta config1 config2.
Proof using size_G.
intros config1 config2 Hdelta Hle. unfold lt_config.
rewrite <- Z2Nat.inj_lt.
+ apply Zup_lt. field_simplify; try lra. unfold Rdiv. apply Rmult_le_compat.
  - apply measure_nonneg.
  - apply Rlt_le. now apply Rinv_0_lt_compat.
  - lra.
  - reflexivity.
+ apply le_IZR. transitivity (measure config1 / delta).
  - simpl. apply Rdiv_le_0_compat; trivial. apply measure_nonneg.
  - apply Rlt_le, (proj1 (archimed _)).
+ apply le_IZR. transitivity (measure config2 / delta).
  - simpl. apply Rdiv_le_0_compat; trivial. apply measure_nonneg.
  - apply Rlt_le, (proj1 (archimed _)).
Qed.

(** ***  With the termination, the rest of the proof is easy  **)

Lemma gathered_precise : forall config pt,
  gathered_at pt config -> forall id, gathered_at (config id) config.
Proof using size_G.
intros config pt Hgather id id'. transitivity pt.
- apply Hgather.
- symmetry. apply (no_byz id), Hgather.
Qed.
(*
Corollary not_gathered_generalize : forall config id,
  ~gathered_at (config id) config -> forall pt, ~gathered_at pt config.
Proof. intros config id Hnot pt Hgather. apply Hnot. apply (gathered_precise Hgather). Qed.

Lemma not_gathered_exists : forall config pt,
  ~ gathered_at pt config -> exists id, ~config id == pt.
Proof.
intros config pt Hgather.
destruct (forallb (fun x => R2dec_bool (config x) pt) names) eqn:Hall.
- elim Hgather. rewrite forallb_forall in Hall.
  intro id'. setoid_rewrite R2dec_bool_true_iff in Hall.
  hnf. repeat rewrite Hall; trivial; apply In_names.
- rewrite <- negb_true_iff, existsb_forallb, existsb_exists in Hall.
  destruct Hall as [id' [_ Hid']].
  rewrite negb_true_iff, R2dec_bool_false_iff in Hid'.
  now exists id'.
Qed.
*)

Lemma gathered_at_elements : forall config pt,
  gathered_at pt config -> PermutationA eq_pair (elements (!! config)) ((pt, nG) :: nil).
Proof using size_G.
intros config pt Hgather.
apply NoDupA_equivlistA_PermutationA; autoclass.
* eapply NoDupA_strengthen, elements_NoDupA. apply subrelation_pair_elt.
* repeat constructor. now rewrite InA_nil.
* intros [x k].
  rewrite elements_spec. cbn -[nG].
  unfold obs_from_config. simpl. rewrite config_list_spec.
  assert (Hnames : names = List.map Good Gnames).
  { unfold names. cut (Bnames = nil).
    - intro Hb. rewrite Hb. simpl. apply app_nil_r.
    - now rewrite <- length_zero_iff_nil, Bnames_length. }
  rewrite Hnames, 2 map_map. unfold id.
  assert (Hperm : PermutationA equiv (List.map (fun x0 : G => config (Good x0)) Gnames) (alls pt nG)).
  { rewrite <- Gnames_length, <- map_cst.
    rewrite map_extensionalityA_compat; try reflexivity; autoclass; [].
    intros ? ? ?. subst. apply Hgather. }
  split; intro Hin.
  + destruct Hin as [? Hlt]. subst k. left. revert Hlt.
    apply make_multiset_compat in Hperm.
    rewrite Hperm, make_multiset_alls, singleton_spec. changeR2.
    destruct (x =?= pt) as [Hpt | Hpt].
    - now split.
    - intro. lia.
  + inv Hin; try (now rewrite InA_nil in *); [].
    revert_one eq_pair. intros [Heq1 Heq2]. compute in Heq1, Heq2; subst.
    assert (Hle := size_G). split; try lia; [].
    apply make_multiset_compat in Hperm.
    rewrite Hperm, make_multiset_alls, singleton_spec. changeR2.
    destruct (pt =?= pt); intuition.
Qed.

Lemma gathered_at_forever : forall da config pt, FSYNC_da da ->
  gathered_at pt config -> gathered_at pt (round ffgatherR2 da config).
Proof using size_G.
intros da config pt Hda Hgather g.
rewrite round_simplify; trivial; [].
cbn zeta.
assert (Hf : Proper (@equiv location _ * eq ==> equiv * eq) (fun xn => (fst xn, INR (snd xn)))).
{ intros [] [] []. split; hnf; simpl; auto. }
rewrite Hgather.
apply gathered_at_elements, (Preliminary.PermutationA_map _ Hf) in Hgather.
apply barycenter_compat in Hgather. cbn [List.map] in Hgather.
assert (INR nG <> 0). { apply not_0_INR. generalize size_G. intro. simpl. lia. }
rewrite barycenter_singleton in Hgather; trivial; [].
rewrite Hgather, update_no_move; eauto using FlexibleChoiceFlexibleUpdate.
Qed.

Lemma gathered_at_OK : forall d conf pt, FSYNC (similarity_demon2demon d) ->
  gathered_at pt conf -> Gather pt (execute ffgatherR2 d conf).
Proof using size_G.
cofix Hind. intros d conf pt Hd Hgather. constructor.
+ clear Hind. simpl. assumption.
+ rewrite execute_tail. destruct Hd. apply Hind; now try apply gathered_at_forever.
Qed.

(*
Lemma not_isobarycenter_moves:
  forall d config gid,
    delta > 0 ->
    FullySynchronous d ->
    config gid =/= isobarycenter (elements (!! config)) ->
    round ffgatherR2 (Stream.hd d) config gid =/= config gid.
Proof.
intros d config id. pattern id. apply no_byz. clear id.
intros g Hdelta HFSync Hnotbary Hnotmove.
apply Hnotbary. clear Hnotbary. revert Hnotmove.
rewrite round_simplify.
destruct HFSync as [Hd _]. rewrite <- similarity2demon_hd, Hd.
cbn zeta. cbn -[dist add opp mul equiv].
destruct_match.
+ rewrite <- (add_origin (config (Good g))) at 4.
  intro Heq. apply add_reg_l in Heq. apply mul_integral in Heq.
  destruct Heq as [Heq | Heq].
  - match goal with H : delta <= _ |- _ => rename H into Hle end.
    rewrite Heq, mul_0, add_origin, R2_dist_defined_2 in Hle. lra.
  - now rewrite R2sub_origin in Heq.
+ rewrite mul_1. unfold id. rewrite <- (add_origin (config (Good g))) at 3.
  intro Heq. apply add_reg_l in Heq. now rewrite R2sub_origin in Heq.
Qed.
*)

(** The final theorem. *)
Theorem FSGathering_in_R2 :
  forall d, delta > 0 -> FSYNC (similarity_demon2demon d) -> FullSolGathering ffgatherR2 d.
Proof using size_G.
intros d Hdelta HFS config. revert d HFS. pattern config.
apply (well_founded_ind (wf_lt_config Hdelta)). clear config.
intros config Hind [da d] HFS.
(* Are we already gathered? *)
destruct (gathered_at_dec config (config (Good g1))) as [Hmove | Hmove];
[| destruct (gathered_at_dec (round ffgatherR2 da config)
                             (round ffgatherR2 da config (Good g1))) as [Hmove' | Hmove']].
* (* If we are already gathered, not much to do *)
  apply Stream.Now. exists (config (Good g1)). now apply gathered_at_OK.
* (* If we are gathered at the next step, not much to do either. *)
  apply Stream.Later, Stream.Now. exists (round ffgatherR2 da config (Good g1)).
  rewrite execute_tail. destruct HFS. now apply gathered_at_OK.
* (* General case, use [round_lt_config] *)
  assert (delta <= measure config).
  { destruct HFS as [HFSync _]. simpl in HFSync.
    apply Rnot_lt_le. intro Habs. eapply Rlt_le, round_last_step in Habs; eauto; [].
    simpl equiv in Habs. rewrite gathered_measure in Habs. destruct Habs as [pt Habs].
    apply Hmove'. apply (gathered_precise Habs (Good g1)). }
  destruct HFS.
  apply Stream.Later. apply Hind.
  + apply lt_config_decrease; trivial; [].
    now apply round_lt_config.
  + assumption.
Qed.

End GatheringInR2.

(* Prefer not to leave this here, so that make -vos does not fail here.
See Peleg_Assumptions.v *)
(* Print Assumptions FSGathering_in_R2. *)


From Equations Require Import Equations.

Section sum.

Variable (L R : Set) (L_eqdec : EqDec L) (R_eqdec : EqDec R).

Inductive sum : Type :=
| inl : L -> sum| inr : R -> sum.

Equations Derive NoConfusion EqDec for sum.

End sum.

Succeed Check sum_eqdec.