diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 8b00ab32cbaf61672e583d57f87e300de23a8bf0..76c4705980764522d6945b9936461785b520c17c 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -10,6 +10,7 @@ stages:
- opam update -y
- opam config list
- opam repo list
+ - opam install coq-libhyps
- opam list
script:
- sudo chown -R coq:coq "$CI_PROJECT_DIR"
@@ -17,8 +18,11 @@ stages:
- make -j "$NJOBS"
# - make install
-coq:8.12:
+coq:8.18:
extends: .build
-coq:8.13:
+coq:8.19:
+ extends: .build
+
+coq:8.20:
extends: .build
diff --git a/CREDIT.md b/CREDIT.md
new file mode 100644
index 0000000000000000000000000000000000000000..57547d1e0e3a6cd7e0b62766deab654787674acc
--- /dev/null
+++ b/CREDIT.md
@@ -0,0 +1,9 @@
+The following people have contributed to the development of the Pactole library during the indicated periods of time:
+
+- Cédric Auger (2013)
+- Thibaut Balabonski (2016-2017)
+- Sebastien Bouchard (2021- now)
+- Pierre Courtieu (2013- now)
+- Robin Pelle (2016-2020)
+- Lionel Rieg (2014- now)
+- Xavier Urbain (2013-now)
diff --git a/CaseStudies/Convergence/Algorithm_noB_Assumptions.v b/CaseStudies/Convergence/Algorithm_noB_Assumptions.v
new file mode 100644
index 0000000000000000000000000000000000000000..032595be1300d9e302644b87c1be9a0daefc5b63
--- /dev/null
+++ b/CaseStudies/Convergence/Algorithm_noB_Assumptions.v
@@ -0,0 +1,2 @@
+Require Pactole.CaseStudies.Convergence.Algorithm_noB.
+Print Assumptions Algorithm_noB.convergence_FSYNC.
diff --git a/CaseStudies/Gathering/InR/Algorithm.v b/CaseStudies/Gathering/InR/Algorithm.v
index f754e01d022e4d3a389ba8c7b4021bb064a91fbc..7a439691ce3941aa29ce2399aa8894a712d758a4 100644
--- a/CaseStudies/Gathering/InR/Algorithm.v
+++ b/CaseStudies/Gathering/InR/Algorithm.v
@@ -305,7 +305,6 @@ Proof using size_G.
(support (max (!! config)))
(support (!! config))
(support_NoDupA _)
- (support_NoDupA _)
h Hlen'').
assert (toto:=cardinal_obs_from_config config origin).
unfold nB in toto.
@@ -695,7 +694,7 @@ destruct (support (max (!! config))) as [| pt' [| pt2' l']].
destruct (size (!! config) =? 3) eqn:Hlen.
+ (* There are three towers *)
rewrite Hmap, middle_sim_invariant.
- - simpl. now rewrite Bijection.retraction_section.
+ - simpl. unfold id. now rewrite Bijection.retraction_section.
- now rewrite <- Nat.eqb_eq.
+ (* Generic case *)
change (IZR Z0) with (@origin location _ _ _). rewrite <- (Similarity.center_prop sim) at 1.
@@ -961,11 +960,13 @@ induction names as [| id l]; simpl in *; unfold Datatypes.id in *.
match goal with H : extreme_center _ == _ |- _ => rewrite <- H at 2 end.
now apply Generic_min_mid_lt.
- exfalso. revert Hext. unfold is_extremal.
- rewrite e.
+ match goal with
+ H: (config id == _) |- _ => rewrite H
+ end.
repeat destruct_match.
-- discriminate.
-- discriminate.
- -- intros _. now apply c0.
+ -- intros _. match goal with H: mini _ =/= mini _ |- _ => apply H end;auto.
- apply IHl.
+ destruct_match.
- f_equal. apply IHl.
@@ -994,11 +995,11 @@ induction names as [| id l]; simpl.
match goal with H : extreme_center _ == _ |- _ => rewrite <- H at 1 end.
now apply Generic_mid_max_lt.
- exfalso. revert Hext. unfold is_extremal.
- rewrite e.
+ match goal with H: config id == _ |- _ => rewrite H end.
repeat destruct_match;intros ?.
-- discriminate.
-- discriminate.
- -- now apply c1.
+ -- match goal with H: maxi _ =/= maxi _ |- _ => apply H end;auto.
- apply IHl.
+ destruct_match.
- f_equal. apply IHl.
@@ -1045,13 +1046,13 @@ destruct (da.(activate) id1) eqn:Hmove1; [destruct (da.(activate) id2) eqn:Hmove
assert (Hmaj : no_Majority config).
{ unfold no_Majority. rewrite size_spec, Hmaj'. simpl. lia. } clear Hmaj'.
destruct (is_extremal (config id1) (!! config)) eqn:Hextreme1.
- + exfalso. unfold moving in Hid1. rewrite List.filter_In in Hid1. destruct Hid1 as [_ Hid1].
- destruct (equiv_dec (round gatherR da config id1) (config id1)) as [_ | Hneq]; try discriminate.
+ + exfalso. unfold moving, equiv_decb in Hid1. rewrite List.filter_In in Hid1. destruct Hid1 as [_ Hid1].
+ destruct (get_location (round gatherR da config id1) =?= get_location (config id1)) as [_ | Hneq]; try discriminate; [].
apply Hneq. rewrite (round_simplify_Generic Hmaj Hlen id1); trivial; [].
destruct (da.(activate) id1); try reflexivity; []. now rewrite Hextreme1.
+ destruct (is_extremal (config id2) (!! config)) eqn:Hextreme2.
- - exfalso. unfold moving in Hid2. rewrite List.filter_In in Hid2. destruct Hid2 as [_ Hid2].
- destruct (equiv_dec (round gatherR da config id2) (config id2)) as [_ | Hneq]; try discriminate; [].
+ - exfalso. unfold moving, equiv_decb in Hid2. rewrite List.filter_In in Hid2. destruct Hid2 as [_ Hid2].
+ destruct (get_location (round gatherR da config id2) =?= get_location (config id2)) as [_ | Hneq]; try discriminate; [].
apply Hneq. rewrite (round_simplify_Generic Hmaj Hlen id2).
destruct (da.(activate) id2); try reflexivity. now rewrite Hextreme2.
- reflexivity. }
@@ -1120,11 +1121,14 @@ intros config pt. split.
assert (Hdest : forall id', List.In id' (moving gatherR da config) ->
get_location (round gatherR da config id') = pt).
{ intros. rewrite <- Hid. apply same_destination; trivial; rewrite moving_spec; auto. }
+ (* assert (Habs' : round gatherR da config id' =/= config id').
+ { intro Habs'. rewrite Habs' in Habs. now contradiction Habs. }
+ *)
assert (Hstay : forall id, get_location (config id) = pt -> get_location (round gatherR da config id) = pt).
{ intros id' Hid'. destruct (get_location (round gatherR da config id') =?= pt) as [Heq | Heq]; trivial; [].
assert (Habs := Heq). rewrite <- Hid' in Habs.
- assert (Habs' : round gatherR da config id' =/= config id').
- { intro Habs'. rewrite Habs' in Habs. now contradiction Habs. }
+ assert (Habs' : get_location (round gatherR da config id') =/= get_location (config id')).
+ { intro Habs'. rewrite Habs' in Habs. now elim Habs. }
rewrite <- (moving_spec gatherR) in Habs'. apply Hdest in Habs'. contradiction. }
do 2 rewrite obs_from_config_spec, config_list_spec.
assert (Hin : List.In id names) by apply In_names.
@@ -1164,7 +1168,7 @@ destruct (support (max (!! config))) as [| pt [| pt' l']] eqn:Hmaj.
assert (Hmaj : no_Majority config). { unfold no_Majority. rewrite size_spec, Hmaj'. simpl. lia. }
clear pt pt' l' Hmaj'.
(* A robot has moved otherwise we have the same configuration before and it is invalid. *)
- assert (Hnil := no_moving_same_config gatherR da config).
+ assert (Hnil := no_changing_same_config gatherR da config).
destruct (moving gatherR da config) as [| rmove l] eqn:Heq.
* now rewrite Hnil.
* intro Habs.
@@ -1389,7 +1393,6 @@ destruct (support (max (!! config))) as [| pt [| ? ?]] eqn:Hmaj.
assert (Hperm : PermutationA equiv (support (!! (round gatherR da config)))
(support (!! config))).
{ apply (NoDupA_inclA_length_PermutationA _).
- - apply support_NoDupA.
- apply support_NoDupA.
- rewrite inclA_Leibniz. eapply support_round_Three_incl; eassumption.
- do 2 rewrite <- size_spec. rewrite Hlen'. reflexivity. }
@@ -1554,12 +1557,12 @@ induction locallyfair as [d Hactive | d]; intros config Hinvalid Hgathered Hmove
rewrite <- (demon2demon Hprop) in Hactive.
apply Hmove in Hactive; try (now destruct HSSYNC); [].
simpl in Hactive. changeR. rewrite Habs in Hactive. inversion Hactive.
-+ destruct (moving gatherR (Stream.hd d) config) eqn:Hnil.
- - apply MoveLater; try exact Hnil.
- rewrite (no_moving_same_config _ _ _ Hnil).
++ destruct (changing gatherR (Stream.hd d) config) eqn:Hnil.
+ - apply MoveLater; try exact Hnil; [].
+ rewrite (no_changing_same_config _ _ _ Hnil).
destruct Hprop, Hfair, HSSYNC.
now apply IHlocallyfair.
- - apply MoveNow. rewrite Hnil. discriminate.
+ - apply MoveNow. change moving with changing. now rewrite Hnil.
Qed.
@@ -1614,7 +1617,7 @@ destruct (gathered_at_dec config (get_location (config (Good g1)))) as [Hmove |
- now destruct Hfair.
- rewrite <- (demon2demon Hprop). destruct HSSYNC. now apply never_invalid.
+ (* Inductive case: we know by induction hypothesis that the wait will end *)
- apply no_moving_same_config in Heq.
+ change moving with changing in Heq. apply no_changing_same_config in Heq.
apply Stream.Later. eapply Hrec.
- setoid_rewrite Heq. apply Hind.
- apply HSSYNC.
diff --git a/CaseStudies/Gathering/InR2/Algorithm.v b/CaseStudies/Gathering/InR2/Algorithm.v
index c879256a4d315b9cfcce93194c8ea5a0b5856fe6..0840d36cd4d784aad3a19b4b6f362af7f2cbdfe4 100644
--- a/CaseStudies/Gathering/InR2/Algorithm.v
+++ b/CaseStudies/Gathering/InR2/Algorithm.v
@@ -47,6 +47,7 @@ Require Import Pactole.Models.NoByzantine.
(* User defined *)
Import Permutation.
+Import ListNotations.
Import Datatypes. (* to recover [id] *)
Set Implicit Arguments.
@@ -77,9 +78,6 @@ Instance MyRobots : Names := Robots n 0.
Instance NoByz : NoByzantine.
Proof using . now split. Qed.
-(* Existing Instance R2_Setoid.
-Existing Instance R2_EqDec.
-Existing Instance R2_RMS. *)
(* We are in a rigid formalism with no other info than the location, so the demon makes no choice. *)
Instance Loc : Location := make_Location R2.
@@ -102,14 +100,6 @@ Proof using . split. reflexivity. Qed.
Notation "s [ x ]" := (multiplicity x s) (at level 2, no associativity, format "s [ x ]").
Notation "!! config" := (@obs_from_config location _ _ _ multiset_observation config origin) (at level 10).
Notation support := (@support location _ _ _).
-(* (@obs_from_config R2 unit _ _ _ _ _ _ multiset_observation) (at level 1). *)
-(* Notation "x == y" := (equiv x y).
-Notation observation := (@observation R2 R2 _ R2_EqDec _ R2_EqDec _ MyRobots multiset_observation).
-Notation robogram := (@robogram R2 R2 _ _ _ _ _ MyRobots _).
-Notation configuration := (@configuration R2 _).
-Notation config_list := (@config_list R2 _).
-Notation round := (@round R2 R2 _ _ _ _ _ _ _ _).
-Notation execution := (@execution R2 _). *)
Notation Madd := (MMultisetInterface.add).
Implicit Type config : configuration.
@@ -174,18 +164,17 @@ Qed.
Open Scope R_scope.
(** The target in the triangle case. *)
-(* TODO: replace [isobarycenter_3_pts] with the general [isobarycenter]. *)
Definition target_triangle (pt1 pt2 pt3 : location) : location :=
let typ := classify_triangle pt1 pt2 pt3 in
match typ with
- | Equilateral => isobarycenter_3_pts pt1 pt2 pt3
+ | Equilateral => isobarycenter ([pt1; pt2; pt3])%list
| Isosceles p => p
| Scalene => opposite_of_max_side pt1 pt2 pt3
end.
Lemma target_triangle_compat : forall pt1 pt2 pt3 pt1' pt2' pt3',
- Permutation (pt1 :: pt2 :: pt3 :: nil) (pt1' :: pt2' :: pt3' :: nil) ->
- target_triangle pt1 pt2 pt3 = target_triangle pt1' pt2' pt3'.
+ Permutation ([pt1; pt2; pt3]) ([pt1'; pt2'; pt3']) ->
+ target_triangle pt1 pt2 pt3 == target_triangle pt1' pt2' pt3'.
Proof using .
intros pt1 pt2 pt3 pt1' pt2' pt3' hpermut.
generalize (classify_triangle_compat hpermut).
@@ -193,7 +182,7 @@ intro h_classify.
unfold target_triangle.
functional induction (classify_triangle pt1 pt2 pt3);
rewrite <- h_classify; auto.
-- apply isobarycenter_3_pts_compat; auto.
+- apply isobarycenter_compat; auto. now rewrite PermutationA_Leibniz.
- symmetry in hpermut |- *. apply opposite_of_max_side_compat; auto.
Qed.
@@ -203,8 +192,8 @@ Definition target (s : observation) : location :=
let l := support s in
match on_SEC l with
| nil => (0, 0) (* no robot *)
- | pt :: nil => pt (* gathered *)
- | pt1 :: pt2 :: pt3 :: nil => (* triangle cases *)
+ | [pt] => pt (* gathered *)
+ | [pt1; pt2; pt3] => (* triangle cases *)
target_triangle pt1 pt2 pt3
| _ => (* general case *) R2.center (SEC l)
end.
@@ -265,7 +254,7 @@ Qed.
Definition gatherR2_pgm (s : observation) : location :=
match support (max s) with
| nil => origin (* no robot *)
- | pt :: nil => pt (* majority *)
+ | [pt] => pt (* majority *)
| _ :: _ :: _ =>
if is_clean s then target s (* clean case *)
else if mem equiv_dec origin (SECT s) then origin else target s (* dirty case *)
@@ -307,15 +296,15 @@ Definition no_Majority config := (size (max (!! config)) > 1)%nat.
Definition diameter_case config :=
no_Majority config
- /\ exists pt1 pt2, PermutationA equiv (on_SEC (support (!! config))) (pt1 :: pt2 :: nil).
+ /\ exists pt1 pt2, PermutationA equiv (on_SEC (support (!! config))) ([pt1; pt2]).
Definition triangle_case config :=
no_Majority config
- /\ exists pt1 pt2 pt3, PermutationA equiv (on_SEC (support (!! config))) (pt1 :: pt2 :: pt3 :: nil).
+ /\ exists pt1 pt2 pt3, PermutationA equiv (on_SEC (support (!! config))) ([pt1; pt2; pt3]).
Definition equilateral_case config :=
no_Majority config
- /\ exists pt1 pt2 pt3, PermutationA equiv (on_SEC (support (!! config))) (pt1 :: pt2 :: pt3 :: nil)
+ /\ exists pt1 pt2 pt3, PermutationA equiv (on_SEC (support (!! config))) ([pt1; pt2; pt3])
/\ classify_triangle pt1 pt2 pt3 = Equilateral.
Definition generic_case config :=
@@ -348,7 +337,7 @@ Definition clean_diameter_case config :=
(** Some results about [MajTower_at] and [no_Majority]. *)
Theorem MajTower_at_equiv : forall config pt, MajTower_at pt config <->
- support (max (!! config)) = pt :: nil.
+ support (max (!! config)) = [pt].
Proof using size_G.
intros config pt. split; intro Hmaj.
* apply Permutation_length_1_inv. rewrite <- PermutationA_Leibniz.
@@ -374,7 +363,7 @@ Qed.
Theorem no_Majority_equiv : forall config, no_Majority config
<-> exists pt1 pt2 l, support (max (!! config)) = pt1 :: pt2 :: l.
Proof using size_G.
-intros config.
+intros config. cbn [app].
unfold no_Majority. rewrite size_spec.
split; intro Hmaj.
+ destruct (support (max (!! config))) as [| ? [| ? ?]]; cbn in Hmaj; lia || eauto.
@@ -409,19 +398,19 @@ Ltac get_case config :=
(* try rewrite <- PermutationA_Leibniz in *; *)
lazymatch goal with
(* Majority case *)
- | H : support (max (!! config)) = ?pt :: nil |- _ =>
+ | H : support (max (!! config)) = [?pt] |- _ =>
assert (Hcase : MajTower_at pt config) by now rewrite MajTower_at_equiv
(* Diameter case *)
- | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = _ :: _ :: nil |- _ =>
+ | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = [_; _] |- _ =>
assert (Hcase : diameter_case config)
by now repeat split; trivial; setoid_rewrite H; repeat eexists; reflexivity
(* Equilateral case *)
- | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = ?pt1 :: ?pt2 :: ?pt3 :: nil,
+ | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = [?pt1; ?pt2; ?pt3],
H' : classify_triangle ?pt1 ?pt2 ?pt3 = Equilateral |- _ =>
assert (Hcase : equilateral_case config)
by now repeat split; trivial; setoid_rewrite H; repeat eexists; reflexivity || assumption
(* Triangle case *)
- | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = _ :: _ :: _ :: nil |- _ =>
+ | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = [_; _; _] |- _ =>
assert (Hcase : triangle_case config)
by now repeat split; trivial; setoid_rewrite H; repeat eexists; reflexivity
(* Generic case *)
@@ -448,7 +437,7 @@ assert (Hmax : forall x, In x (max (!! config)) <-> x = pt).
intro Hvalid.
assert (Hsuplen := WithMultiplicity.invalid_size eq_refl Hvalid).
destruct Hvalid as [Heven [? [pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
-assert (Hsup : Permutation (support (!! config)) (pt1 :: pt2 :: nil)).
+assert (Hsup : Permutation (support (!! config)) ([pt1; pt2])).
{ assert (Hin1 : InA equiv pt1 (support (!! config))).
{ rewrite support_spec. unfold In. changeR2. setoid_rewrite Hpt1. now apply Exp_prop.div2_not_R0. }
assert (Hin2 : InA equiv pt2 (support (!! config))).
@@ -464,7 +453,7 @@ assert (Hsup : Permutation (support (!! config)) (pt1 :: pt2 :: nil)).
+ rewrite <- PermutationA_Leibniz. now change eq with (@equiv location _).
+ inversion H2. }
assert (Hpt : pt = pt1 \/ pt = pt2).
-{ assert (Hin : List.In pt (pt1 :: pt2 :: nil)).
+{ assert (Hin : List.In pt ([pt1; pt2])).
{ rewrite <- Hsup, <- InA_Leibniz. change eq with (@equiv location _).
rewrite support_spec.
setoid_rewrite <- (max_subset (!! config)).
@@ -509,7 +498,7 @@ intro config. unfold no_Majority. split.
- exists x, x0; intuition. }
exists pt1, pt2.
split.
- * assert (hnodup:NoDupA equiv (pt1 :: pt2 :: nil)).
+ * assert (hnodup:NoDupA equiv ([pt1; pt2])).
{ rewrite <- Hsupp. apply support_NoDupA. }
intro abs.
subst.
@@ -526,7 +515,6 @@ intro config. unfold no_Majority. split.
(support (max (!! config)))
(support (!! config))
(support_NoDupA _)
- (support_NoDupA _)
h Hlen'').
assert (toto := cardinal_obs_from_config config origin).
rewrite <- plus_n_O in toto.
@@ -561,9 +549,7 @@ intro config. unfold no_Majority. split.
rewrite heq_config in toto.
rewrite cardinal_fold_elements in toto.
assert (fold_left (fun acc xn => snd xn + acc)
- ((pt1, (!! config)[pt1])
- :: (pt2, (!! config)[pt2])
- :: nil) 0
+ ([(pt1, (!! config)[pt1]); (pt2, (!! config)[pt2])]) 0
= nG).
{ rewrite <- toto.
eapply MMultiset.Preliminary.fold_left_symmetry_PermutationA with (eqA := eq_pair); autoclass.
@@ -696,13 +682,13 @@ Definition measure_dirty (s : observation) := nG - SECT_cardinal s.
Function measure (s : observation) : nat * nat :=
match support (max s) with
| nil => (0, 0) (* no robot *)
- | pt :: nil => (0, nG - s[pt]) (* majority *)
+ | [pt] => (0, nG - s[pt]) (* majority *)
| _ :: _ :: _ =>
match on_SEC (support s) with
- | nil | _ :: nil => (0, 0) (* impossible cases *)
- | pt1 :: pt2 :: nil => (* diameter case *)
+ | nil | [_] => (0, 0) (* impossible cases *)
+ | [pt1; pt2] => (* diameter case *)
if is_clean s then (1, measure_clean s) else (2, measure_dirty s)
- | pt1 :: pt2 :: pt3 :: nil => (* triangle case *)
+ | [pt1; pt2; pt3] => (* triangle case *)
if is_clean s then (3, measure_clean s) else (4, measure_dirty s)
| _ => (* general case *) if is_clean s then (5, measure_clean s) else (6, measure_dirty s)
end
@@ -763,8 +749,8 @@ Lemma target_triangle_morph:
Proof using .
intros sim pt1 pt2 pt3. unfold target_triangle.
rewrite classify_triangle_morph.
-destruct (classify_triangle pt1 pt2 pt3); simpl; auto.
-- apply isobarycenter_3_morph.
+destruct (classify_triangle pt1 pt2 pt3); cbn -[isobarycenter]; auto.
+- rewrite <- isobarycenter_sim_morph; auto; discriminate.
- apply opposite_of_max_side_morph.
Qed.
@@ -836,7 +822,7 @@ Qed.
(** **** The value of [target] in the various cases **)
Lemma diameter_target : forall config ptx pty,
- on_SEC (support (!! config)) = ptx :: pty :: nil ->
+ on_SEC (support (!! config)) = [ptx; pty] ->
target (!! config) = middle ptx pty.
Proof using .
intros config ptx pty HonSEC.
@@ -847,9 +833,9 @@ now rewrite HonSEC.
Qed.
Lemma equilateral_target : forall config ptx pty ptz,
- PermutationA equiv (on_SEC (support (!! config))) (ptx :: pty :: ptz :: nil) ->
+ PermutationA equiv (on_SEC (support (!! config))) ([ptx; pty; ptz]) ->
classify_triangle ptx pty ptz = Equilateral ->
- target (!! config) = isobarycenter_3_pts ptx pty ptz.
+ target (!! config) = isobarycenter ([ptx; pty; ptz]).
Proof using .
intros config ptx pty ptz Hperm Htriangle.
unfold target.
@@ -860,13 +846,13 @@ unfold target_triangle. now rewrite Htriangle.
Qed.
Lemma isosceles_target : forall config ptx pty ptz vertex,
- PermutationA equiv (on_SEC (support (!! config))) (ptx :: pty :: ptz :: nil) ->
+ PermutationA equiv (on_SEC (support (!! config))) ([ptx; pty; ptz]) ->
classify_triangle ptx pty ptz = Isosceles vertex ->
target (!! config) = vertex.
Proof using size_G.
intros config ptx pty ptz vertex Hsec Htriangle.
unfold target.
-assert (Hlen : length (on_SEC (support (!! config))) = length (ptx :: pty :: ptz :: nil))
+assert (Hlen : length (on_SEC (support (!! config))) = length ([ptx; pty; ptz]))
by (f_equiv; eassumption).
destruct (on_SEC (support (!! config))) as [| t [| t0 [| t1 [| t2 l]]]] eqn:Heq;
simpl in Hlen; try lia; [].
@@ -882,14 +868,14 @@ end.
Qed.
Lemma scalene_target : forall config ptx pty ptz,
- PermutationA equiv (on_SEC (support (!! config))) (ptx :: pty :: ptz :: nil) ->
+ PermutationA equiv (on_SEC (support (!! config))) ([ptx; pty; ptz]) ->
classify_triangle ptx pty ptz = Scalene ->
target (!! config) = opposite_of_max_side ptx pty ptz.
Proof using size_G.
intros config ptx pty ptz Hsec Htriangle.
remember (opposite_of_max_side ptx pty ptz) as vertex.
unfold target.
-assert (Hlen : length (on_SEC (support (!! config))) = length (ptx :: pty :: ptz :: nil))
+assert (Hlen : length (on_SEC (support (!! config))) = length ([ptx; pty; ptz]))
by (f_equiv; eassumption).
destruct (on_SEC (support (!! config))) as [| t [| t0 [| t1 [| t2 l]]]] eqn:Heq;
simpl in Hlen; try lia; [].
@@ -1061,13 +1047,13 @@ destruct (classify_triangle pt1 pt2 pt3) eqn:Htriangle.
+ rewrite classify_triangle_Isosceles_spec in Htriangle.
decompose [and or] Htriangle; subst; clear Htriangle;
match goal with |- InA equiv ?pt (support (!! config)) =>
- assert (Hin : InA equiv pt (pt1 :: pt2 :: pt3 :: nil)) by intuition;
+ assert (Hin : InA equiv pt ([pt1; pt2; pt3])) by intuition;
rewrite <- Hsec in Hin; unfold on_SEC in Hin; now rewrite filter_InA in Hin; autoclass
end.
+ unfold opposite_of_max_side. unfold Rle_bool.
do 2 match goal with |- context[Rle_dec ?x ?y] => destruct (Rle_dec x y) end;
match goal with |- InA equiv ?pt (support (!! config)) =>
- assert (Hin : InA equiv pt (pt1 :: pt2 :: pt3 :: nil)) by intuition;
+ assert (Hin : InA equiv pt ([pt1; pt2; pt3])) by intuition;
rewrite <- Hsec in Hin; unfold on_SEC in Hin; now rewrite filter_InA in Hin; autoclass
end.
Qed.
@@ -1084,7 +1070,7 @@ Theorem round_simplify : forall config,
then let s : observation := !! config in
match support (max s) with
| nil => config id (* only happen with no robots *)
- | pt :: nil => pt (* majority tower *)
+ | [pt] => pt (* majority tower *)
| _ => if is_clean s then target s else
if mem equiv_dec (get_location (config id)) (SECT s) then config id else target s
end
@@ -1271,10 +1257,9 @@ intros config pt. split.
rewrite moving_spec. intro Heq. apply Hroundid. now rewrite Heq. }
assert (Hstay : forall id, get_location (config id) == pt -> get_location (round gatherR2 da config id) == pt).
{ intros id' Hid'. destruct (get_location (round gatherR2 da config id') =?= pt) as [Heq | Heq]; trivial; [].
- assert (Habs : round gatherR2 da config id' =/= pt).
+ assert (Habs : get_location (round gatherR2 da config id') =/= pt).
{ intro Habs. apply Heq. now rewrite Habs. }
- rewrite <- Hid' in Habs. change (get_location (config id')) with (config id') in Habs.
- rewrite <- (moving_spec gatherR2) in Habs. apply Hdest in Habs. contradiction. }
+ rewrite <- Hid' in Habs. rewrite <- (moving_spec gatherR2) in Habs. apply Hdest in Habs. contradiction. }
setoid_rewrite WithMultiplicity.obs_from_config_spec.
do 2 rewrite config_list_spec.
assert (Hin : List.In id names) by apply In_names.
@@ -1317,7 +1302,7 @@ destruct (@increase_move gatherR2 config x) as [r_moving [Hdest_rmoving Hrmoving
- now contradiction Heq.
- unfold no_Majority. now rewrite size_spec.
- rewrite moving_spec. intro Habs. apply Hrmoving. now rewrite Habs.
- + assert ((support (max (!! config))) = x :: nil).
+ + assert ((support (max (!! config))) = [x]).
{ destruct (support (max (!! config))) as [| pt [| ? ?]] eqn:Heq'; cbv in Hlt; try lia.
+ now destruct (support_max_non_nil config).
+ get_case config.
@@ -1326,7 +1311,7 @@ destruct (@increase_move gatherR2 config x) as [r_moving [Hdest_rmoving Hrmoving
- now rewrite <- Hdest_rmoving.
- assert (H := pos_in_config config origin r_moving).
rewrite Hdest_rmoving in H. unfold In in H. lia. }
- assert (Hperm : PermutationA equiv (support (max (!! config))) (x :: nil)) by now rewrite H.
+ assert (Hperm : PermutationA equiv (support (max (!! config))) ([x])) by now rewrite H.
rewrite support_1 in Hperm.
destruct Hperm as [_ Hperm].
destruct (max_case (!! config) x); changeR2; lia.
@@ -1475,7 +1460,7 @@ do 2 rewrite config_list_spec.
induction names as [| id l]; simpl.
+ reflexivity.
+ changeR2. destruct (activate (proj_sim_da da) id); simpl.
- - R2dec_full; try contradiction; []. R2dec_full; try apply le_S; apply IHl.
+ - destruct_match; try contradiction; []. R2dec_full; try apply le_S; apply IHl.
- R2dec_full; try apply le_n_S; apply IHl.
Qed.
@@ -1505,12 +1490,11 @@ cut ((!! config)[target (!! config)] < (!! (round gatherR2 da config))[target (!
exists gmove. split.
- now apply destination_is_target.
- intro Habs. apply WithMultiplicity.no_info in Habs. revert Habs.
- change (round gatherR2 da config gmove =/= config gmove).
+ change (get_location (round gatherR2 da config gmove) =/= get_location (config gmove)).
now rewrite <- (moving_spec gatherR2).
Qed.
Opaque obs_from_config.
-(* Opaque R2_Setoid. *)
Lemma solve_measure_dirty : forall (config : configuration),
moving gatherR2 da config <> nil ->
@@ -1533,7 +1517,7 @@ assert (Hlt : (!! config)[target (!! config)] < (!! (round gatherR2 da config))[
exists gmove. split.
- now apply destination_is_target.
- intro Habs. apply WithMultiplicity.no_info in Habs. revert Habs.
- change (round gatherR2 da config gmove =/= config gmove).
+ change (get_location (round gatherR2 da config gmove) =/= get_location (config gmove)).
now rewrite <- (moving_spec gatherR2). }
unfold SECT_cardinal.
pose (f s x := if InA_dec equiv_dec x (SECT s) then true else false).
@@ -1547,8 +1531,6 @@ unfold f in Hext.
rewrite (filter_extensionality_compat _ _ Hext). clear Hext.
pose (f_target := fun x => if equiv_dec x (target (!! config)) then true else false).
pose (f_out_target := fun x => if InA_dec equiv_dec x (SECT (!! config)) then negb (f_target x) else false).
-(* assert (Proper (equiv ==> eq) f_target).
-{ intros ? ? Heq. simpl in Heq. subst. unfold f_target. R2dec_full. } *)
assert (Hext : forall x, f (!! config) x = f_target x || f_out_target x).
{ intro pt. unfold f, f_out_target, f_target. simpl. changeR2. repeat destruct_match; reflexivity. }
unfold f in Hext. setoid_rewrite (filter_extensionality_compat _ _ Hext). clear Hext f.
@@ -1560,8 +1542,8 @@ assert (Hdisjoint : forall m x, In x m -> f_target x && f_out_target x = false).
setoid_rewrite filter_disjoint_or_union; try (try (intros ? ? Heq; rewrite Heq); autoclass); [].
do 2 rewrite cardinal_union.
unfold f_target. setoid_rewrite cardinal_filter_is_multiplicity.
-assert (Heq : @equiv observation observation_Setoid (filter f_out_target (!! (round gatherR2 da config)))
- (filter f_out_target (!! config))).
+assert (Heq : equiv (filter f_out_target (!! (round gatherR2 da config)))
+ (filter f_out_target (!! config))).
{ intro pt. repeat rewrite filter_spec; try (now intros ? ? Heq; rewrite Heq); [].
destruct (f_out_target pt) eqn:Htest; trivial.
rewrite round_simplify_dirty; trivial. symmetry.
@@ -1657,24 +1639,23 @@ destruct (support (max (!! config))) as [| pt [| pt' l']] eqn:Hmaj.
- get_case config.
clear pt pt' l' Hmaj. rename Hmaj0 into Hmaj.
(* A robot has moved otherwise we have the same configuration before and it is invalid. *)
- assert (Hnil := no_moving_same_config gatherR2 da config).
- destruct (moving gatherR2 da config) as [| rmove l] eqn:Heq.
+ assert (Hnil := no_changing_same_config gatherR2 da config).
+ destruct (changing gatherR2 da config) as [| rmove l] eqn:Heq.
* now rewrite Hnil.
* intro Habs.
clear Hnil.
- assert (Hmove : List.In rmove (moving gatherR2 da config)). { rewrite Heq. now left. }
+ assert (Hmove : List.In rmove (moving gatherR2 da config)).
+ { change changing with moving in Heq. rewrite Heq. now left. }
rewrite moving_spec in Hmove.
(* the robot moves to one of the two locations in round robogram config *)
assert (Hinvalid := Habs). destruct Habs as [HnG [HsizeG[pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
assert (Hpt : exists pt pt', (pt = pt1 /\ pt' = pt2 \/ pt = pt2 /\ pt' = pt1)
/\ get_location (round gatherR2 da config rmove) == pt).
- { assert (Hperm : Permutation (support (!! (round gatherR2 da config))) (pt1 :: pt2 :: nil)).
+ { assert (Hperm : Permutation (support (!! (round gatherR2 da config))) ([pt1; pt2])).
{ symmetry. apply NoDup_Permutation_bis.
+ repeat constructor.
- intro Habs. inversion Habs. now contradiction Hdiff. now inversion H.
- intro Habs. now inversion Habs.
- (* NoDupA_Leibniz had a useless hyp in coq stdlib until april 2020. *)
- (* + rewrite <- NoDupA_Leibniz. change eq with (@equiv location _). apply support_NoDupA. *)
+ rewrite <- size_spec.
now setoid_rewrite <- WithMultiplicity.invalid_size.
+ intros pt Hpt. inversion_clear Hpt.
@@ -1682,7 +1663,7 @@ destruct (support (max (!! config))) as [| pt [| pt' l']] eqn:Hmaj.
unfold In. setoid_rewrite Hpt1. apply Exp_prop.div2_not_R0. apply HsizeG.
- inversion H; (now inversion H0) || subst. rewrite <- InA_Leibniz. change eq with (@equiv location _).
rewrite support_spec. unfold In. setoid_rewrite Hpt2. apply Exp_prop.div2_not_R0. apply HsizeG. }
- assert (Hpt : List.In (get_location (round gatherR2 da config rmove)) (pt1 :: pt2 :: nil)).
+ assert (Hpt : List.In (get_location (round gatherR2 da config rmove)) ([pt1; pt2])).
{ rewrite <- Hperm, <- InA_Leibniz. change eq with (@equiv location _).
rewrite support_spec. apply pos_in_config. }
inversion_clear Hpt; try (now exists pt1, pt2; eauto); [].
@@ -1730,31 +1711,17 @@ Qed.
(** *** Lemmas about the diameter case **)
-
Lemma diameter_clean_support : forall config ptx pty,
~WithMultiplicity.invalid config ->
no_Majority config ->
is_clean (!! config) = true ->
- on_SEC (support (!! config)) = ptx :: pty :: nil ->
- PermutationA equiv (support (!! config)) (middle ptx pty :: ptx :: pty :: nil).
+ on_SEC (support (!! config)) = [ptx; pty] ->
+ PermutationA equiv (support (!! config)) (middle ptx pty :: [ptx; pty]).
Proof using size_G.
intros config ptx pty Hinvalid hmax Hclean HonSEC.
assert (Htarget : target (!! config) = middle ptx pty) by (apply (diameter_target); auto).
apply (NoDupA_inclA_length_PermutationA _).
- apply support_NoDupA.
-- assert (Hdiff : ptx <> pty).
- { assert (Hnodup : NoDupA equiv (on_SEC (support (!! config)))).
- { unfold on_SEC in HonSEC.
- apply NoDupA_filter_compat; autoclass.
- apply support_NoDupA. }
- rewrite HonSEC in Hnodup.
- inversion Hnodup as [ | ? ? h1 h2]; subst.
- intro abs; subst.
- apply h1; now left. }
- constructor.
- + apply middle_diff.
- assumption.
- + rewrite <- HonSEC. apply on_SEC_NoDupA, support_NoDupA.
- intros x Hin.
rewrite is_clean_spec in Hclean. apply Hclean in Hin.
now rewrite <- Htarget, <- HonSEC.
@@ -1763,13 +1730,13 @@ Qed.
Lemma diameter_round_same : forall config ptx pty,
no_Majority (round gatherR2 da config) ->
- PermutationA equiv (support (!! config)) (middle ptx pty :: ptx :: pty :: nil) ->
+ PermutationA equiv (support (!! config)) (middle ptx pty :: [ptx; pty]) ->
PermutationA equiv (support (!! (round gatherR2 da config)))
- (middle ptx pty :: ptx :: pty :: nil).
+ (middle ptx pty :: [ptx; pty]).
Proof using Hssync.
intros config ptx pty Hmaj Hperm.
assert (Htarget : target (!! config) = middle ptx pty).
-{ assert (HonSEC : PermutationA equiv (on_SEC (support (!! config))) (ptx :: pty :: nil)).
+{ assert (HonSEC : PermutationA equiv (on_SEC (support (!! config))) ([ptx; pty])).
{ rewrite Hperm. rewrite on_SEC_middle_diameter, on_SEC_dueton; try reflexivity; [].
assert (Hnodup : NoDupA equiv (support (!! config))) by apply support_NoDupA.
rewrite Hperm in Hnodup. inversion_clear Hnodup. inversion_clear H0. intuition. }
@@ -1780,8 +1747,6 @@ assert (Htarget : target (!! config) = middle ptx pty).
- rewrite middle_comm. now apply diameter_target. }
apply (NoDupA_inclA_length_PermutationA _).
- apply support_NoDupA.
-- rewrite <- Hperm.
- apply support_NoDupA.
- assert (Hincl:= incl_next config).
rewrite Hperm in Hincl.
rewrite Htarget in Hincl.
@@ -1812,20 +1777,17 @@ assert (Hincl := incl_next config).
assert (Htarget : target (!!config) = middle ptx pty) by (apply diameter_target; auto).
assert (Hperm := @diameter_clean_support config ptx pty Hinvalid Hmaj Hclean Hsec).
assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
- (middle ptx pty :: ptx :: pty :: nil)).
+ (middle ptx pty :: [ptx; pty])).
{ apply (NoDupA_inclA_length_PermutationA _).
- apply support_NoDupA.
- - rewrite <- Hperm.
- apply support_NoDupA.
- apply (inclA_cons_InA _) with (middle ptx pty).
+ intuition.
+ rewrite <- Hperm, <- Htarget. apply Hincl.
- simpl length at 1. rewrite <- size_spec. now apply not_invalid_no_majority_size, never_invalid. }
-assert (HpermSEC' : PermutationA equiv (on_SEC (support (!! (round gatherR2 da config))))
- (ptx :: pty :: nil)).
+assert (HpermSEC' : PermutationA equiv (on_SEC (support (!! (round gatherR2 da config)))) ([ptx; pty])).
{ rewrite Hperm'. rewrite on_SEC_middle_diameter.
- now rewrite on_SEC_dueton.
- - assert (Hnodup : NoDupA equiv (middle ptx pty :: ptx :: pty :: nil)).
+ - assert (Hnodup : NoDupA equiv (middle ptx pty :: [ptx; pty])).
{ rewrite <- Hperm. apply support_NoDupA. }
inversion_clear Hnodup. inversion_clear H0. intuition. }
assert (Hlen : length (on_SEC (support (!! (round gatherR2 da config)))) = 2) by now rewrite HpermSEC'.
@@ -1840,7 +1802,7 @@ Lemma clean_diameter_next_maj_or_diameter : forall config ptx pty,
~WithMultiplicity.invalid config ->
no_Majority config ->
is_clean (!! config) = true ->
- on_SEC (support (!! config)) = ptx :: pty :: nil ->
+ on_SEC (support (!! config)) = [ptx; pty] ->
(exists pt, MajTower_at pt (round gatherR2 da config))
\/ no_Majority (round gatherR2 da config)
/\ PermutationA equiv (on_SEC (support (!! (round gatherR2 da config)))) (ptx :: pty :: nil).
@@ -1872,20 +1834,20 @@ Qed.
(** **** Lemmas about the equilateral triangle case **)
Lemma SEC_3_to_2: forall config ptx pty ptz bary pt ptdiam,
- InA equiv pt (ptx :: pty :: ptz :: nil) ->
- InA equiv ptdiam (ptx :: pty :: ptz :: nil) ->
+ InA equiv pt ([ptx; pty; ptz]) ->
+ InA equiv ptdiam ([ptx; pty; ptz]) ->
pt<> ptdiam ->
- PermutationA equiv (on_SEC (support (!! config))) (ptx :: pty :: ptz :: nil) ->
- PermutationA equiv (on_SEC (support (!! (round gatherR2 da config)))) (bary :: ptdiam :: nil) ->
+ PermutationA equiv (on_SEC (support (!! config))) ([ptx; pty; ptz]) ->
+ PermutationA equiv (on_SEC (support (!! (round gatherR2 da config)))) ([bary; ptdiam]) ->
classify_triangle ptx pty ptz = Equilateral ->
- bary == (isobarycenter_3_pts ptx pty ptz) ->
+ bary == isobarycenter ([ptx; pty; ptz]) ->
~ InA equiv pt (support (!! (round gatherR2 da config))).
Proof using .
intros config ptx pty ptz bary pt ptdiam hIn_pt hIn_ptdiam hneq_pt_ptdiam Hsec Hsec' Htriangle heq_bary.
intro abs.
-assert (h_bary:=@same_dist_vertex_notin_sub_circle ptdiam pt bary).
+assert (h_bary:=@same_dist_vertex_notin_sub_circle ptdiam pt bary).
-assert (h_radius_pt : radius (SEC (ptx :: pty :: ptz :: nil)) = dist bary pt).
+assert (h_radius_pt : radius (SEC ([ptx; pty; ptz])) = dist bary pt).
{ rewrite InA_Leibniz in hIn_pt.
simpl in hIn_pt.
decompose [or False] hIn_pt;subst.
@@ -1895,31 +1857,29 @@ assert (h_radius_pt : radius (SEC (ptx :: pty :: ptz :: nil)) = dist bary pt).
rewrite h_sec_xyz.
simpl.
reflexivity.
- - assert (hperm:PermutationA equiv (ptx :: pt :: ptz :: nil) (pt :: ptx :: ptz :: nil)) by permut_3_4.
+ - assert (hperm:PermutationA equiv ([ptx; pt; ptz]) ([pt; ptx; ptz])) by permut_3_4.
rewrite ?hperm in *.
generalize hperm; intro hperm'.
apply PermutationA_Leibniz in hperm'.
rewrite (classify_triangle_compat hperm') in Htriangle.
- rewrite (isobarycenter_3_pts_compat hperm') in heq_bary.
generalize (@equilateral_SEC _ _ _ Htriangle).
intro h_sec_xyz.
rewrite <- heq_bary in h_sec_xyz.
rewrite h_sec_xyz.
simpl.
reflexivity.
- - assert (hperm:PermutationA equiv (ptx :: pty :: pt :: nil) (pt :: ptx :: pty :: nil)) by permut_3_4.
+ - assert (hperm:PermutationA equiv ([ptx; pty; pt]) ([pt; ptx; pty])) by permut_3_4.
rewrite ?hperm in *.
generalize hperm;intro hperm'.
apply PermutationA_Leibniz in hperm'.
rewrite (classify_triangle_compat hperm') in Htriangle.
- rewrite (isobarycenter_3_pts_compat hperm') in heq_bary.
generalize (@equilateral_SEC _ _ _ Htriangle).
intro h_sec_xyz.
rewrite <- heq_bary in h_sec_xyz.
rewrite h_sec_xyz.
simpl.
reflexivity. }
-assert (h_radius_ptdiam : radius (SEC (ptx :: pty :: ptz :: nil)) = dist bary ptdiam).
+assert (h_radius_ptdiam : radius (SEC ([ptx; pty; ptz])) = dist bary ptdiam).
{ rewrite InA_Leibniz in hIn_ptdiam.
simpl in hIn_ptdiam.
decompose [or False] hIn_ptdiam;subst.
@@ -1929,24 +1889,22 @@ assert (h_radius_ptdiam : radius (SEC (ptx :: pty :: ptz :: nil)) = dist bary p
rewrite h_sec_xyz.
simpl.
reflexivity.
- - assert (hperm:PermutationA equiv (ptx :: ptdiam :: ptz :: nil) (ptdiam :: ptx :: ptz :: nil)) by permut_3_4.
+ - assert (hperm:PermutationA equiv ([ptx; ptdiam; ptz]) ([ptdiam; ptx; ptz])) by permut_3_4.
rewrite ?hperm in *.
generalize hperm;intro hperm'.
apply PermutationA_Leibniz in hperm'.
rewrite (classify_triangle_compat hperm') in Htriangle.
- rewrite (isobarycenter_3_pts_compat hperm') in heq_bary.
generalize (@equilateral_SEC _ _ _ Htriangle).
intro h_sec_xyz.
rewrite <- heq_bary in h_sec_xyz.
rewrite h_sec_xyz.
simpl.
reflexivity.
- - assert (hperm:PermutationA equiv (ptx :: pty :: ptdiam :: nil) (ptdiam :: ptx :: pty :: nil)) by permut_3_4.
+ - assert (hperm:PermutationA equiv ([ptx; pty; ptdiam]) ([ptdiam; ptx; pty])) by permut_3_4.
rewrite ?hperm in *.
generalize hperm;intro hperm'.
apply PermutationA_Leibniz in hperm'.
rewrite (classify_triangle_compat hperm') in Htriangle.
- rewrite (isobarycenter_3_pts_compat hperm') in heq_bary.
generalize (@equilateral_SEC _ _ _ Htriangle).
intro h_sec_xyz.
rewrite <- heq_bary in h_sec_xyz.
@@ -2058,80 +2016,47 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
assert (Hlen' : size (!! (round gatherR2 da config)) >= 3) by now apply not_invalid_no_majority_size.
destruct (classify_triangle ptx pty ptz) eqn:Htriangle.
+ (* Equilateral case *)
- assert (Htarget : target (!! config) = isobarycenter_3_pts ptx pty ptz) by now apply equilateral_target.
+ assert (Htarget : target (!! config) = isobarycenter ([ptx; pty; ptz])%list) by now apply equilateral_target.
assert (Hle := no_Majority_on_SEC_length Hmaj').
destruct (on_SEC (support (!! (round gatherR2 da config)))) as [| pt1 [| pt2 [| pt3 l]]] eqn:Hsec';
cbn in Hle; try lia.
- * (* Valid case: SEC is a pair *)
+ * (* Valid case: SEC is a pair after the round *)
destruct (is_clean (!! (round gatherR2 da config))) eqn:Hclean'.
-- (* Absurd case: the center of the SEC is not on a diameter *)
- exfalso.
+ exfalso.
clear Hle.
assert (Hcenter := on_SEC_pair_is_diameter _ Hsec').
assert (Hperm : PermutationA equiv (support (!! (round gatherR2 da config)))
- (middle pt1 pt2 :: pt1 :: pt2 :: nil)).
- { apply diameter_clean_support;auto. }
+ ([middle pt1 pt2; pt1; pt2])).
+ { apply diameter_clean_support; auto. }
destruct (is_clean (!! config)) eqn:Hclean.
** assert (Hincl : inclA equiv (support (!! (round gatherR2 da config)))
- (target (!! config) :: ptx :: pty :: ptz :: nil)).
+ (target (!! config) :: [ptx; pty; ptz])).
{ rewrite <- Hsec. now apply incl_clean_next. }
rewrite Hperm in Hincl.
- destruct (InA_dec equiv_dec (target(!! config)) (middle pt1 pt2 :: pt1 :: pt2 :: nil)) as [Hin | Hin].
+ destruct (InA_dec equiv_dec (target(!! config)) (middle pt1 pt2 :: [pt1; pt2])) as [Hin | Hin].
--- rewrite Htarget in Hin.
- assert (hNoDup:NoDupA equiv (pt1 :: pt2 :: nil)).
+ assert (hNoDup : NoDupA equiv ([pt1; pt2])).
{ rewrite <- Hsec'. apply on_SEC_NoDupA, support_NoDupA. }
- Opaque middle. Opaque isobarycenter_3_pts. cbn in Hin.
- { rewrite InA_Leibniz in Hin. simpl in Hin. decompose [or False] Hin; clear Hin.
- - rewrite H, Htarget in Hincl.
- eapply inclA_cons_inv in Hincl; autoclass; auto.
- + unfold inclA in Hincl.
- assert (hpt1:= Hincl pt1 (InA_cons_hd _ eq_refl)).
- assert (hpt2:= Hincl pt2 (InA_cons_tl pt1 (InA_cons_hd _ eq_refl))).
- rewrite InA_Leibniz in hpt1,hpt2.
-
- simpl in hpt1, hpt2;
- decompose [or False] hpt1;
- decompose [or False] hpt2;subst;clear hpt1; clear hpt2.
- * inv hNoDup. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
- * assert (heq:=middle_isobarycenter_3_neq Htriangle H).
- inversion hNoDup; subst. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
- * rewrite (@isobarycenter_3_pts_compat pt1 pty pt2 pt1 pt2 pty) in H; repeat econstructor.
- rewrite(@classify_triangle_compat pt1 pty pt2 pt1 pt2 pty) in Htriangle; repeat econstructor.
- assert (heq:=middle_isobarycenter_3_neq Htriangle H).
- inversion hNoDup; subst. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
- * rewrite (@isobarycenter_3_pts_compat pt2 pt1 ptz pt1 pt2 ptz) in H; repeat econstructor.
- rewrite(@classify_triangle_compat pt2 pt1 ptz pt1 pt2 ptz) in Htriangle; repeat econstructor.
- assert (heq:=middle_isobarycenter_3_neq Htriangle H).
- inversion hNoDup; subst. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
- * inv hNoDup. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
- * rewrite (@isobarycenter_3_pts_compat ptx pt1 pt2 pt1 pt2 ptx) in H.
- -- rewrite (@classify_triangle_compat ptx pt1 pt2 pt1 pt2 ptx) in Htriangle.
- ++ assert (heq:=middle_isobarycenter_3_neq Htriangle H).
- inversion hNoDup; subst. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
- ++ now do 3 econstructor.
- -- now do 3 econstructor.
- * rewrite (@isobarycenter_3_pts_compat pt2 pty pt1 pt1 pt2 pty) in H.
- -- rewrite (@classify_triangle_compat pt2 pty pt1 pt1 pt2 pty) in Htriangle.
- ++ assert (heq:=middle_isobarycenter_3_neq Htriangle H).
- inversion hNoDup; subst. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
- ++ now do 3 econstructor.
- -- now do 3 econstructor.
- * rewrite (@isobarycenter_3_pts_compat ptx pt2 pt1 pt1 pt2 ptx) in H.
- -- rewrite (@classify_triangle_compat ptx pt2 pt1 pt1 pt2 ptx) in Htriangle.
- ++ assert (heq:=middle_isobarycenter_3_neq Htriangle H).
- inversion hNoDup; subst. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
- ++ permut_3_4.
- -- econstructor 4 with (pt2 :: ptx :: pt1 :: nil); now do 3 econstructor.
- * inv hNoDup. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
- + rewrite <- H. apply middle_diff.
- inversion hNoDup; subst.
- intro abs; subst. match goal with | H: ~ InA _ _ _ |- _ => apply H end. now left.
+ Opaque middle.
+ { inv hNoDup. match goal with | H: ~ InA _ _ _ |- _ => apply H end. left.
+ rewrite 2 InA_cons, InA_singleton in Hin. decompose [or] Hin; clear Hin.
+ - (* Absurd case because distances do not match:
+ - dist corner (center of equilateral triangle) = sqrt(3)/2 * side
+ - dist to middle of a segment = side / 2
+ => these can only be equal if side = 0, that is, all corners coincide. *)
+ rewrite <- H, Htarget in Hincl.
+ assert (~ InA equiv (isobarycenter ([ptx; pty; ptz])) ([pt1; pt2])).
+ { assert (Hnodup := support_NoDupA (!! (round gatherR2 da config))).
+ rewrite Hperm in Hnodup. rewrite H. now inv Hnodup. }
+ eapply inclA_cons_inv in Hincl; autoclass; auto; [].
+ symmetry in H. revert H.
+ now apply middle_isobarycenter_3_neq.
- (* if (target (config)) is in (SEC (round config)) then two previously
SEC-towers have moved to (target (config)). therefore there are
- two tower => majority (or contradicting invalid). *)
-
- assert (Hin : List.In pt2 (ptx :: pty :: ptz :: nil)).
- { assert (Hin : List.In pt2 (target (!! config) :: ptx :: pty :: ptz :: nil)).
+ two tower => majority (or contradicting invalid). *)
+ assert (Hin : List.In pt2 ([ptx; pty; ptz])).
+ { assert (Hin : List.In pt2 (target (!! config) :: [ptx; pty; ptz])).
{ rewrite <- Hsec.
apply InA_Leibniz.
eapply incl_clean_next; auto; [].
@@ -2139,13 +2064,13 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
{ rewrite Hsec'. now right; left. }
rewrite InA_Leibniz in Hin |- *.
now apply on_SEC_In. }
- inversion Hin; trivial; [].
+ inversion Hin; trivial; []. subst.
exfalso.
- rewrite <- H0 in Htarget.
- rewrite Htarget in H.
- subst pt2; inv hNoDup; intuition. }
+ rewrite H0 in Htarget.
+ rewrite Htarget in H1.
+ intuition. }
unfold inclA in Hincl.
- assert (hmid:InA equiv (middle pt1 pt2) (middle pt1 pt2 :: pt1 :: pt2 :: nil)).
+ assert (hmid:InA equiv (middle pt1 pt2) (middle pt1 pt2 :: [pt1; pt2])).
{ left.
reflexivity. }
specialize (Hincl (middle pt1 pt2) hmid).
@@ -2154,62 +2079,37 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
lazy beta iota delta [List.In] in Hincl.
decompose [or False] Hincl;clear Hincl.
- + rewrite Htarget in H.
- rewrite <- H0 in H.
- apply (@middle_diff pt1 pt2).
- * intro abs. rewrite abs in hNoDup. inversion hNoDup.
- apply H3.
- left; reflexivity.
- * changeR2.
- rewrite <- H.
- simpl. auto.
+ + rewrite Htarget, H0 in H. symmetry in H.
+ rewrite <- middle_eq. apply H.
+ assert(ptx == pt2).
- { rewrite middle_comm in H1.
+ { rewrite middle_comm in H3.
eapply equilateral_isobarycenter_degenerated_gen
with (ptopp:=pt2) (mid:=ptx) (white:=pt1);eauto.
- left.
- reflexivity. }
+ now left. }
subst ptx.
- rewrite middle_comm in H.
- apply (middle_eq pt2 pt1) in H.
- rewrite H in hNoDup.
- inversion hNoDup.
- apply H3.
- left.
- reflexivity.
+ symmetry. rewrite <- middle_eq, middle_comm.
+ apply H.
+ assert(pty = pt2).
{ rewrite middle_comm in H.
eapply equilateral_isobarycenter_degenerated_gen
with (ptopp:=pt2) (mid:=pty) (white:=pt1);eauto.
- right;left.
- reflexivity. }
+ now right; left. }
subst pty.
- rewrite middle_comm in H1.
- rewrite (middle_eq pt2 pt1) in H1.
- rewrite H1 in hNoDup.
- inversion hNoDup.
+ symmetry. rewrite <- middle_eq, middle_comm.
apply H3.
- left.
- reflexivity.
+ assert(ptz = pt2).
- { rewrite middle_comm in H1.
+ { rewrite middle_comm in H3.
eapply equilateral_isobarycenter_degenerated_gen
- with (ptopp:=pt2) (mid:=ptz) (white:=pt1);eauto.
- right;right;left.
- reflexivity. }
+ with (ptopp:=pt2) (mid:=ptz) (white:=pt1); eauto.
+ now do 2 right; left. }
subst ptz.
- rewrite middle_comm in H.
- rewrite (middle_eq pt2 pt1) in H.
- rewrite H in hNoDup.
- inversion hNoDup.
- apply H3.
- left.
- reflexivity.
+ symmetry. rewrite <- middle_eq, middle_comm.
+ apply H.
- (* if (target (config)) is in (SEC (round config)) then two previously
SEC-towers have moved to (target (config)). therefore there are
two towers => majority (or contradicting invalid). *)
- assert (hIn:List.In pt1 (ptx :: pty :: ptz :: nil)).
- { assert (Hin:List.In pt1 (target (!! config) :: ptx :: pty :: ptz :: nil)).
+ assert (hIn:List.In pt1 ([ptx; pty; ptz])).
+ { assert (Hin:List.In pt1 (target (!! config) :: [ptx; pty; ptz])).
{ rewrite <- Hsec.
apply InA_Leibniz.
eapply incl_clean_next ;auto;[].
@@ -2221,74 +2121,52 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
assumption. }
inversion Hin;trivial;[].
exfalso.
- rewrite <- H in Htarget.
- rewrite Htarget in H0.
- subst pt2; inv hNoDup; intuition. }
+ rewrite H in Htarget.
+ rewrite Htarget in Hin.
+ subst pt1; intuition. }
lazy beta iota delta [inclA] in Hincl.
- assert (hmid:InA equiv (middle pt1 pt2) (middle pt1 pt2 :: pt1 :: pt2 :: nil)).
+ assert (hmid:InA equiv (middle pt1 pt2) (middle pt1 pt2 :: [pt1; pt2])).
{ left.
reflexivity. }
specialize (Hincl (middle pt1 pt2) hmid).
rewrite InA_Leibniz in Hincl.
lazy beta iota delta [List.In] in Hincl.
decompose [or False] Hincl;clear Hincl.
- + rewrite Htarget in H0.
- rewrite <- H in H0.
- apply (@middle_diff pt1 pt2).
- * intro abs. rewrite abs in hNoDup. inversion hNoDup.
- apply H3.
- left; reflexivity.
- * changeR2.
- rewrite <- H0.
- simpl. auto.
+ + rewrite Htarget in H.
+ rewrite H in H0.
+ symmetry. rewrite <- middle_eq, middle_comm.
+ apply H0.
+ assert(ptx = pt1).
{ eapply equilateral_isobarycenter_degenerated_gen
with (ptopp:=pt1) (mid:=ptx) (white:=pt2);eauto.
left.
reflexivity. }
subst ptx.
- rewrite (middle_eq pt1 pt2) in H0.
- rewrite H0 in hNoDup.
- inversion hNoDup.
- apply H3.
- left.
- reflexivity.
+ rewrite <- middle_eq.
+ apply H.
+ assert(pty = pt1).
{ eapply equilateral_isobarycenter_degenerated_gen
with (ptopp:=pt1) (mid:=pty) (white:=pt2);eauto.
right;left.
reflexivity. }
subst pty.
- rewrite (middle_eq pt1 pt2) in H1.
- rewrite H1 in hNoDup.
- inversion hNoDup.
+ rewrite <- middle_eq.
apply H3.
- left.
- reflexivity.
+ assert(ptz = pt1).
{ eapply equilateral_isobarycenter_degenerated_gen
with (ptopp:=pt1) (mid:=ptz) (white:=pt2);eauto.
right;right;left.
reflexivity. }
subst ptz.
- rewrite (middle_eq pt1 pt2) in H0.
- rewrite H0 in hNoDup.
- inversion hNoDup.
- apply H3.
- left.
- reflexivity. }
- --- (* (ptx :: pty :: ptz :: nil) = (middle pt1 pt2 :: pt1 :: pt2 :: nil)
+ rewrite <- middle_eq.
+ apply H. }
+ --- (* ([ptx; pty; ptz]) = (middle pt1 pt2 :: [pt1; pt2])
contradiction with calssify_triangle = equilateral *)
- assert (PermutationA equiv (ptx :: pty :: ptz :: nil) (middle pt1 pt2 :: pt1 :: pt2 :: nil)).
+ assert (PermutationA equiv ([ptx; pty; ptz]) (middle pt1 pt2 :: [pt1; pt2])).
{ apply inclA_skip in Hincl;autoclass.
- symmetry.
- Set Printing Depth 100.
- apply NoDupA_inclA_length_PermutationA with (1:=setoid_equiv);auto.
- + rewrite <- Hperm.
- apply support_NoDupA;auto.
- + rewrite <- Hsec.
- apply on_SEC_NoDupA;auto.
- apply support_NoDupA;auto. }
+ apply NoDupA_inclA_length_PermutationA with (1:=setoid_equiv);auto; [].
+ rewrite <- Hperm. apply support_NoDupA;auto. }
assert (classify_triangle (middle pt1 pt2) pt1 pt2 = Equilateral).
{ rewrite PermutationA_Leibniz in H. now rewrite (classify_triangle_compat H) in Htriangle. }
functional inversion H0. (*clear H0.*)
@@ -2299,7 +2177,7 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
{ changeR2.
lra. }
apply dist_defined in H3.
- assert (hNoDup:NoDupA equiv (pt1 :: pt2 :: nil)).
+ assert (hNoDup:NoDupA equiv ([pt1; pt2])).
{ rewrite <- Hsec'.
apply on_SEC_NoDupA.
apply support_NoDupA. }
@@ -2309,10 +2187,10 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
apply H6. left;reflexivity.
** rewrite <- dirty_next_on_SEC_same in Hsec;auto.
rewrite Hsec' in Hsec.
- assert (length (pt1 :: pt2 :: nil) = length (ptx :: pty :: ptz :: nil)).
+ assert (length ([pt1; pt2]) = length ([ptx; pty; ptz])).
{ rewrite Hsec.
reflexivity. }
- simpl in H;lia.
+ simpl in H; lia.
-- (* Valid case: the center of the SEC is not on a diameter *)
left. repeat split; trivial; eauto.
@@ -2333,8 +2211,7 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
{ eapply incl_clean_next ;eauto. }
rewrite Htarget in hincl_round.
rewrite Hsec in hincl_round.
- assert (h_incl_pt1_pt2 : inclA equiv (pt1 :: pt2 :: nil)
- (isobarycenter_3_pts ptx pty ptz :: ptx :: pty :: ptz :: nil)).
+ assert (h_incl_pt1_pt2 : inclA equiv ([pt1; pt2]) (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])).
{ transitivity (support (!! (round gatherR2 da config))).
- rewrite <- Hsec'.
unfold on_SEC.
@@ -2346,26 +2223,24 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
autoclass.
- assumption. }
- assert (hnodup: NoDupA equiv (pt1 :: pt2 :: nil)).
+ assert (hnodup: NoDupA equiv ([pt1; pt2])).
{ rewrite <- Hsec'.
apply on_SEC_NoDupA.
apply support_NoDupA. }
- assert (hnodupxyz: NoDupA equiv (ptx :: pty :: ptz :: nil)).
+ assert (hnodupxyz: NoDupA equiv ([ptx; pty; ptz])).
{ rewrite <- Hsec.
apply on_SEC_NoDupA.
apply support_NoDupA. }
inv_nodup hnodupxyz.
inv_nodup hnodup.
- (* simpl in H;lia. *)
- destruct (equiv_dec pt1 (isobarycenter_3_pts ptx pty ptz)) as [heq_pt1_bary | hneq_pt1_bary].
+ destruct (pt1 =?= (isobarycenter ([ptx; pty; ptz]))) as [heq_pt1_bary | hneq_pt1_bary].
++ { exfalso.
- assert(hpermut_config: PermutationA equiv (support (!! (round gatherR2 da config)))
- (pt1 :: pt2 :: nil)).
+ assert(hpermut_config: PermutationA equiv (support (!! (round gatherR2 da config))) ([pt1; pt2])).
{ rewrite heq_pt1_bary in heq2, h_incl_pt1_pt2.
apply inclA_cons_inv in h_incl_pt1_pt2; autoclass.
+ red in h_incl_pt1_pt2.
- assert (h_pt2:InA equiv pt2 (pt2 :: nil)).
+ assert (h_pt2:InA equiv pt2 ([pt2])).
{ left;reflexivity. }
specialize (h_incl_pt1_pt2 pt2 h_pt2).
clear h_pt2.
@@ -2373,8 +2248,8 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
(* pt2 = ptx *)
* unfold equiv, R2_Setoid in heq_pt2_ptx.
subst.
- assert (hpermut:PermutationA equiv (isobarycenter_3_pts ptx pty ptz :: ptx :: pty :: ptz :: nil)
- (pty :: ptz :: isobarycenter_3_pts ptx pty ptz :: ptx :: nil))
+ assert (hpermut:PermutationA equiv (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (pty :: ptz :: isobarycenter ([ptx; pty; ptz]) :: [ptx]))
by permut_3_4.
rewrite hpermut in hincl_round;clear hpermut.
assert (h_ynotin:~ InA equiv pty (support (!! (round gatherR2 da config)))).
@@ -2396,7 +2271,7 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
changeR2.
lia.
- * { (* InA equiv pt2 (pt2 :: nil) *)
+ * { (* InA equiv pt2 [pt2] *)
subst pt.
subst lpt.
inversion h_in_pt2_lpt
@@ -2404,8 +2279,8 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
(* pt2 = pty *)
* unfold equiv, R2_Setoid in heq_pt2_pty.
subst.
- assert (Hperm:PermutationA equiv (isobarycenter_3_pts ptx pty ptz :: ptx :: pty :: ptz :: nil)
- (ptx :: ptz :: isobarycenter_3_pts ptx pty ptz :: pty :: nil))
+ assert (Hperm:PermutationA equiv (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (ptx :: ptz :: isobarycenter ([ptx; pty; ptz]) :: [pty]))
by permut_3_4.
rewrite Hperm in hincl_round;clear Hperm.
assert (h_ynotin:~ InA equiv ptx (support (!! (round gatherR2 da config)))).
@@ -2419,7 +2294,7 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
apply inclA_skip in hincl_round;autoclass.
apply inclA_skip in hincl_round;autoclass.
apply NoDupA_inclA_length_PermutationA;autoclass.
- -- apply support_NoDupA.
+ -- apply support_NoDupA.
-- rewrite heq_pt1_bary.
assumption.
-- changeR2.
@@ -2439,8 +2314,8 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
* unfold equiv, R2_Setoid in heq_pt2_pty.
subst.
assert (Hperm : PermutationA equiv
- (isobarycenter_3_pts ptx pty ptz :: ptx :: pty :: ptz :: nil)
- (ptx :: pty :: isobarycenter_3_pts ptx pty ptz :: ptz :: nil))
+ (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (ptx :: pty :: isobarycenter ([ptx; pty; ptz]) :: [ptz]))
by permut_3_4.
rewrite Hperm in hincl_round;clear Hperm.
assert (h_ynotin:~ InA equiv ptx (support (!! (round gatherR2 da config)))).
@@ -2454,7 +2329,7 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
apply inclA_skip in hincl_round;autoclass.
apply inclA_skip in hincl_round;autoclass.
apply NoDupA_inclA_length_PermutationA;autoclass.
- -- apply support_NoDupA.
+ -- apply support_NoDupA.
-- now rewrite heq_pt1_bary.
--
transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
@@ -2470,16 +2345,15 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
rewrite hpermut_config in Hlen'.
simpl in Hlen'.
lia. }
- ++ { destruct (equiv_dec pt2 (isobarycenter_3_pts ptx pty ptz)) as [heq_pt2_bary | hneq_pt2_bary].
+ ++ { destruct (equiv_dec pt2 (isobarycenter ([ptx; pty; ptz]))) as [heq_pt2_bary | hneq_pt2_bary].
++ { exfalso.
- assert(hpermut_config: PermutationA equiv (support (!! (round gatherR2 da config)))
- (pt2 :: pt1 :: nil)).
- { assert (hpermut12:PermutationA equiv (pt1 :: pt2 :: nil) (pt2 :: pt1 :: nil)) by permut_3_4.
+ assert(hpermut_config: PermutationA equiv (support (!! (round gatherR2 da config))) ([pt2; pt1])).
+ { assert (hpermut12:PermutationA equiv ([pt1; pt2]) ([pt2; pt1])) by permut_3_4.
rewrite hpermut12 in h_incl_pt1_pt2.
rewrite heq_pt2_bary in heq2, h_incl_pt1_pt2.
apply inclA_cons_inv in h_incl_pt1_pt2;autoclass.
+ red in h_incl_pt1_pt2.
- assert (h_pt1:InA equiv pt1 (pt1 :: nil)).
+ assert (h_pt1:InA equiv pt1 ([pt1])).
{ left;reflexivity. }
specialize (h_incl_pt1_pt2 pt1 h_pt1).
clear h_pt1.
@@ -2489,8 +2363,8 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
* unfold equiv, R2_Setoid in heq_pt1_ptx.
subst ptx.
subst pt.
- assert (Hperm:PermutationA equiv (isobarycenter_3_pts pt1 pty ptz :: pt1 :: pty :: ptz :: nil)
- (pty :: ptz :: isobarycenter_3_pts pt1 pty ptz :: pt1 :: nil))
+ assert (Hperm:PermutationA equiv (isobarycenter ([pt1; pty; ptz]) :: [pt1; pty; ptz])
+ (pty :: ptz :: isobarycenter ([pt1; pty; ptz]) :: [pt1]))
by permut_3_4.
rewrite Hperm in hincl_round;clear Hperm.
assert (h_ynotin:~ InA equiv pty (support (!! (round gatherR2 da config)))).
@@ -2504,13 +2378,7 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
apply inclA_skip in hincl_round;autoclass.
apply inclA_skip in hincl_round;autoclass.
apply NoDupA_inclA_length_PermutationA;autoclass.
- -- apply support_NoDupA.
- -- repeat constructor.
- ++ intro Habs.
- inversion_clear Habs.
- ** congruence.
- ** now rewrite InA_nil in *.
- ++ now rewrite InA_nil.
+ -- apply support_NoDupA.
-- now rewrite heq_pt2_bary.
-- transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
++ now rewrite Hsec'.
@@ -2519,7 +2387,7 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
changeR2.
lia.
- * { (* InA equiv pt1 (pt1 :: nil) *)
+ * { (* InA equiv pt1 [pt1] *)
subst pt.
subst lpt.
inversion h_in_pt1_lpt as [pt lpt heq_pt1_pty [__h heq_lpt]
@@ -2528,8 +2396,8 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
* unfold equiv, R2_Setoid in heq_pt1_pty.
subst.
assert (Hperm : PermutationA equiv
- (isobarycenter_3_pts ptx pty ptz :: ptx :: pty :: ptz :: nil)
- (ptx :: ptz :: isobarycenter_3_pts ptx pty ptz :: pty :: nil))
+ (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (ptx :: ptz :: isobarycenter ([ptx; pty; ptz]) :: [pty]))
by permut_3_4.
rewrite Hperm in hincl_round;clear Hperm.
assert (h_xnotin:~ InA equiv ptx (support (!! (round gatherR2 da config)))).
@@ -2543,18 +2411,10 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
apply inclA_skip in hincl_round;autoclass.
apply inclA_skip in hincl_round;autoclass.
apply NoDupA_inclA_length_PermutationA;autoclass.
- -- apply support_NoDupA.
- -- repeat constructor.
- ++ intro Habs.
- inversion_clear Habs.
- ** congruence.
- ** now rewrite InA_nil in *.
- ++ now rewrite InA_nil.
- -- rewrite heq_pt2_bary.
- assumption.
+ -- apply support_NoDupA.
+ -- now rewrite heq_pt2_bary.
-- transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
- ++ rewrite Hsec'.
- reflexivity.
+ ++ now rewrite Hsec'.
++ unfold on_SEC.
rewrite filter_length.
changeR2.
@@ -2567,8 +2427,8 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
* unfold equiv, R2_Setoid in heq_pt1_ptz.
subst.
assert (hpermut : PermutationA equiv
- (isobarycenter_3_pts ptx pty ptz :: ptx :: pty :: ptz :: nil)
- (ptx :: pty :: isobarycenter_3_pts ptx pty ptz :: ptz :: nil))
+ (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (ptx :: pty :: isobarycenter ([ptx; pty; ptz]) :: [ptz]))
by permut_3_4.
rewrite hpermut in hincl_round;clear hpermut.
assert (h_xnotin:~ InA equiv ptx (support (!! (round gatherR2 da config)))).
@@ -2583,12 +2443,6 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
do 2 (apply inclA_skip in hincl_round; autoclass).
apply NoDupA_inclA_length_PermutationA; autoclass.
-- apply support_NoDupA.
- -- repeat constructor.
- ++ intro Habs.
- inversion_clear Habs.
- ** congruence.
- ** now rewrite InA_nil in *.
- ++ now rewrite InA_nil.
-- now rewrite heq_pt2_bary.
-- transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
++ rewrite Hsec'.
@@ -2630,9 +2484,9 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
(* TODO: the SEC has not changed *)
destruct (is_clean (!! config)) eqn:Hclean.
-- destruct (moving gatherR2 da config) as [| gmove ?] eqn:Hmoving.
- ++ apply no_moving_same_config in Hmoving. now rewrite Hmoving.
+ ++ change moving with changing in Hmoving. apply no_changing_same_config in Hmoving. now rewrite Hmoving.
++ assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
- (isobarycenter_3_pts ptx pty ptz :: ptx :: pty :: ptz :: nil)).
+ (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])).
{ assert ((!! (round gatherR2 da config))[target (!! config)] > 0).
{ apply Nat.le_lt_trans with ((!! config)[target (!! config)]); try lia.
rewrite increase_move_iff.
@@ -2646,10 +2500,6 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
apply hmoved_in. }
apply (NoDupA_inclA_length_PermutationA _).
- apply support_NoDupA.
- - apply equilateral_isobarycenter_NoDupA; trivial.
- assert (Hnodup : NoDupA equiv (on_SEC (support (!! config)))).
- { apply on_SEC_NoDupA, support_NoDupA. }
- rewrite Hsec in Hnodup. inversion Hnodup. intuition.
- rewrite <- Htarget, <- Hsec. now apply incl_clean_next.
- rewrite <- size_spec.
destruct (size (!! (round gatherR2 da config))) as [| [| [| [| ?]]]] eqn:Hlen; simpl; try lia.
@@ -2664,27 +2514,25 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
- unfold on_SEC. intro. rewrite (filter_InA _). intuition. }
subst.
assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
- (pt1 :: pt2 :: pt3 :: nil)).
+ ([pt1; pt2; pt3])).
{ symmetry.
apply (NoDupA_inclA_length_PermutationA _).
- rewrite <- Hsec'. apply on_SEC_NoDupA, support_NoDupA.
- - apply support_NoDupA.
- rewrite <- Hsec'. unfold on_SEC. intro. rewrite (filter_InA _). intuition.
- rewrite <- size_spec. rewrite Hlen. cbn. lia. }
rewrite <- Hsec' in Hperm'.
- (* Triangle equilatéral: comme qqchose bouge et que on est encore avec 3
- colonne après, une colonne s'est déplacée vers le barycentre, contradiction:
- le barycentre ne peut pas être sur le SEC. *)
- assert (Hnodup : NoDupA equiv (ptx :: pty :: ptz :: nil)).
+ (* Equilateral triangle: since one robot moves and there are still 3 columns afterwards,
+ a column moved to the barycenter, contradiction as the barycenter cannot be on the SEC. *)
+ assert (Hnodup : NoDupA equiv ([ptx; pty; ptz])).
{ rewrite <- Hsec. apply on_SEC_NoDupA, support_NoDupA. }
assert (Hex : exists pta ptb ptc,
- PermutationA equiv (pta :: ptb :: ptc :: nil) (ptx :: pty :: ptz :: nil)
- /\ PermutationA equiv (isobarycenter_3_pts ptx pty ptz :: pta :: ptb ::nil)
- (pt1 :: pt2 :: pt3 :: nil)).
- { assert (hincl:=incl_clean_next config Hclean).
+ PermutationA equiv ([pta; ptb; ptc]) ([ptx; pty; ptz])
+ /\ PermutationA equiv (isobarycenter ([ptx; pty; ptz]) :: [pta; ptb])
+ ([pt1; pt2; pt3])).
+ { assert (hincl:=incl_clean_next _ Hclean).
rewrite Hsec in hincl.
rewrite Hperm', Hsec' in hincl.
- assert (hbary : InA equiv (isobarycenter_3_pts ptx pty ptz)
+ assert (hbary : InA equiv (isobarycenter ([ptx; pty; ptz]))
(support (!! (round gatherR2 da config)))).
{ rewrite support_spec.
rewrite <- Htarget.
@@ -2697,19 +2545,19 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
destruct l as [| pta [| ptb [| ? ?]]]; simpl in Hlength; lia || clear Hlength.
inv_nodup Hnodup.
assert (Hnodup' := equilateral_isobarycenter_NoDupA _ Htriangle ltac:(auto)).
- assert (Hnodup123 : NoDupA equiv (pt1 :: pt2 :: pt3 :: nil)).
+ assert (Hnodup123 : NoDupA equiv ([pt1; pt2; pt3])).
{ rewrite <- Hsec'. apply on_SEC_NoDupA, support_NoDupA. }
inv_nodup Hnodup'.
rewrite hpermut_l in Hnodup123. inv_nodup Hnodup123.
- assert (Hpta : InA equiv pta (ptx :: pty :: ptz :: nil)).
+ assert (Hpta : InA equiv pta ([ptx; pty; ptz])).
{ rewrite hpermut_l, Htarget in hincl. apply (inclA_cons_inv _ h_notin4) in hincl.
apply hincl. now constructor. }
- assert (Hptb : InA equiv ptb (ptx :: pty :: ptz :: nil)).
+ assert (Hptb : InA equiv ptb ([ptx; pty; ptz])).
{ rewrite hpermut_l, Htarget in hincl. apply (inclA_cons_inv _ h_notin4) in hincl.
apply hincl. now do 2 constructor. }
rewrite InA_Leibniz in Hpta, Hptb. simpl in Hpta, Hptb.
exists pta, ptb.
- cut (exists ptc, PermutationA equiv (pta :: ptb :: ptc :: nil) (ptx :: pty :: ptz :: nil)).
+ cut (exists ptc, PermutationA equiv ([pta; ptb; ptc]) ([ptx; pty; ptz])).
- intros [ptc Hptc]. exists ptc. now split.
- decompose [or False] Hpta; decompose [or False] Hptb;
lazymatch goal with
@@ -2724,23 +2572,19 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
end; subst; permut_3_4. }
destruct Hex as [pta [ptb [ptc [Hpermxyz Hperm]]]].
pose (better_SEC := {| R2.center := middle pta ptb; radius := /2 * dist pta ptb |}).
-
- assert (Hbary_strict : (dist (isobarycenter_3_pts ptx pty ptz) (R2.center better_SEC)
+
+ assert (Hbary_strict : (dist (isobarycenter ([ptx; pty; ptz])) (R2.center better_SEC)
< radius better_SEC)%R).
- { rewrite PermutationA_Leibniz in Hpermxyz. rewrite <- (isobarycenter_3_pts_compat Hpermxyz).
- unfold better_SEC. simpl. repeat rewrite R2.norm_dist.
+ { rewrite PermutationA_Leibniz in Hpermxyz. rewrite <- Hpermxyz.
+ unfold better_SEC. cbn -[middle isobarycenter]. repeat rewrite R2.norm_dist.
pose (h:=@Barycenter_spec pta ptb ptc).
- Transparent isobarycenter_3_pts middle.
- unfold isobarycenter_3_pts, middle.
- Opaque isobarycenter_3_pts middle.
- replace (/ 3 * (pta + (ptb + ptc)) - 1 / 2 * (pta + ptb))%VS
+ rewrite isobarycenter_3_pts.
+ Transparent middle. unfold middle. Opaque middle.
+ replace (/ 3 * (pta + ptb + ptc) - 1 / 2 * (pta + ptb))%VS
with (/6 * (ptc + ptc - (pta + ptb)))%VS by (destruct pta, ptb, ptc; simpl; f_equal; field).
rewrite norm_mul. rewrite Rabs_pos_eq; try lra; [].
- repeat rewrite <- norm_dist.
- cut (dist (ptc + ptc) (pta + ptb) < 3 * dist pta ptb)%R.
- { changeR2. lra. }
-
-
+ repeat rewrite <- norm_dist.
+ cut (dist (ptc + ptc) (pta + ptb) < 3 * dist pta ptb)%R. { changeR2. lra. }
eapply Rle_lt_trans.
- apply (triang_ineq _ (ptc + pta)%VS).
- changeR2.
@@ -2761,20 +2605,14 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
contradiction. }
changeR2.
lra. }
- assert (enclosing_circle better_SEC (isobarycenter_3_pts ptx pty ptz :: pta :: ptb :: nil)).
+ assert (enclosing_circle better_SEC (isobarycenter ([ptx; pty; ptz]) :: [pta; ptb])).
{ intros pt hin.
simpl in hin.
+ unfold better_SEC. cbn [R2.center radius].
decompose [or False] hin;subst pt;clear hin.
- - apply Rlt_le.
- assumption.
- - unfold better_SEC ; simpl.
- rewrite R2dist_middle.
- reflexivity.
- - unfold better_SEC ; simpl.
- rewrite middle_comm.
- rewrite R2dist_middle.
- rewrite dist_sym.
- reflexivity. }
+ - now apply Rlt_le.
+ - now rewrite R2dist_middle.
+ - now rewrite middle_comm, R2dist_middle, dist_sym. }
assert (better_SEC = (SEC (support (!! (round gatherR2 da config))))).
{ rewrite PermutationA_Leibniz in Hperm',Hperm.
rewrite Hperm',Hsec',<-Hperm.
@@ -2783,7 +2621,7 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
- unfold better_SEC.
simpl.
apply SEC_min_radius; intuition. }
- absurd (on_circle better_SEC (isobarycenter_3_pts ptx pty ptz)=true).
+ absurd (on_circle better_SEC (isobarycenter ([ptx; pty; ptz])) = true).
+ rewrite on_circle_true_iff.
apply Rlt_not_eq.
assumption.
@@ -2811,9 +2649,10 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
right. split; trivial.
destruct (is_clean (!! config)) eqn:Hclean.
-- destruct (moving gatherR2 da config) as [| gmove ?] eqn:Hmoving.
- ++ apply no_moving_same_config in Hmoving. now rewrite Hmoving.
+ ++ change moving with changing in Hmoving.
+ apply no_changing_same_config in Hmoving. now rewrite Hmoving.
++ assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
- (ptx :: pty :: ptz :: nil)).
+ ([ptx; pty; ptz])).
{ assert (forall x, List.In x (gmove :: l) -> get_location (round gatherR2 da config x) == vertex).
{ rewrite <- Htarget.
intros x H3.
@@ -2821,16 +2660,13 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
rewrite Hmoving.
assumption. }
assert (h_vertex:=isoscele_vertex_is_vertex _ _ _ Htriangle).
- assert (H_supp: PermutationA equiv (support (!! config)) (ptx :: pty :: ptz :: nil)).
+ assert (H_supp: PermutationA equiv (support (!! config)) ([ptx; pty; ptz])).
{ rewrite is_clean_spec in Hclean.
unfold SECT in Hclean.
rewrite Hsec in Hclean.
apply inclA_cons_InA in Hclean;autoclass;auto.
- apply NoDupA_inclA_length_PermutationA;autoclass.
+ apply support_NoDupA;auto.
- + rewrite <- Hsec.
- apply on_SEC_NoDupA.
- apply support_NoDupA;auto.
+ transitivity (length (on_SEC (support (!! config)))).
-- rewrite Hsec.
reflexivity.
@@ -2843,18 +2679,14 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
apply NoDupA_inclA_length_PermutationA; autoclass.
- apply support_NoDupA.
- - rewrite <- Hsec.
- apply on_SEC_NoDupA, support_NoDupA.
- - transitivity (target (!! config) :: ptx :: pty :: ptz :: nil).
+ - transitivity (target (!! config) :: [ptx; pty; ptz]).
+ rewrite <- H_supp.
- apply incl_next.
+ now apply incl_next.
+ apply inclA_Leibniz.
apply incl_cons.
* rewrite Htarget.
- apply InA_Leibniz.
- assumption.
- * apply inclA_Leibniz.
- reflexivity.
+ now apply InA_Leibniz.
+ * now apply inclA_Leibniz.
- rewrite size_spec in Hlen'.
apply Hlen'. }
rewrite Hperm'.
@@ -2868,11 +2700,12 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
(* TODO: the SEC has not changed, same thing? *)
destruct (is_clean (!! config)) eqn:Hclean.
-- destruct (moving gatherR2 da config) as [| gmove ?] eqn:Hmoving.
- ++ apply no_moving_same_config in Hmoving. now rewrite Hmoving.
+ ++ change moving with changing in Hmoving.
+ apply no_changing_same_config in Hmoving. now rewrite Hmoving.
++
remember (opposite_of_max_side ptx pty ptz) as vertex.
assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
- (ptx :: pty :: ptz :: nil)).
+ ([ptx; pty; ptz])).
{ assert (forall x, List.In x (gmove :: l) -> get_location (round gatherR2 da config x) == vertex).
{ rewrite <- Htarget.
intros x H3.
@@ -2880,41 +2713,31 @@ destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eq
rewrite Hmoving.
assumption. }
assert (h_vertex:=scalene_vertex_is_vertex _ _ _ Htriangle).
- assert (H_supp: PermutationA equiv (support (!! config)) (ptx :: pty :: ptz :: nil)).
+ assert (H_supp: PermutationA equiv (support (!! config)) ([ptx; pty; ptz])).
{ rewrite is_clean_spec in Hclean.
unfold SECT in Hclean.
rewrite Hsec in Hclean.
apply inclA_cons_InA in Hclean;autoclass;auto.
- apply NoDupA_inclA_length_PermutationA;autoclass.
+ apply support_NoDupA;auto.
- + rewrite <- Hsec.
- apply on_SEC_NoDupA.
- apply support_NoDupA;auto.
+ transitivity (length (on_SEC (support (!! config)))).
- -- rewrite Hsec.
- reflexivity.
+ -- now rewrite Hsec.
-- unfold on_SEC.
rewrite filter_length.
changeR2. lia.
- - subst.
- rewrite Htarget.
- assumption. }
+ - subst. now rewrite Htarget. }
apply NoDupA_inclA_length_PermutationA; autoclass.
- apply support_NoDupA.
- - rewrite <- Hsec.
- apply on_SEC_NoDupA, support_NoDupA.
- - transitivity (target (!! config) :: ptx :: pty :: ptz :: nil).
+ - transitivity (target (!! config) :: [ptx; pty; ptz]).
+ rewrite <- H_supp.
- apply incl_next.
+ now apply incl_next.
+ apply inclA_Leibniz.
apply incl_cons.
* subst.
rewrite Htarget.
- apply InA_Leibniz.
- assumption.
- * apply inclA_Leibniz.
- reflexivity.
+ now apply InA_Leibniz.
+ * now apply inclA_Leibniz.
- rewrite size_spec in Hlen'.
apply Hlen'. }
rewrite Hperm'.
@@ -2975,7 +2798,7 @@ assert (Hneqid24 : id2 <> id4). { intro. subst id2. rewrite Hid2 in Hid4. contra
assert (Hneqid34 : id3 <> id4). { intro. subst id3. rewrite Hid3 in Hid4. contradiction. }
(* At most one of these robots was activated during the round *)
assert (Hex : forall id id',
- List.In id (id1 :: id2 :: id3 :: id4 :: nil) -> List.In id' (id1 :: id2 :: id3 :: id4 :: nil) ->
+ List.In id ([id1; id2; id3; id4]) -> List.In id' ([id1; id2; id3; id4]) ->
id <> id' -> da.(activate) id = true -> da.(activate) id' = false).
{ intros id id' Hid Hid' Hneq Hactive. simpl in *.
destruct (da.(activate) id') eqn:Hactive'; trivial; exfalso.
@@ -2984,9 +2807,9 @@ assert (Hex : forall id id',
rewrite ?Hid1, ?Hid2, ?Hid3, ?Hid4 in *; R2dec. }
(* Therefore, at least three were not activated and not on the target *)
assert (Hperm_id : exists id1' id2' id3' id4',
- Permutation (id1 :: id2 :: id3 :: id4 :: nil) (id1' :: id2' :: id3' :: id4' :: nil)
+ Permutation ([id1; id2; id3; id4]) ([id1'; id2'; id3'; id4'])
/\ da.(activate) id2' = false /\ da.(activate) id3' = false /\ da.(activate) id4' = false
- /\ NoDup (get_location (config id2') :: get_location (config id3') :: get_location (config id4') :: nil)
+ /\ NoDup ([get_location (config id2'); get_location (config id3'); get_location (config id4')])
/\ get_location (config id2') <> target (!!config)
/\ get_location (config id3') <> target (!!config)
/\ get_location (config id4') <> target (!!config)).
@@ -3039,15 +2862,15 @@ assert (Hperm_id : exists id1' id2' id3' id4',
++ exists id1, id2, id3, id4. rewrite <- Heq1. subst. repeat split; trivial; intuition; [].
repeat constructor; cbn in *; intuition.
++ destruct (get_location (config id2) =?= target (!! config)) as [Heq2 | Heq2].
- -- exists id2, id1, id3, id4. rewrite <- Heq2. subst.
- repeat split; trivial;
+ -- exists id2, id1, id3, id4. subst.
+ repeat split; trivial; try rewrite <- Heq2;
solve [repeat constructor; cbn in *; intuition | now do 3 econstructor].
-- destruct (get_location (config id3) =?= target (!! config)) as [Heq3 | Heq3].
- *** exists id3, id1, id2, id4. rewrite <- Heq3. subst.
- Time repeat split; trivial; (* 9 s.*)
+ *** exists id3, id1, id2, id4. subst.
+ repeat split; trivial; try rewrite <- Heq3;
solve [repeat constructor; cbn in *; intuition | now do 3 econstructor].
*** exists id4, id1, id2, id3. subst.
- Time repeat split; trivial; (* 11 s. *)
+ repeat split; trivial;
solve [repeat constructor; cbn in *; intuition | now do 4 econstructor]. }
(* Finally, the old and new SEC are defined by the unchanging locations of these three robots *)
destruct Hperm_id as [id1' [id2' [id3' [id4' [Hperm_id [Hactive2' [Hactive3' [Hactive4' [Hnodup [? [? ?]]]]]]]]]]].
@@ -3055,15 +2878,15 @@ apply three_points_same_circle
with (get_location (config id2')) (get_location (config id3')) (get_location (config id4')).
+ assumption.
+ eapply proj2. rewrite <- (filter_InA _).
- assert (Hin : List.In id2' (id1 :: id2 :: id3 :: id4 :: nil)) by (rewrite Hperm_id; intuition).
+ assert (Hin : List.In id2' ([id1; id2; id3; id4])) by (rewrite Hperm_id; intuition).
simpl in Hin. unfold on_SEC in Hperm'. rewrite Hperm'.
decompose [or] Hin; subst id2' || easy; clear Hin; rewrite Hactive2' in *; subst; intuition.
+ eapply proj2. rewrite <- (filter_InA _).
- assert (Hin : List.In id3' (id1 :: id2 :: id3 :: id4 :: nil)) by (rewrite Hperm_id; intuition).
+ assert (Hin : List.In id3' ([id1; id2; id3; id4])) by (rewrite Hperm_id; intuition).
simpl in Hin. unfold on_SEC in Hperm'. rewrite Hperm'.
decompose [or] Hin; subst id3' || easy; clear Hin; rewrite Hactive3' in *; subst; intuition.
+ eapply proj2. rewrite <- (filter_InA _).
- assert (Hin : List.In id4' (id1 :: id2 :: id3 :: id4 :: nil)) by (rewrite Hperm_id; intuition).
+ assert (Hin : List.In id4' ([id1; id2; id3; id4])) by (rewrite Hperm_id; intuition).
simpl in Hin. unfold on_SEC in Hperm'. rewrite Hperm'.
decompose [or] Hin; subst id4' || easy; clear Hin; rewrite Hactive4' in *; subst; intuition.
+ assert (Hin : InA equiv (get_location (config id2')) (support (!! config))).
@@ -3124,7 +2947,6 @@ Proof using Hssync.
{ apply moving_active in Hmove; trivial; []. now rewrite active_spec in Hmove. }
rewrite moving_spec in Hmove.
rewrite increase_move_iff. exists gmove.
- (* split; try (now intro; apply Hmove, no_info) ; []. *)
split;try now intro.
simpl.
get_case config.
@@ -3188,7 +3010,8 @@ Proof using Hssync.
destruct Hmax' as [? [? [? Hmax']]]. rewrite Hmax'.
assert (Hlen' : length (on_SEC (support (!! (round gatherR2 da config)))) = 3)
by now rewrite HpermSEC'.
- destruct (on_SEC (support (!! (round gatherR2 da config)))) as [| ? [| ? [| ? [| ? ?]]]] eqn:Hsec';
+ destruct (on_SEC (support (!! (round gatherR2 da config))))
+ as [| ? [| ? [| ? [| ? ?]]]] eqn:Hsec';
cbn in Hlen'; lia || clear Hlen'.
assert (Htarget' : target (!! (round gatherR2 da config)) = target (!! config)).
{ apply same_on_SEC_same_target. now rewrite Hsec, Hsec'. }
@@ -3252,7 +3075,7 @@ Proof using Type.
+ assert (no_Majority config). { unfold no_Majority. now rewrite size_spec. }
now repeat rewrite destination_is_target.
+ rewrite moving_spec in Hmove1, Hmove2.
- rewrite (round_simplify da hss _ id1) in Hmove1 |- *.
+ rewrite (round_simplify da hss _ id1) in Hmove1 |- *.
rewrite (round_simplify da' hss' _ id2) in Hmove2 |- *.
destruct (da.(activate) id1), (da'.(activate) id2);
try (now contradiction Hmove1 + contradiction Hmove2); [].
@@ -3349,7 +3172,8 @@ induction locallyfair as [d Hactive | d]; intros config Hvalid Hgathered Hmove H
simpl in Hactive. changeR2. rewrite Habs in Hactive. inv Hactive.
+ destruct (moving gatherR2 (Stream.hd d) config) eqn:Hnil.
- apply MoveLater; try exact Hnil; [].
- rewrite (no_moving_same_config _ _ _ Hnil).
+ change moving with changing in Hnil.
+ rewrite (no_changing_same_config _ _ _ Hnil).
destruct Hprop, Hssync, Hfair.
now apply IHlocallyfair.
- apply MoveNow. rewrite Hnil. discriminate.
@@ -3387,7 +3211,7 @@ cofix Hind. intros d config pt Hssync Hgather. constructor.
Qed.
(** The final theorem. *)
-Theorem Gathering_in_R2 : forall d, SSYNC (similarity_demon2demon d) -> Fair d -> WithMultiplicity.ValidSolGathering gatherR2 d.
+Theorem Gathering_in_R2 : forall d : similarity_demon, SSYNC (d : demon) -> Fair d -> WithMultiplicity.ValidSolGathering gatherR2 d.
Proof using .
intro d. generalize (similarity_demon2prop d).
generalize (similarity_demon2demon d). clear d.
@@ -3414,7 +3238,8 @@ destruct (gathered_at_dec config (get_location (config (Good g1)))) as [Hmove |
- now destruct Hfair.
- rewrite <- (demon2demon Hprop). now apply never_invalid.
+ (* Inductive case: we know by induction hypothesis that the wait will end *)
- apply no_moving_same_config in Heq.
+ change moving with changing in Heq.
+ apply no_changing_same_config in Heq.
apply Stream.Later. eapply Hrec.
- intros ? Hlt. apply Hind. eapply lt_config_compat; try eassumption; autoclass.
- now destruct Hssync.
@@ -3439,7 +3264,7 @@ Definition unfair_gathering r d config :=
robot can move, then some robot moves *)
Definition sim_da_with_all_activated da : similarity_da.
-Proof.
+Proof using .
exists (da_with_all_activated da).
apply (proj2_sig da).
Defined.
@@ -3458,7 +3283,7 @@ assert (Hall : List.In gmove (active (proj_sim_da (sim_da_with_all_activated da)
specialize (Hgmove (sim_da_with_all_activated da)
(FSYNC_SSYNC_da (da_with_all_activated_FSYNC_da da)) Hall).
rewrite moving_spec in Hgmove.
-intro Habs. apply no_moving_same_config in Habs. apply Hgmove, Habs.
+intro Habs. apply no_changing_same_config in Habs. apply Hgmove, Habs.
Qed.
Lemma unfair_gather_impl : forall d config,
@@ -3471,9 +3296,9 @@ coinduction cfsd.
Qed.
(* Final theorem for unfair demons. *)
-Theorem unfair_Gathering_in_R2 : forall d config,
- SSYNC (similarity_demon2demon d) ->
- unfair gatherR2 (similarity_demon2demon d) config ->
+Theorem unfair_Gathering_in_R2 : forall (d : similarity_demon) config,
+ SSYNC (d : demon) ->
+ unfair gatherR2 (d : demon) config ->
~WithMultiplicity.invalid config -> WillGather (execute gatherR2 d config).
Proof using .
intros d config Hssync Hunfair' Hvalid.
diff --git a/CaseStudies/Gathering/InR2/Algorithm_withLight.v b/CaseStudies/Gathering/InR2/Algorithm_withLight.v
new file mode 100644
index 0000000000000000000000000000000000000000..924ef899c4a0860bc58509f8185878d884628470
--- /dev/null
+++ b/CaseStudies/Gathering/InR2/Algorithm_withLight.v
@@ -0,0 +1,7102 @@
+(**************************************************************************)
+(* Mechanised Framework for Local Interactions & Distributed Algorithms *)
+(* P. Courtieu, L. Rieg, X. Urbain *)
+(* PACTOLE project *)
+(* *)
+(* This file is distributed under the terms of the CeCILL-C licence. *)
+(* *)
+(**************************************************************************)
+
+(**************************************************************************)
+(** 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 PeanoNat.
+Require Import Lia Field Lra.
+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 FunInd.
+Require Import FMapFacts.
+
+(* Pactole basic definitions *)
+Require Import Pactole.Util.SetoidDefs.
+Require Export Pactole.Setting.
+(* Specific to R^2 topology *)
+Require Import Pactole.Spaces.R2.
+(* Specific to gathering *)
+Require Import Pactole.CaseStudies.Gathering.WithMultiplicityLight.
+Require Import Pactole.CaseStudies.Gathering.Definitions.
+(* Specific to multiplicity *)
+Require Import Pactole.Observations.MultisetObservation.
+(* Specific to rigidity *)
+Require Import Pactole.Models.Rigid.
+(* Specific to settings with no Byzantine robots *)
+Require Import Pactole.Models.NoByzantine.
+
+(* User defined *)
+Import Permutation.
+Import ListNotations.
+
+Set Implicit Arguments.
+Close Scope R_scope.
+Close Scope VectorSpace_scope.
+
+Local Remove Hints pair_compat R2_Setoid R2_EqDec : typeclasses_instances.
+Remove Hints WithMultiplicityLight.St
+ FMapFacts.eq_key_Setoid
+ FMapFacts.eq_key_elt_Setoid : typeclass_instances.
+
+(* Local Existing Instance fst_compat_pactole. *)
+(* Local Existing Instance snd_compat_pactole. *)
+(* Local Existing Instance pair_compat_pactole. *)
+
+Local Declare Scope pactole_scope.
+
+(** * The Gathering Problem **)
+
+(** Vocabulary: we call a [location] the coordinate 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 three elements **)
+
+(* Require Import LibHyps.LibHyps.
+
+Local Open Scope autonaming_scope.
+
+
+(* Suppose I want to add later another naming rule: *)
+Ltac rename_hyp_1 n th :=
+ match th with
+ | @complement _ (@equiv _ _) ?x ?y => name(`_neqv` ++ x#n + y#n)
+ | @equiv _ _ => name(`_eqv` ++ x#n + y#n)
+ | @equiv _ _ ?x ?y => name(`_eqv` ++ x#n + y#n)
+ | obs_from_config ?x => name(`_obs` ++ x#n)
+ | multiplicity ?x _ => name(`_mult` ++ x#n)
+ end.
+
+Ltac rename_hyp ::= rename_hyp_1.
+Local Close Scope autonaming_scope.
+Ltac rename_depth ::= constr:(3).
+*)
+(* Rewriting tactics to handle Boolean expressions *)
+Global Hint Rewrite andb_true_iff andb_false_iff orb_true_iff orb_false_iff
+ negb_true_iff negb_false_iff eqb_true_iff eqb_false_iff
+ andb_true_r andb_false_r orb_true_r orb_false_r
+ equiv_decb_spec equiv_decb_false : reflect_bool.
+
+Ltac reflect_bool := autorewrite with reflect_bool in *.
+
+Global Hint Rewrite Bool.andb_true_r Bool.andb_false_r Bool.negb_involutive
+ Bool.orb_true_r Bool.orb_false_r @equiv_decb_refl : simpl_bool.
+
+Ltac simpl_bool := autorewrite with simpl_bool in *.
+
+
+Section GatheringInR2.
+
+(** Let [n] be an integer greater than 2. *)
+Variable n : nat.
+Hypothesis size_G : (3 <= 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.
+
+Lemma nG_ge: nG >= 3.
+Proof using size_G.
+ cbn.
+ lia.
+Qed.
+
+Lemma nG_nonzero: nG <> 0.
+Proof using size_G.
+ cbn.
+ lia.
+Qed.
+
+Lemma le_2_n : 2 <= nG + nB.
+Proof using size_G. cbn. lia. Qed.
+Hint Resolve le_2_n : core.
+
+Lemma n_gt_0 : Nat.div2 (nG + nB) > 0.
+Proof using size_G. apply Exp_prop.div2_not_R0. cbn. lia. Qed.
+
+Hint Immediate n_gt_0 le_2_n : core.
+
+(** Define one robot to get the location whenever they are gathered. *)
+Definition g1 : G.
+Proof using size_G. exists 0. generalize size_G; intro; abstract lia. Defined.
+
+Instance Lght: @WithMultiplicityLight.Lights.
+refine {|
+ L := bool;
+ L_Setoid := bool_Setoid;
+ L_EqDec := bool_EqDec;
+ witness := false;
+ l_list := true::false::nil;
+|}.
+- repeat constructor.
+ + intro abs.
+ inversion abs.
+ * discriminate.
+ * inversion H0.
+ + intro abs.
+ inversion abs.
+- abstract (intros li; destruct li;intuition).
+Defined.
+
+
+(* We are in a rigid formalism with no other info than the location, so the demon makes no choice. *)
+Instance Loc : Location := make_Location R2.
+Instance VS : RealVectorSpace location := R2_VS.
+Instance ES : EuclideanSpace location := R2_ES.
+Instance RobotChoice : robot_choice (location*L) :=
+ { robot_choice_Setoid := prod_Setoid location_Setoid L_Setoid }.
+Instance ActiveChoice : update_choice unit := NoChoice.
+Instance InactiveChoice : inactive_choice unit := { inactive_choice_EqDec := unit_eqdec }.
+(* Instance Info : State location := OnlyLocation (fun _ => True). *)
+
+(* true = white, false = black *)
+Instance St : State (location*L) := @WithMultiplicityLight.St _ Lght.
+
+Instance UpdFun : @update_function (location*L) Loc St MyRobots (location*bool)
+ (Similarity.similarity location) unit _ _ _ := {
+ update := fun _ _ _ target _ => target;
+ update_compat := ltac:(now repeat intro) }.
+
+Instance InaFun : inactive_function unit := {
+ inactive := fun config id _ => config id;
+ inactive_compat := ltac:(repeat intro; subst; auto) }.
+
+Instance Rigid : RigidSettingInfo.
+Proof using . split. reflexivity. Qed.
+
+(* Trying to avoid notation problem with implicit arguments *)
+Local Notation "s [ x ]" := (multiplicity x s) (at level 2, no associativity, format "s [ x ]"): pactole_scope.
+
+Existing Instance WithMultiplicityLight.Obs.
+
+Notation support := (@support location _ _ _).
+Notation Madd := (MMultisetInterface.add).
+
+Implicit Type config : configuration.
+Implicit Type da : similarity_da.
+Implicit Type d : similarity_demon.
+Arguments origin : simpl never.
+
+(* Refolding typeclass instances *)
+Ltac changeR2 :=
+ change R2 with location in *;
+ change R2_Setoid with location_Setoid in *;
+ change R2_EqDec with location_EqDec in *;
+ change R2_VS with VS in *;
+ change R2_ES with ES in *;
+ change bool with L in *;
+ fold St in *.
+
+Lemma config_list_alls : forall pt, config_list (fun _ => pt) = alls pt nG.
+Proof using .
+intro. rewrite config_list_spec, map_cst.
+rewrite names_length. simpl. now rewrite Nat.add_0_r.
+Qed.
+
+Lemma map_sim_support_fst : forall (f : Bijection.bijection location) (obs : observation (Observation := Obs)),
+ PermutationA (@equiv location _) (support (map f (fst obs))) (List.map f (support (fst obs))).
+Proof using .
+intros f s. apply map_injective_support.
+- intros ? ? Heq. now rewrite Heq.
+- apply Bijection.injective.
+Qed.
+
+Lemma map_sim_support :
+ forall (f : Bijection.bijection location) (s : (@observation _ _ _ _ multiset_observation)),
+ PermutationA (@equiv location _) (support (map f s)) (List.map f (support s)).
+Proof using .
+intros f s. apply map_injective_support.
+- intros ? ? Heq. now rewrite Heq.
+- apply Bijection.injective.
+Qed.
+
+
+Notation " '!!' config" :=
+ (@obs_from_config (location * L) _ St _ multiset_observation config (origin, witness)) (at level 10): pactole_scope.
+Notation " '!!!' '(' config ',' st ')'" :=
+ (@obs_from_config (location * L) _ St _ (@WithMultiplicityLight.Obs _ _ _) config st) (at level 10): pactole_scope.
+
+Local Open Scope pactole_scope.
+
+
+Definition is_black (c:configuration) id := get_light (c id) == false.
+Definition is_white (c:configuration) id := get_light (c id) == true.
+
+Definition all_are_white_in c l := Forall (is_white c) l.
+Definition all_are_black_in c l := Forall (is_black c) l.
+
+Definition all_are_white c := all_are_white_in c names.
+Definition all_are_black c := all_are_black_in c names.
+
+Definition all_active_are_white c da := all_are_white_in c (active da).
+Definition all_active_are_black c da := all_are_black_in c (active da).
+
+Lemma all_active_are_black_equiv : forall config da,
+ all_active_are_black config da <-> forall id, activate da id = true -> is_black config id.
+Proof using .
+intros config da.
+unfold all_active_are_black, all_are_black_in.
+rewrite Forall_forall. setoid_rewrite active_spec.
+reflexivity.
+Qed.
+
+Lemma black_white: forall c id, ~ is_black c id <-> is_white c id.
+Proof using .
+intros c id.
+split; intro h; destruct (get_light (c id)) eqn:heq; cbn in *; auto; intro; rewrite h in *; try discriminate.
+Qed.
+
+Lemma white_black: forall c id, ~ is_white c id <-> is_black c id.
+Proof using .
+intros c id.
+split;intro h; destruct (get_light (c id)) eqn:heq;
+cbn in *; auto; try (intro; rewrite h in *; try discriminate).
+elim h; auto.
+Qed.
+
+Lemma all_white_black: forall c l, Forall (fun x => ~ (is_black c x)) l <-> all_are_white_in c l.
+Proof using .
+ intros c l.
+ apply Forall_Permutation_compat;auto.
+ repeat intro.
+ rewrite H.
+ apply black_white.
+Qed.
+
+
+Lemma all_black_white: forall c l, Forall (fun x => ~ (is_white c x)) l <-> all_are_black_in c l.
+Proof using .
+ intros c l.
+ apply Forall_Permutation_compat;auto.
+ repeat intro.
+ rewrite H.
+ apply white_black.
+Qed.
+
+Lemma all_white_black_names: forall c, Forall (fun x => ~ (is_black c x)) names <-> all_are_white c.
+Proof using .
+ intros c.
+ apply all_white_black.
+Qed.
+
+Lemma all_black_white_names: forall c, Forall (fun x => ~ (is_white c x)) names <-> all_are_black c.
+Proof using .
+ intros c.
+ apply all_black_white.
+Qed.
+
+Lemma all_white_black_active : forall c da,
+ Forall (fun x => ~ (is_black c x)) (active da) <-> all_active_are_white c da.
+Proof using .
+ intros.
+ apply all_white_black.
+Qed.
+
+Lemma all_black_white_active : forall c da,
+ Forall (fun x => ~ (is_white c x)) (active da) <-> all_active_are_black c da.
+Proof using .
+ intros.
+ apply all_black_white.
+Qed.
+
+
+Lemma get_light_dec_1 c: forall x : ident, get_light (c x) == false \/ ~ get_light (c x) == false.
+Proof using .
+clear. intros x. cbn. destruct (get_light (c x)); intuition.
+Qed.
+
+Lemma get_light_dec_2 c: forall x : ident, get_light (c x) == true \/ ~ get_light (c x) == true.
+Proof using .
+clear. intros x. cbn. destruct (get_light (c x)); intuition.
+Qed.
+
+Lemma is_white_dec c: forall x : ident, is_white c x \/ ~ is_white c x.
+Proof using .
+ intros x.
+ unfold is_white.
+ destruct (get_light (c x));auto.
+ right.
+ intro abs; discriminate.
+Qed.
+
+Lemma is_black_dec c: forall x : ident, is_black c x \/ ~ is_black c x.
+Proof using .
+ intros x.
+ unfold is_black.
+ destruct (get_light (c x));auto.
+ right.
+ intro abs; discriminate.
+Qed.
+
+Definition is_white_b (c:configuration) x: bool := get_light (c x).
+Definition is_black_b (c:configuration) x: bool := negb (get_light (c x)).
+
+Lemma is_white_b_spec: forall c x, is_white_b c x == true <-> is_white c x.
+Proof using .
+ intros c x.
+ cbn.
+ reflexivity.
+Qed.
+
+Lemma is_black_b_spec: forall c x, is_black_b c x == true <-> is_black c x.
+Proof using .
+ intros c x.
+ cbn.
+ unfold is_black_b.
+ rewrite negb_true_iff.
+ reflexivity.
+Qed.
+
+Lemma get_location_dec: forall (c:configuration) x loc,
+ get_location (c x) == loc \/ ~ get_location (c x) == loc.
+Proof using .
+ intros c x loc.
+ destruct (equiv_dec (get_location (c x)) loc);auto.
+Qed.
+
+Lemma get_light_decidable (c:configuration) col :
+ forall id, { get_light (c id) == col } + { ~ (get_light (c id) == col) }.
+Proof using .
+ intros x. cbn. destruct (get_light (c x)).
+ destruct col;auto; try (right;intro abs; discriminate).
+ destruct col;auto; try (right;intro abs; discriminate).
+Defined.
+
+Lemma Forall_decidable_color (c:configuration) l col:
+ Decidable.decidable (Forall (fun id0 : ident => get_light (c id0) == col) l).
+Proof using .
+ red.
+ edestruct (Forall_dec (fun id0 : ident => get_light (c id0) == col) (get_light_decidable c col) l).
+ - left;auto.
+ - right;auto.
+Qed.
+
+Lemma Forall_decidable_black_in c l: Decidable.decidable (all_are_black_in c l).
+Proof using .
+ red.
+ apply Forall_decidable_color.
+Qed.
+
+Lemma Forall_decidable_white_in c l: Decidable.decidable (all_are_white_in c l).
+Proof using .
+ red.
+ apply Forall_decidable_color.
+Qed.
+
+Lemma Forall_decidable_black c: Decidable.decidable (all_are_black c).
+Proof using .
+ red.
+ apply Forall_decidable_color.
+Qed.
+
+Lemma Forall_decidable_white c: Decidable.decidable (all_are_white c).
+Proof using .
+ red.
+ apply Forall_decidable_color.
+Qed.
+
+
+Lemma Forall_decidable_active_color_black c l: Decidable.decidable (all_active_are_black c l).
+Proof using .
+ red.
+ apply Forall_decidable_color.
+Qed.
+
+
+Lemma Forall_decidable_active_color_white c l: Decidable.decidable (all_active_are_white c l).
+Proof using .
+ red.
+ apply Forall_decidable_color.
+Qed.
+
+Lemma not_and: forall A B: Prop,
+ Decidable.decidable A ->
+ ~ (A /\ B) <-> (~A \/ ~B).
+Proof using .
+ intros A B hdec.
+ split;intro h.
+ - apply Decidable.not_and;auto.
+ - intro abs.
+ destruct h,abs;contradiction.
+Qed.
+
+Hint Resolve Forall_decidable_black_in Forall_decidable_white_in
+ Forall_decidable_black Forall_decidable_white
+ Forall_decidable_active_color_black Forall_decidable_active_color_white: color_dec.
+
+Definition is_moving r da c id := List.In id (moving r da c).
+Definition is_stationary r da c id := List.In id (stationary r da c).
+
+Lemma is_moving_dec r da c id: is_moving r da c id \/ ~ is_moving r da c id.
+Proof using . destruct (moving_dec r da c id); intuition. Qed.
+
+Lemma is_stationary_dec r da c id: is_stationary r da c id \/ ~ is_stationary r da c id.
+Proof using . destruct (stationary_dec r da c id); intuition. Qed.
+
+Lemma stationary_moving: forall r da config id,
+ ~ is_moving r da config id -> is_stationary r da config id.
+Proof using .
+ intros r da config id H.
+ unfold is_moving , is_stationary , stationary, moving in *.
+ rewrite List.filter_In in *.
+ rewrite not_and in H.
+ destruct H.
+ { exfalso.
+ apply H.
+ apply In_names. }
+ split.
+ - apply In_names.
+ - destruct (get_location (round r da config id) ==b get_location (config id));auto.
+ - apply ListDec.In_decidable.
+ red.
+ intros x y.
+ red.
+ destruct (names_eq_dec x y); auto.
+Qed.
+
+Hint Resolve is_moving_dec is_stationary_dec: color_dec.
+
+Lemma bivalent_same_location_2 :
+ forall {Loc : Location} {Lght : Lights} {VS : RealVectorSpace location} {Hnames : Names} [config : configuration]
+ [pt1 pt2 pt3 : location] [id1 id2 id3],
+ bivalent config ->
+ get_location (config id1) = pt1 ->
+ get_location (config id2) = pt2 ->
+ get_location (config id3) = pt3 ->
+ pt1 =/= pt3 -> pt2 =/= pt3 -> pt1 == pt2.
+Proof using .
+ intros Loc0 Lght0 VS0 Hnames config pt1 pt2 pt3 id1 id2 id3 H H0 H1 H2 H3 H4.
+ repeat match goal with
+ | H: get_location (config ?id) = ?pt |- _ =>
+ let id' := fresh id in assert (exists id', get_location (config id') = pt) by eauto; clear H
+ end.
+
+ eapply bivalent_same_location with (1:=H);eauto.
+ - now apply obs_from_config_In with (pt:= (origin,witness)).
+ - now apply obs_from_config_In with (pt:= (origin,witness)).
+ - now apply obs_from_config_In with (pt:= (origin,witness)).
+Qed.
+
+Lemma mult_div2_In : forall config pt,
+ nG+nB > 1 ->
+ (!! config)[pt] = Nat.div2 (nG + nB) -> In pt (fst (!!! (config, (0%VS, witness)))).
+Proof using.
+ clear size_G.
+ intros config' pt hn H.
+ unfold In.
+ changeR2.
+ rewrite <- obs_fst.
+ changeR2.
+ rewrite H.
+ apply Exp_prop.div2_not_R0; auto.
+Qed.
+
+
+Definition count_if (pred: ident -> bool) := List.length (List.filter pred names).
+
+Definition sublist config (pred: (location*L) -> bool) :=
+ List.length (List.filter (fun id => pred (config id)) names).
+
+Definition bivalent_on config (pt1 pt2 : location) :=
+ nG + nB >= 2
+ /\ pt1 =/= pt2
+ /\ (forall id, (get_location (config id) = pt1 \/ get_location (config id) = pt2))
+ /\
+ count_if (fun id => get_location (config id) ==b pt1)
+ = count_if (fun id => get_location (config id) ==b pt2).
+
+
+Definition get_light_decb (c : configuration) (col: L) (id : ident) : bool:=
+ if get_light_decidable c col id then true else false.
+
+Definition color_bivalent_on config (pt1 pt2 : location) :=
+ bivalent_on config pt1 pt2 /\
+ forall col:L,
+ count_if (fun id => get_light_decb config col id && (get_location (config id) ==b pt1))
+ = count_if (fun id => get_light_decb config col id && (get_location (config id) ==b pt2)).
+
+Lemma count_if_multiplicity: forall config pt,
+ count_if (fun id : ident => get_location (config id) ==b pt) = ((!! config)[pt]).
+Proof using .
+ intros config pt.
+ unfold count_if.
+ setoid_rewrite (obs_from_config_fst_ok (origin,witness)(origin,witness)).
+ now rewrite obs_from_config_fst_spec, count_filter_length,
+ config_list_spec, map_map, filter_map, map_length.
+Qed.
+
+Lemma count_if_witness: forall (P:ident -> bool) (id:ident), P id = true -> count_if P > 0.
+Proof using.
+ clear size_G.
+ intros P id h_P_id.
+ unfold count_if.
+ destruct (List.filter P names) eqn:h_eq_filter.
+ { exfalso.
+ assert (List.In id (List.filter P names)) as h_In.
+ { apply List.filter_In.
+ split.
+ - apply In_names.
+ - assumption. }
+ rewrite h_eq_filter in h_In.
+ destruct h_In. }
+ cbn.
+ lia.
+Qed.
+
+Lemma bivalent_on_min: forall c pt1 pt2,
+ bivalent_on c pt1 pt2 ->
+ nG + nB >= 2.
+Proof using.
+ unfold bivalent_on.
+ intros c pt1 pt2 H.
+ apply H.
+Qed.
+
+(** A configuration with two towers containing the same numbers of robots. *)
+Lemma bivalent_iff config: bivalent config <-> exists pt1 pt2, bivalent_on config pt1 pt2.
+Proof using.
+ clear.
+ specialize nB_eq_0 as h_nB_0.
+ split.
+ - unfold bivalent_on.
+ intro Hbivalent.
+ remember Hbivalent as HBiv.
+ clear HeqHBiv.
+ red in Hbivalent.
+ (* decompose [ex and] Hbivalent /n; clear Hbivalent. *)
+ destruct Hbivalent as [ h_Even_add_nG_nB_
+ [ h_ge_add_nG_nB_2_
+ [ x [ x0 [ h_complement_equiv_location_Setoid_x_x0_
+ [ h_eq_mult_x_div2_add_ h_eq_mult_x0_div2_add_ ]]]]]].
+ exists x, x0.
+ repeat split.
+ + assumption.
+ + assumption.
+ + intros id.
+ destruct (get_location_dec config id x);auto.
+ destruct (get_location_dec config id x0);auto.
+ exfalso.
+ specialize (@bivalent_same_location_2 _ _ _ _ config x x0 (get_location (config id))) with (id3:=id) as h.
+ assert (0 < Nat.div2 (nG + nB)).
+ { apply Exp_prop.div2_not_R0. lia. }
+ assert (exists id1, get_location (config id1) == x) as h_ex_id1.
+ { now apply (obs_from_config_In config (origin,witness)), mult_div2_In. }
+ assert (exists id2, get_location (config id2) == x0) as h_ex_id2.
+ { now apply (obs_from_config_In config (origin,witness)), mult_div2_In. }
+ destruct h_ex_id1 as [id1 h_id1].
+ destruct h_ex_id2 as [id2 h_id2].
+ contradiction h_complement_equiv_location_Setoid_x_x0_.
+ apply (h id1 id2);auto.
+ + rewrite <- count_if_multiplicity in h_eq_mult_x_div2_add_,h_eq_mult_x0_div2_add_.
+ now rewrite h_eq_mult_x_div2_add_,h_eq_mult_x0_div2_add_.
+ - intro Hbivalent_on.
+ destruct Hbivalent_on as [x [x0 Hbivalent_on]].
+ assert (Hbivalent_on' := Hbivalent_on).
+ unfold bivalent_on in Hbivalent_on.
+ (* decompose [and ex] Hbivalent_on /n; clear Hbivalent_on. *)
+ destruct Hbivalent_on as [ h_ge_add_nG_nB_2_
+ [ h_complement_equiv_R2_Setoid_x_x0_
+ [ h_all_or_eq_eq_ h_eq_count_if_count_if_ ]]].
+ match type of h_eq_count_if_count_if_ with
+ count_if (fun id => ?a ==b ?b) = _ =>
+ set (is_notlocx := (fun id : ident => negb (a ==b b))) in *
+ end.
+ match type of h_eq_count_if_count_if_ with
+ _ = count_if (fun id => ?a' ==b ?b') =>
+ set (is_notlocx0 := (fun id : ident => negb (a' ==b b'))) in *
+ end.
+ match type of h_eq_count_if_count_if_ with
+ count_if ?f = count_if ?g => set (is_locx := f) in *; set (is_locx0 := g) in *
+ end.
+
+ assert (forall x1 : ident, is_notlocx x1 = true -> is_locx0 x1 = true) as h_biv.
+ { intros x1 h.
+ destruct (h_all_or_eq_eq_ x1) as [h'|h'];auto.
+ - unfold is_notlocx in h.
+ reflect_bool.
+ contradiction.
+ - unfold is_locx0. now reflect_bool. }
+ assert (forall x1 : ident, is_locx0 x1 = true -> is_notlocx x1 = true).
+ { intros x1 h.
+ destruct (h_all_or_eq_eq_ x1) as [h'|h'];auto.
+ - unfold is_locx0 in h. reflect_bool. subst. contradiction.
+ - unfold is_locx0 in *. unfold is_notlocx. reflect_bool.
+ now rewrite h'. }
+
+ assert (PermutationA equiv names (List.filter is_locx names ++ (List.filter is_notlocx names))) as h_permut.
+ { transitivity ((fst (List.partition is_locx names) ++ snd (List.partition is_locx names))).
+ - symmetry.
+ apply partition_PermutationA.
+ - apply eqlistA_PermutationA.
+ apply eqlistA_app; try typeclasses eauto.
+ * rewrite Preliminary.partition_filter.
+ reflexivity.
+ * rewrite Preliminary.partition_filter.
+ reflexivity. }
+
+ assert (PermutationA equiv (List.filter is_notlocx names)
+ (List.filter is_locx0 (List.filter is_notlocx names)
+ ++ (List.filter is_notlocx0 (List.filter is_notlocx names)))) as h_permut_nest.
+ { transitivity ((fst (List.partition is_locx0 (List.filter is_notlocx names))
+ ++ snd (List.partition is_locx0 (List.filter is_notlocx names)))).
+ - symmetry.
+ apply partition_PermutationA.
+ - apply eqlistA_PermutationA.
+ apply eqlistA_app; try typeclasses eauto.
+ * rewrite Preliminary.partition_filter.
+ reflexivity.
+ * rewrite Preliminary.partition_filter.
+ reflexivity. }
+
+ assert ((List.filter is_notlocx0 (List.filter is_notlocx names)) = nil) as h_nil.
+ { destruct (List.filter is_notlocx0 (List.filter is_notlocx names)) eqn:heq;auto.
+ exfalso.
+ assert (InA equiv i (List.filter is_notlocx0 (List.filter is_notlocx names))) as h.
+ { rewrite heq.
+ apply InA_cons_hd;auto. }
+ rewrite filter_InA in h.
+ destruct h as [h_in h_isnotloc_x0].
+ rewrite filter_InA in h_in.
+ destruct h_in as [ _ h_isnotloc_x].
+ destruct (h_all_or_eq_eq_ i).
+ - unfold is_notlocx in h_isnotloc_x.
+ rewrite negb_true_iff,R2dec_bool_false_iff in h_isnotloc_x.
+ contradiction.
+ - unfold is_notlocx0 in h_isnotloc_x0.
+ rewrite negb_true_iff,R2dec_bool_false_iff in h_isnotloc_x0.
+ contradiction.
+ - typeclasses eauto.
+ - typeclasses eauto. }
+ assert ((!! config)[x] = (!! config)[x0]) as h_mult_eq.
+ { unfold is_locx in h_eq_count_if_count_if_.
+ rewrite count_if_multiplicity in h_eq_count_if_count_if_.
+ unfold is_locx0 in h_eq_count_if_count_if_.
+ rewrite count_if_multiplicity in h_eq_count_if_count_if_.
+ assumption. }
+
+ rewrite h_permut_nest in h_permut.
+ rewrite h_nil in h_permut.
+ clear h_nil h_permut_nest.
+ rewrite app_nil_r in h_permut.
+ apply PermutationA_length in h_permut.
+ rewrite names_length in h_permut.
+ rewrite app_length in h_permut.
+ rewrite ListComplements.filter_comm in h_permut.
+ rewrite filter_weakened in h_permut;auto.
+
+ red.
+ repeat split.
+ + unfold count_if in h_eq_count_if_count_if_.
+ rewrite h_eq_count_if_count_if_ in h_permut.
+ rewrite h_permut.
+ red.
+ exists (length (List.filter is_locx0 names));lia.
+ + eapply bivalent_on_min;eauto.
+ + changeR2.
+ exists x, x0.
+ rewrite <- h_mult_eq.
+ rewrite <- count_if_multiplicity.
+ fold is_locx.
+ unfold count_if.
+
+ repeat split.
+ * assumption.
+ * unfold count_if in h_eq_count_if_count_if_.
+ rewrite <- h_eq_count_if_count_if_ in h_permut.
+ rewrite h_permut.
+ match goal with
+ |- _ = Nat.div2 (?a + ?a) => replace (a + a) with (2 * a)
+ end.
+ -- now rewrite Nat.div2_double.
+ -- lia.
+ * unfold count_if in h_eq_count_if_count_if_.
+ rewrite <- h_eq_count_if_count_if_ in h_permut.
+ rewrite h_permut.
+ match goal with
+ |- _ = Nat.div2 (?a + ?a) => replace (a + a) with (2 * a)
+ end.
+ -- now rewrite Nat.div2_double.
+ -- lia.
+Qed.
+
+Lemma bivalent_exists_opposite_id:
+ forall (c:@configuration Loc (prod (@location Loc) (@L Lght)) St MyRobots) (id:ident),
+ bivalent c -> exists id', get_location (c id') <> get_location (c id).
+Proof using .
+ clear.
+ intros c id Hcolor.
+ apply bivalent_iff in Hcolor.
+ unfold bivalent_on in Hcolor.
+ destruct Hcolor as [pt1 [pt2 [ h_n [h_neq [h1 h2]]]]].
+ specialize (h1 id).
+ destruct h1 as [h1 | h1].
+ - assert (count_if (fun id : ident => get_location (c id) ==b pt2) > 0) as h_count_lt.
+ { rewrite <- h2.
+ apply count_if_witness with id.
+ now apply equiv_decb_spec. }
+ unfold count_if in h_count_lt.
+ destruct (List.filter (fun id : ident => get_location (c id) ==b pt2) names) eqn:h_eq_filter.
+ { exfalso.
+ inversion h_count_lt. }
+ assert (List.In i (List.filter (fun id : ident => get_location (c id) ==b pt2) names)) as h_In.
+ { rewrite h_eq_filter.
+ now constructor. }
+ exists i.
+ apply List.filter_In in h_In.
+ destruct h_In as [h_In h_i_pt2].
+ rewrite equiv_decb_spec in h_i_pt2.
+ rewrite h_i_pt2,h1.
+ symmetry in h_neq.
+ assumption.
+ - assert (count_if (fun id : ident => get_location (c id) ==b pt1) > 0) as h_count_lt.
+ { rewrite h2.
+ apply count_if_witness with id.
+ now apply equiv_decb_spec. }
+ unfold count_if in h_count_lt.
+ destruct (List.filter (fun id : ident => get_location (c id) ==b pt1) names) eqn:h_eq_filter.
+ { exfalso.
+ inversion h_count_lt. }
+ assert (List.In i (List.filter (fun id : ident => get_location (c id) ==b pt1) names)) as h_In.
+ { rewrite h_eq_filter.
+ now constructor. }
+ exists i.
+ apply List.filter_In in h_In.
+ destruct h_In as [h_In h_i_pt1].
+ rewrite equiv_decb_spec in h_i_pt1.
+ rewrite h_i_pt1,h1.
+ assumption.
+Qed.
+
+Lemma count_if_multiplicity_light: forall (config:configuration) (a:location) (col:L) ,
+ count_if (fun id : ident => get_light_decb config col id && R2dec_bool (get_location (config id)) a)
+ = (colors (snd (obs_from_config config (0%VS, witness))))[(a, col)].
+Proof using .
+ changeR2.
+ intros config a col.
+ unfold count_if.
+ unshelve setoid_rewrite obs_from_ok.
+ changeR2.
+ cbn [snd].
+
+ specialize obs_from_config_spec.
+ intros h.
+ cbn -[names equiv equiv_dec get_location config_list] in h.
+ specialize (h config (a,col)).
+ destruct h as [h1 [h2 h3]].
+ changeR2.
+ rewrite h3.
+ rewrite count_filter_length.
+ rewrite config_list_spec.
+ rewrite filter_map.
+ rewrite map_length.
+ f_equal.
+ apply filter_ext.
+ intros a0.
+ unfold R2dec_bool.
+ unfold get_light_decb.
+ repeat destruct_match;auto; cbn in *; intuition.
+Qed.
+
+(** Observations can never be empty as the number of robots is non null. *)
+
+Lemma obs_non_nil : forall config, !! config =/= empty.
+Proof using size_G.
+ intros.
+ changeR2.
+ apply WithMultiplicityLight.obs_non_nil with (st:=(origin,witness)).
+ auto with arith.
+Qed.
+
+Lemma support_non_nil : forall config, support (!!config) <> nil.
+Proof using size_G.
+ intros config Habs.
+ rewrite support_nil in Habs.
+ eapply obs_non_nil.
+ eassumption.
+Qed.
+
+Lemma support_max_non_nil : forall config, support (max (!!(config))) <> nil.
+Proof using size_G.
+ intros config Habs.
+ rewrite support_nil, max_is_empty in Habs.
+ eapply (obs_non_nil _ Habs).
+Qed.
+
+Lemma max_morph : forall (f : Bijection.bijection location) s, max (map f s) == map f (max s).
+Proof using .
+intros f s. apply max_map_injective.
+- intros ? ? Heq. now rewrite Heq.
+- apply Bijection.injective.
+Qed.
+
+Lemma multiplicity_le_nG : forall pt config, (!!(config))[pt] <= nG.
+Proof using size_G.
+intros pt config. etransitivity.
+- apply cardinal_lower.
+- rewrite cardinal_obs_from_config.
+ simpl.
+ lia.
+Qed.
+
+Lemma obs_from_ok: forall config st, (!!!(config,st)) == (!! config, snd (!!!(config,st))).
+Proof using .
+ intros config st.
+ specialize (obs_from_config_ignore_snd_except_observerlight st config st) as h.
+ lazy zeta in h.
+ setoid_rewrite h.
+ reflexivity.
+Qed.
+
+
+
+(** ** Definition of the robogram **)
+
+Open Scope R_scope.
+
+Section Target.
+
+Local Existing Instance multiset_observation.
+Typeclasses eauto := (bfs).
+
+(** The target in the triangle case. *)
+(* TODO: replace [isobarycenter_3_pts] with the general [isobarycenter]. *)
+Definition target_triangle (pt1 pt2 pt3 : location) : location :=
+ let typ := classify_triangle pt1 pt2 pt3 in
+ match typ with
+ | Equilateral => isobarycenter ([pt1; pt2; pt3])%list
+ | Isosceles p => p
+ | Scalene => opposite_of_max_side pt1 pt2 pt3
+ end.
+
+Lemma target_triangle_compat : forall pt1 pt2 pt3 pt1' pt2' pt3',
+ Permutation ([pt1; pt2; pt3]) ([pt1'; pt2'; pt3']) ->
+ target_triangle pt1 pt2 pt3 == target_triangle pt1' pt2' pt3'.
+Proof using .
+intros pt1 pt2 pt3 pt1' pt2' pt3' hpermut.
+generalize (classify_triangle_compat hpermut).
+intro h_classify.
+unfold target_triangle.
+rewrite h_classify.
+destruct_match.
+- now rewrite hpermut.
+- reflexivity.
+- apply opposite_of_max_side_compat; auto.
+Qed.
+
+
+(** A function computing the target location of robots.
+ Safe to use only when there is no majority tower. *)
+Definition target (s : observation) : location :=
+ let l := support s in
+ match on_SEC l with
+ | nil => (0, 0) (* no robot *)
+ | [pt] => pt (* gathered *)
+ | [pt1; pt2; pt3] => (* triangle cases *)
+ target_triangle pt1 pt2 pt3
+ | _ => (* general case *) R2.center (SEC l)
+ end.
+
+Typeclasses eauto := (dfs).
+Instance target_compat : Proper (equiv ==> Logic.eq) target.
+Proof using size_G.
+intros s1 s2 Hs. unfold target.
+assert (Hperm : Permutation (on_SEC (support s1)) (on_SEC (support s2))).
+{ now rewrite <- PermutationA_Leibniz, Hs. }
+destruct (on_SEC (support s1)) as [| a1 [| a2 [| a3 [| ? ?]]]] eqn:Hs1.
++ apply Permutation_nil in Hperm. now rewrite Hperm.
++ apply Permutation_length_1_inv in Hperm. now rewrite Hperm.
++ apply Permutation_length_2_inv in Hperm.
+ destruct Hperm as [Hperm | Hperm].
+ * rewrite Hperm. now rewrite Hs.
+ * rewrite Hperm. now rewrite Hs.
++ assert (length (on_SEC (support s2)) =3%nat) by now rewrite <- Hperm.
+ destruct (on_SEC (support s2)) as [| b1 [| b2 [| b3 [| ? ?]]]]; simpl in *; try lia.
+ apply target_triangle_compat; assumption.
++ assert (Hlen : (length (on_SEC (support s2)) = 4 + length l)%nat) by now rewrite <- Hperm.
+ destruct (on_SEC (support s2)) as [| b1 [| b2 [| b3 [| ? ?]]]]; simpl in Hlen; try lia.
+ now rewrite Hs.
+Qed.
+
+(** The list of acceptable locations in a clean configuration. *)
+Definition SECT (s : observation) : list location := target s :: on_SEC (support s).
+
+Instance SECT_compat : Proper (equiv ==> PermutationA equiv) SECT.
+Proof using size_G.
+intros ? ? Hs. unfold SECT. rewrite Hs at 1.
+constructor; try reflexivity; []. now rewrite Hs.
+Qed.
+
+Definition is_clean (s : observation) : bool :=
+ if inclA_bool _ equiv_dec (support s) (SECT s) then true else false.
+
+Instance is_clean_compat : Proper (equiv ==> Logic.eq) is_clean.
+Proof using size_G.
+intros ? ? Heq. unfold is_clean.
+destruct (inclA_bool _ equiv_dec (support x) (SECT x)) eqn:Hx,
+ (inclA_bool _ equiv_dec (support y) (SECT y)) eqn:Hy;
+ trivial; rewrite ?inclA_bool_true_iff, ?inclA_bool_false_iff in *; [|].
++ elim Hy. intros e Hin. rewrite <- Heq in Hin.
+ apply SECT_compat in Heq. rewrite <- Heq. now apply Hx.
++ elim Hx. intros e Hin. rewrite Heq in Hin.
+ apply SECT_compat in Heq. rewrite Heq. now apply Hy.
+Qed.
+
+Lemma is_clean_spec : forall s, is_clean s = true <-> inclA equiv (support s) (SECT s).
+Proof using .
+intro s. unfold is_clean.
+split; intro Hclean.
+- rewrite <- (inclA_bool_true_iff _ equiv_dec).
+ now destruct (inclA_bool _ equiv_dec (support s) (SECT s)).
+- rewrite <- inclA_bool_true_iff in Hclean.
+ now rewrite Hclean.
+Qed.
+
+(** The robogram solving the gathering problem in R². *)
+Definition gatherR2_old_pgm (s : observation) : location :=
+ match support (max s) with
+ | nil => origin (* no robot *)
+ | [pt] => pt (* majority *)
+ | _ :: _ :: _ =>
+ if is_clean s then target s (* clean case *)
+ else if mem equiv_dec origin (SECT s) then origin else target s (* dirty case *)
+ end.
+
+Global Instance gatherR2_pgm_compat : Proper (equiv ==> equiv) gatherR2_old_pgm.
+Proof using size_G.
+intros s1 s2 Hs. unfold gatherR2_old_pgm.
+assert (Hsize : length (support (max s1)) = length (support (max s2))) by now rewrite Hs.
+destruct (support (max s1)) as [| pt1 [| ? ?]] eqn:Hs1,
+ (support (max s2)) as [| pt2 [| ? ?]] eqn:Hs2;
+simpl in Hsize; lia || clear Hsize.
+* reflexivity.
+* apply max_compat, support_compat in Hs. rewrite Hs1, Hs2 in Hs.
+ rewrite PermutationA_Leibniz in Hs. apply Permutation_length_1_inv in Hs. now inversion Hs.
+* rewrite Hs. destruct (is_clean s2).
+ + now f_equiv.
+ + assert (Heq : mem equiv_dec origin (SECT s1) = mem equiv_dec origin (SECT s2)).
+ { apply mem_compat, PermutationA_equivlistA_subrelation; auto; []. now rewrite Hs. }
+ (* BUG?: [rewrite Hs] should take care of this assert (and bypass it entirely) *)
+ rewrite Heq.
+ destruct (mem equiv_dec origin (SECT s2)) eqn:Hin.
+ - reflexivity.
+ - now f_equiv.
+Qed.
+
+End Target.
+
+Local Existing Instance color_bivalent_obs_compat.
+Local Existing Instance bivalent_obs_compat.
+Local Existing Instance mem_compat.
+Local Existing Instance target_compat.
+Local Existing Instance SECT_compat.
+Local Existing Instance is_clean_compat.
+(* Move this up? *)
+
+Definition find_max_black (obs : (@observation (location * L) _ _ _ Obs)) loc1 loc2 : location :=
+ let col1 : nat := (colors (snd obs))[(loc1, false)] in
+ let col2 : nat := (colors (snd obs))[(loc2, false)] in
+ if Nat.leb col1 col2 then loc2 else loc1.
+
+Instance find_max_black_compat: Proper (@equiv observation _ ==> equiv ==> equiv ==> equiv) find_max_black.
+Proof using .
+intros obs1 obs2 Hobs loc1 loc1' Hloc1 loc2 loc2' Hloc2.
+unfold find_max_black.
+now rewrite Hobs, 2 Hloc1, 2 Hloc2.
+Qed.
+
+Lemma find_max_black_indep : forall config st1 st2 pt1 pt2,
+ find_max_black (!!! (config, st1)) pt1 pt2 == find_max_black (!!! (config, st2)) pt1 pt2.
+Proof using .
+intros config st1 st2 pt1 pt2. unfold find_max_black.
+now rewrite (colors_indep config st1 st2).
+Qed.
+
+Lemma find_max_black_either : forall obs pt1 pt2,
+ find_max_black obs pt1 pt2 == pt1 \/ find_max_black obs pt1 pt2 == pt2.
+Proof using . intros. unfold find_max_black. destruct_match; now left + right. Qed.
+
+Definition find_other_loc obs (loc : location) :=
+ match support obs with
+ | pt1 :: pt2 :: nil =>
+ if pt1 ==b loc then pt2 else
+ if pt2 ==b loc then pt1 else loc
+ | _ => loc
+ end.
+
+Instance find_other_loc_compat : Proper (equiv ==> equiv ==> equiv) find_other_loc.
+Proof using .
+intros obs1 obs2 Hobs loc1 loc2 Hloc. unfold find_other_loc.
+assert (Hperm : PermutationA equiv (support obs1) (support obs2)).
+{ apply support_compat, Hobs. }
+assert (Hlen := PermutationA_length Hperm).
+assert (Hnodup1 : NoDupA equiv (support obs1)) by apply support_NoDupA.
+assert (Hnodup2 : NoDupA equiv (support obs2)) by apply support_NoDupA.
+destruct (support obs1) as [| pt1 [| pt1' []]] eqn:Hobs1,
+ (support obs2) as [| pt2 [| pt2' []]] eqn:Hobs2;
+cbn in Hlen; auto; [].
+rewrite PermutationA_2 in Hperm; autoclass; [].
+rewrite NoDupA_2 in *.
+destruct_match_eq Heq1; destruct_match_eq Heq2;
+try destruct_match_eq Heq3; try destruct_match_eq Heq4; trivial;
+try rewrite <- not_true_iff_false in *; rewrite equiv_decb_spec in *;
+decompose [or and] Hperm; congruence.
+Qed.
+
+Lemma find_other_loc_spec : forall obs, bivalent_obs obs = true ->
+ forall pt, In pt (fst obs) ->
+ PermutationA equiv (support (fst obs)) (pt :: find_other_loc (fst obs) pt :: nil).
+Proof using .
+intros obs Hbivalent pt Hpt. unfold find_other_loc, bivalent_obs in *.
+assert (Hnodup := support_NoDupA (fst obs)).
+destruct obs as [obs1 ?]. cbn [fst] in *.
+rewrite <- support_spec in Hpt.
+revert Hbivalent. changeR2.
+repeat destruct_match; try discriminate; [| |]; intros _; rewrite NoDupA_2 in Hnodup;
+repeat rewrite 2 InA_cons, InA_nil in *;
+try rewrite <- not_true_iff_false in *; rewrite equiv_decb_spec in *.
+- now constructor.
+- rewrite H3. apply permA_swap.
+- intuition congruence.
+Qed.
+
+Corollary find_other_loc_diff : forall obs, bivalent_obs obs = true ->
+ forall pt, In pt (fst obs) -> @complement _ (@equiv _ location_Setoid) (find_other_loc (fst obs) pt) pt.
+Proof using .
+intros obs Hobs pt Hperm. apply find_other_loc_spec in Hperm; trivial; [].
+assert (Hnodup := support_NoDupA (fst obs)).
+rewrite Hperm in Hnodup. inv Hnodup.
+now rewrite InA_singleton in *.
+Qed.
+
+Corollary find_other_loc_In : forall obs, bivalent_obs obs = true ->
+ forall pt, In pt (fst obs) -> In (find_other_loc (fst obs) pt) (fst obs).
+Proof using .
+intros obs Hbivalent pt Hin.
+apply find_other_loc_spec in Hin; trivial; [].
+rewrite <- support_spec, Hin. now right; left.
+Qed.
+
+(** The robogram solving the gathering problem in R². *)
+(* Note: If gatherR2_pgm is adapted to this model it should already return a location * L *)
+Definition gatherR2_pgmLight (obs : observation) : location * L :=
+ if bivalent_obs obs
+ then let other_loc := find_other_loc (fst obs) origin in
+ if color_bivalent_obs obs
+ then if observer_lght (snd obs)
+ then (middle origin other_loc, false)
+ else (origin, true) (* was: (other_loc, true) *)
+ else let maj_black := find_max_black obs origin other_loc in
+ (maj_black, observer_lght (snd obs))
+ else (gatherR2_old_pgm (fst obs), observer_lght (snd obs)).
+
+Global Instance gatherR2_pgmLight_compat: Proper (equiv ==> equiv) gatherR2_pgmLight.
+Proof using size_G.
+intros obs1 obs2 Hobs. unfold gatherR2_pgmLight.
+repeat first [ reflexivity | setoid_rewrite Hobs | destruct_match].
+Qed.
+
+Definition gatherR2 : robogram := {| pgm := gatherR2_pgmLight |}.
+
+Close Scope R_scope.
+
+
+(** ** Decreasing measure ensuring termination **)
+
+(** *** Naming the useful cases in the algorithm and proof **)
+
+Definition MajTower_at (x:location) (config:configuration) := forall y,
+ y =/= x -> (!! (config))[y] < (!! (config))[x].
+
+Definition no_Majority (config:configuration) :=
+ (size (max (!! (config))) > 1)%nat.
+
+Definition diameter_case config :=
+ no_Majority config
+ /\ exists pt1 pt2, PermutationA equiv (on_SEC (support (!! (config)))) (pt1 :: pt2 :: nil).
+
+Definition triangle_case config :=
+ no_Majority config
+ /\ exists pt1 pt2 pt3, PermutationA equiv (on_SEC (support (!! (config)))) (pt1 :: pt2 :: pt3 :: nil).
+
+Definition equilateral_case config :=
+ no_Majority config
+ /\ exists pt1 pt2 pt3, PermutationA equiv (on_SEC (support (!! (config)))) (pt1 :: pt2 :: pt3 :: nil)
+ /\ classify_triangle pt1 pt2 pt3 = Equilateral.
+
+Definition generic_case config :=
+ no_Majority config
+ /\ exists pt1 pt2 pt3 pt4 l, PermutationA equiv (on_SEC (support (!! (config))))
+ (pt1 :: pt2 :: pt3 :: pt4 :: l).
+
+
+Instance no_Majority_compat : Proper (equiv ==> iff) no_Majority.
+Proof using . intros ? ? Hconfig. unfold no_Majority. now setoid_rewrite Hconfig. Qed.
+
+Instance MajTower_at_compat : Proper (Logic.eq ==> equiv ==> iff) MajTower_at.
+Proof using .
+ intros ? ? Hconfig1 ? ? Hconfig2.
+ subst. unfold MajTower_at. now setoid_rewrite Hconfig2.
+Qed.
+
+Instance diameter_case_compat : Proper (equiv ==> iff) diameter_case.
+Proof using . intros ? ? Hconfig. unfold diameter_case. now setoid_rewrite Hconfig. Qed.
+
+Instance triangle_case_compat : Proper (equiv ==> iff) triangle_case.
+Proof using . intros ? ? Hconfig. unfold triangle_case. now setoid_rewrite Hconfig. Qed.
+
+Instance equilateral_case_compat : Proper (equiv ==> iff) equilateral_case.
+Proof using . intros ? ? Hconfig. unfold equilateral_case. now setoid_rewrite Hconfig. Qed.
+
+Instance generic_case_compat : Proper (equiv ==> iff) generic_case.
+Proof using . intros ? ? Hconfig. unfold generic_case. now setoid_rewrite Hconfig. Qed.
+
+Definition clean_diameter_case config :=
+ diameter_case config /\ is_clean (!! config) = true.
+
+(** Some results about [MajTower_at] and [no_Majority]. *)
+Theorem MajTower_at_equiv : forall config pt,
+ MajTower_at pt config <->
+ support (max (!! config)) = [pt].
+Proof using size_G.
+intros config pt. split; intro Hmaj.
+* apply Permutation_length_1_inv. rewrite <- PermutationA_Leibniz.
+ change eq with (@equiv location _).
+ apply (NoDupA_equivlistA_PermutationA _).
+ + apply NoDupA_singleton.
+ + apply support_NoDupA.
+ + intro y. rewrite InA_singleton.
+ rewrite support_spec, max_spec1_iff.
+ 2:{ apply obs_non_nil. }
+ simpl equiv. split; intro Hpt.
+ - subst y. intro x. destruct (equiv_dec x pt).
+ -- rewrite e. reflexivity.
+ -- apply Nat.lt_le_incl. now apply Hmaj.
+ - destruct (equiv_dec y pt) as [? | Hy]; trivial.
+ exfalso. apply (Hmaj y) in Hy. elim (Nat.lt_irrefl (!! (config))[pt]).
+ eapply Nat.le_lt_trans; try eassumption; [].
+ apply Hpt.
+* intros y hdiff. apply max_spec_lub.
+ - rewrite <- support_spec.
+ rewrite Hmaj. now left.
+ - rewrite <- support_spec, Hmaj. intro Habs. inversion_clear Habs.
+ + auto.
+ + inversion H.
+Qed.
+
+Theorem no_Majority_equiv : forall config, no_Majority config
+ <-> exists pt1 pt2 l, support (max (!! config)) = pt1 :: pt2 :: l.
+Proof using size_G.
+intros config.
+unfold no_Majority. rewrite size_spec.
+split; intro Hmaj.
++ destruct (support (max (!! config))) as [| ? [| ? ?]]; cbn in Hmaj; lia || eauto.
++ destruct Hmaj as [? [? [? Hmaj]]]. rewrite Hmaj. cbn. lia.
+Qed.
+
+Corollary make_no_Majority : forall pt1 pt2 l config,
+ PermutationA equiv (support (max (!! config))) (pt1 :: pt2 :: l) -> no_Majority config.
+Proof using size_G.
+intros pt1 pt2 l config Hperm.
+rewrite no_Majority_equiv. apply PermutationA_length in Hperm.
+destruct (support (max (!! config))) as [| ? [| ? ?]]; cbn in Hperm; lia || eauto.
+Qed.
+
+Lemma no_Majority_on_SEC_length : forall config,
+ no_Majority config -> 2 <= length (on_SEC (support (!! config))).
+Proof using size_G.
+intros config Hmaj.
+destruct (on_SEC (support (!! config))) as [| pt1 [| pt2 ?]] eqn:Hsec; simpl; lia || exfalso.
++ rewrite on_SEC_nil in Hsec. apply (support_non_nil _ Hsec).
++ apply on_SEC_singleton_is_singleton in Hsec.
+ - rewrite no_Majority_equiv in Hmaj. destruct Hmaj as [? [? [? Hmaj]]].
+ assert (Hle := size_max (!! config)).
+ do 2 rewrite size_spec in Hle.
+ rewrite Hmaj, Hsec in Hle. cbn in Hle. lia.
+ - rewrite <- NoDupA_Leibniz. change eq with (@equiv location _). apply support_NoDupA.
+Qed.
+
+(** A Tactic deciding in which case we are in the algorithm. *)
+Ltac get_case config :=
+ let Hcase := fresh "Hcase" in
+(* try rewrite <- PermutationA_Leibniz in *; *)
+ lazymatch goal with
+ (* Majority case *)
+ | H : support (max (!! config)) = [?pt] |- _ =>
+ assert (Hcase : MajTower_at pt config) by now rewrite MajTower_at_equiv
+ (* Diameter case *)
+ | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = [_; _] |- _ =>
+ assert (Hcase : diameter_case config)
+ by now repeat split; trivial; setoid_rewrite H; repeat eexists; reflexivity
+ (* Equilateral case *)
+ | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = [?pt1; ?pt2; ?pt3],
+ H' : classify_triangle ?pt1 ?pt2 ?pt3 = Equilateral |- _ =>
+ assert (Hcase : equilateral_case config)
+ by now repeat split; trivial; setoid_rewrite H; repeat eexists; reflexivity || assumption
+ (* Triangle case *)
+ | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = [_; _; _] |- _ =>
+ assert (Hcase : triangle_case config)
+ by now repeat split; trivial; setoid_rewrite H; repeat eexists; reflexivity
+ (* Generic case *)
+ | Hmaj : no_Majority config, H : on_SEC (support (!! config)) = _ :: _ :: _ :: _ :: _ |- _ =>
+ assert (Hcase : generic_case config)
+ by now repeat split; trivial; setoid_rewrite H; repeat eexists; reflexivity
+ (* no_Majority *)
+ | Hmaj : no_Majority config, H : support (max (!! config)) = _ :: _ :: _ |- _ => idtac
+ | H : support (max (!! config)) = _ :: _ :: _ |- _ =>
+ let Hmaj := fresh "Hmaj" in
+ assert (Hmaj : no_Majority config) by (now eapply make_no_Majority; rewrite H); get_case config
+ end.
+
+(** *** Equivalent formulations of [bivalent] **)
+
+Lemma Majority_not_bivalent : forall config pt,
+ MajTower_at pt config -> ~ bivalent config.
+Proof using size_G.
+intros config pt Hmaj. rewrite MajTower_at_equiv in Hmaj.
+specialize nB_eq_0 as h_nB_0.
+assert (Hmax : forall x, In x (max (!! config)) <-> x = pt).
+{ intro x. rewrite <- support_spec, Hmaj. split.
+ - intro Hin. inversion_clear Hin. assumption. inversion H.
+ - intro. subst x. now left. }
+intro Hbivalent.
+assert (Hsuplen := WithMultiplicityLight.bivalent_size (origin,witness) Hbivalent).
+destruct Hbivalent as [Heven [? [pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
+assert (Hsup : Permutation (support (!! config)) (pt1 :: pt2 :: nil)).
+{ assert (Hin1 : InA equiv pt1 (support (!! config))).
+ { rewrite support_spec. unfold In. changeR2. setoid_rewrite Hpt1.
+ apply Exp_prop.div2_not_R0.
+ lia. }
+ assert (Hin2 : InA equiv pt2 (support (!! config))).
+ { rewrite support_spec. unfold In. changeR2. setoid_rewrite Hpt2.
+ apply Exp_prop.div2_not_R0;lia. }
+ apply (PermutationA_split _) in Hin1. destruct Hin1 as [l Hl]. rewrite Hl in Hin2.
+ inversion_clear Hin2; try now subst; elim Hdiff.
+ rewrite Hl in Hsuplen. destruct l as [| x [| ? ?]]; simpl in Hsuplen; try lia.
+ inversion_clear H.
+ - inversion H0; simpl in H1; subst.
+ + rewrite <- PermutationA_Leibniz. now change eq with (@equiv location _).
+ + inversion H1.
+ - inversion H0; simpl in H2; subst.
+ + rewrite <- PermutationA_Leibniz. now change eq with (@equiv location _).
+ + inversion H2. }
+assert (Hpt : pt = pt1 \/ pt = pt2).
+{ assert (Hin : List.In pt ([pt1; pt2])).
+ { rewrite <- Hsup, <- InA_Leibniz. change eq with (@equiv location _).
+ rewrite support_spec.
+ setoid_rewrite <- (max_subset (!! config)).
+ rewrite <- support_spec.
+ setoid_rewrite Hmaj.
+ now left. }
+inversion_clear Hin; auto. inversion_clear H0; auto. inversion H1. }
+apply (Nat.lt_irrefl (Nat.div2 (nG+nB))). destruct Hpt; subst pt.
+- rewrite <- Hpt1 at 2. rewrite <- Hpt2. apply max_spec_lub; try now rewrite Hmax.
+- rewrite <- Hpt1 at 1. rewrite <- Hpt2. apply max_spec_lub; now rewrite Hmax.
+Qed.
+
+(* bivalent_size already proves the -> direction *)
+Lemma bivalent_equiv : forall config,
+ bivalent config <-> no_Majority config /\ size (!! config) = 2%nat.
+Proof using size_G.
+intro config.
+specialize nB_eq_0 as h_nB_0.
+unfold no_Majority. split.
+- intro Hbivalent. split.
+ + rewrite size_spec. destruct (support (max (!! config))) as [| pt1 [| pt2 l]] eqn:Hmax.
+ * exfalso. revert Hmax. apply support_max_non_nil.
+ * exfalso. revert Hmax Hbivalent. rewrite <- MajTower_at_equiv. apply Majority_not_bivalent.
+ * simpl. lia.
+ + changeR2. rewrite size_spec.
+ now apply bivalent_size with (st:=(origin,witness)).
+- intros [Hlen H2]. rewrite size_spec in Hlen, H2.
+ destruct (support (!! config)) as [| pt1 [| pt2 [| ? ?]]] eqn:Hsupp; try (now simpl in H2; lia); [].
+ red.
+ assert (Hlen':(size (max (!! config)) = 2)%nat).
+ { assert (size (max (!! config)) <= 2)%nat.
+ { rewrite max_simplified. unfold simple_max.
+ rewrite <- H2, <- Hsupp, <- size_spec.
+ apply size_nfilter.
+ now repeat intro; subst. }
+ rewrite <- size_spec in Hlen. lia. }
+ clear Hlen H2.
+ (* let us reformulate this in a more convenient way *)
+ cut (exists pt0 pt3,
+ pt0 <> pt3 /\
+ (!! config)[pt0] = Nat.div2 (nG+nB) /\ (!! config)[pt3] = Nat.div2 (nG+nB) /\ Nat.Even (nG+nB)).
+ { intros h.
+ decompose [ex and] h; repeat split; trivial.
+ - unfold ge. cbn. lia.
+ - exists x, x0; intuition. }
+ exists pt1, pt2.
+ split.
+ * assert (hnodup:NoDupA equiv ([pt1; pt2])).
+ { rewrite <- Hsupp. apply support_NoDupA. }
+ intro abs.
+ subst.
+ inversion hnodup; subst.
+ elim H1.
+ constructor.
+ reflexivity.
+ * assert (h : inclA equiv (support (max (!! config))) (support (!! config))).
+ { f_equiv. apply max_subset. }
+ assert (Hlen'': length (support (!! config)) <= length (support (max (!! config)))).
+ { rewrite size_spec in Hlen'. now rewrite Hsupp, Hlen'. }
+ assert (h2:=@NoDupA_inclA_length_PermutationA
+ _ equiv _
+ (support (max (!! config)))
+ (support (!! config))
+ (support_NoDupA _)
+ h Hlen'').
+ specialize (@cardinal_obs_from_config _ _ _ _ config (origin,false)) as toto.
+ rewrite <- plus_n_O in toto.
+ assert (~ equiv pt1 pt2).
+ { intro abs.
+ repeat red in abs.
+ rewrite abs in Hsupp.
+ assert (hnodup := support_NoDupA (!! config)).
+ rewrite Hsupp in hnodup.
+ inversion hnodup; subst.
+ match goal with H : ~ InA equiv pt2 ([pt2]) |- _ => elim H end.
+ constructor 1.
+ reflexivity. }
+ assert (heq_config: !! config == Madd pt1 ((!! config)[pt1]) (Madd pt2 ((!! config)[pt2]) empty)).
+ { red.
+ intros x.
+ destruct (equiv_dec x pt1) as [heqxpt1 | hneqxpt1].
+ - rewrite heqxpt1, add_same, (add_other pt2 pt1).
+ + now rewrite empty_spec.
+ + assumption.
+ - rewrite add_other; auto.
+ destruct (equiv_dec x pt2) as [heqxpt2 | hneqxpt2].
+ + now rewrite heqxpt2, add_same, empty_spec.
+ + rewrite add_other; auto.
+ rewrite empty_spec, <- not_In, <- support_spec.
+ intro abs. simpl equiv in abs. rewrite Hsupp in abs.
+
+ inversion abs; try contradiction; subst.
+ inversion H1; try contradiction; subst.
+ rewrite InA_nil in H2.
+ assumption. }
+ rewrite heq_config in toto.
+ rewrite cardinal_fold_elements in toto.
+ assert (fold_left (fun acc xn => snd xn + acc)
+ ([(pt1, (!! config)[pt1]); (pt2, (!! config)[pt2])]) 0
+ = nG).
+ { rewrite <- toto.
+ eapply MMultiset.Preliminary.fold_left_symmetry_PermutationA with (eqA := eq_pair); autoclass.
+ - repeat intro; subst. now rewrite H1.
+ - intros. lia.
+ - symmetry.
+ transitivity ((pt1, (!! config)[pt1]) :: (elements (Madd pt2 (!! config)[pt2] empty))).
+ eapply elements_add_out; auto.
+ + rewrite heq_config, add_same. cut ((!! config)[pt1] > 0). lia.
+ change (In pt1 (!! config)). rewrite <- support_spec, Hsupp. now left.
+ + rewrite add_empty.
+ rewrite In_singleton.
+ intros [abs _].
+ contradiction.
+ + apply permA_skip.
+ * reflexivity.
+ * transitivity ((pt2, (!! config)[pt2]) :: elements empty).
+ -- eapply elements_add_out; auto. change (In pt2 (!! config)).
+ rewrite <- support_spec, Hsupp. now right; left.
+ -- now rewrite elements_empty. }
+ change ((!! config)[pt2] + ((!! config)[pt1] + 0) = nG) in H0.
+ rewrite <- plus_n_O in H0.
+
+ assert ((!! config)[pt2] = (!! config)[pt1]).
+ { assert (hfilter:= nfilter_In (eqb_max_mult_compat (!! config))).
+ transitivity (max_mult (!! config)).
+ + specialize (hfilter pt2 (!!config)).
+ change (nfilter (fun _ => Nat.eqb (max_mult (!! config))) (!!config))
+ with (simple_max (!!config)) in hfilter.
+ rewrite <- max_simplified in hfilter.
+ destruct hfilter as [hfilter1 hfilter2].
+ destruct hfilter1.
+ * apply support_spec.
+ rewrite h2.
+ rewrite Hsupp.
+ constructor 2; constructor 1.
+ reflexivity.
+ * symmetry.
+ rewrite <- Nat.eqb_eq.
+ assumption.
+ + specialize (hfilter pt1 (!!config)).
+ change (nfilter (fun _ => Nat.eqb (max_mult (!! config))) (!!config))
+ with (simple_max (!!config)) in hfilter.
+ rewrite <- max_simplified in hfilter.
+ destruct hfilter as [hfilter1 hfilter2].
+ destruct hfilter1.
+ * apply support_spec.
+ rewrite h2.
+ rewrite Hsupp.
+ constructor 1.
+ reflexivity.
+ * now rewrite <- Nat.eqb_eq. }
+ rewrite H1 in *|-*.
+ assert ( 0 + 2 *(!! config)[pt1] = nG) by lia.
+ assert (Nat.even nG = true).
+ { rewrite <- H2.
+ rewrite (Nat.even_add_mul_2 0 ((!! config)[pt1])).
+ apply Nat.even_0. }
+ split;[| split].
+ -- rewrite Nat.div2_odd in H2.
+ rewrite <- Nat.negb_even in H2.
+ rewrite H3 in H2.
+ simpl negb in H2.
+ simpl Nat.b2n in H2.
+ repeat rewrite <- plus_n_O,plus_O_n in H2.
+ rewrite h_nB_0.
+ replace (nG+0) with nG; lia.
+ -- rewrite Nat.div2_odd in H2.
+ rewrite <- Nat.negb_even in H2.
+ rewrite H3 in H2.
+ simpl negb in H2.
+ simpl Nat.b2n in H2.
+ repeat rewrite <- plus_n_O,plus_O_n in H2.
+ replace (nG+0) with nG; lia.
+ -- replace (nG+0) with nG; try lia.
+ now apply Nat.even_spec.
+Qed.
+
+Lemma not_bivalent_no_majority_size : forall config,
+ no_Majority config -> ~WithMultiplicityLight.bivalent config -> (size (!! config) >= 3)%nat.
+Proof using size_G.
+intros config H1 H2.
+assert (size (!! config) > 1)%nat.
+{ unfold gt. eapply Nat.lt_le_trans; try eassumption; []. f_equiv. apply max_subset. }
+ destruct (size (!! config)) as [| [| [| ?]]] eqn:Hlen; try lia.
+exfalso. apply H2. now rewrite bivalent_equiv.
+Qed.
+
+
+(** *** Global decreasing measure **)
+
+(** It is a lexicographic order on the index of the type of config + the number of robots that should move. *)
+(**
+ - ] Gathered: no need
+ - 0] Majority tower: # robots not on majority tower
+ - 1] Clean diameter case: # robots not on target
+ - 2] Dirty diameter case: # robots not on SECT
+ - 3] Clean equilateral triangle: # robots not on target
+ - 4] Dirty equilateral triangle: # robots not on SECT
+ - 3'] Clean isosceles triangle not equilateral: # robots not on target
+ - 4'] Dirty isosceles triangle not equilateral: # robots not on SECT
+ - 3''] Clean scalene triangle: # robots not on target
+ - 4''] Dirty scalene triangle: # robots not on SECT
+ - 5] Clean generic case (|SEC| ≥ 4): # robots not on target
+ - 6] Dirty Generic case (|SEC| ≥ 4): # robots not on SECT
+ - 7] Bivalent case: no need, durect jump to Majority tower of Gathered
+ - 8] Color bivalent case: # black robots
+*)
+
+Definition SECT_cardinal s :=
+ cardinal (filter (fun x => if InA_dec equiv_dec x (SECT s) then true else false) s).
+
+Instance SECT_cardinal_compat : Proper (equiv ==> Logic.eq) SECT_cardinal.
+Proof using size_G.
+intros s1 s2 Hs. unfold SECT_cardinal. f_equiv. rewrite Hs.
+apply filter_extensionality_compat.
+- intros x y Hxy. now rewrite Hxy.
+- intro x. destruct (InA_dec equiv_dec x (SECT s1)), (InA_dec equiv_dec x (SECT s2));
+ trivial; rewrite Hs in *; contradiction.
+Qed.
+
+Lemma SECT_cardinal_le_nG : forall config, SECT_cardinal (!! config) <= nG.
+Proof using .
+intro config. unfold SECT_cardinal.
+replace nG with (nG + nB) by (simpl; apply Nat.add_0_r).
+rewrite <- (cardinal_obs_from_config config (origin,false)).
+apply cardinal_sub_compat, filter_subset.
+intros ? ? H. now rewrite H.
+Qed.
+
+Definition measure_clean (s : @observation _ _ _ _ multiset_observation) := nG - s[target s].
+Definition measure_dirty (s : @observation _ _ _ _ multiset_observation) := nG - SECT_cardinal s.
+
+
+Definition count_black (s : observation): nat :=
+ fold (fun k n acc => acc+n) (filter (fun k => negb (snd k)) (colors (snd s))) 0.
+
+Definition old_measure (s : @observation _ _ _ _ multiset_observation) : nat * nat :=
+ match support (max s) with
+ | nil => (0, 0) (* no robot *)
+ | [pt] => (0, nG - s[pt]) (* majority *)
+ | _ :: _ :: _ =>
+ match on_SEC (support s) with
+ | nil | [_] => (0, 0) (* impossible cases *)
+ | [pt1; pt2] => (* diameter case *)
+ if is_clean s then (1, measure_clean s) else (2, measure_dirty s)
+ | [pt1; pt2; pt3] => (* triangle case *)
+ if is_clean s then (3, measure_clean s) else (4, measure_dirty s)
+ | _ => (* general case *) if is_clean s then (5, measure_clean s) else (6, measure_dirty s)
+ end
+ end.
+
+Function measure (s : observation) : nat * nat :=
+ if bivalent_obs s then
+ if color_bivalent_obs s then (8, count_black s)
+ else
+ (7, 0) (* we eventually (by fairness) jump directly to a majority tower case. *)
+ else
+ old_measure (fst s).
+
+
+Instance measure_clean_compat : Proper (equiv ==> Logic.eq) measure_clean.
+Proof using size_G.
+ intros ? ? Heq. unfold measure_clean.
+ now rewrite Heq.
+Qed.
+
+Instance measure_dirty_compat : Proper (equiv ==> Logic.eq) measure_dirty.
+Proof using size_G.
+ intros ? ? Heq. unfold measure_dirty.
+ now rewrite Heq.
+Qed.
+
+Instance old_measure_compat : Proper (equiv ==> Logic.eq) old_measure.
+Proof using size_G.
+intros s1 s2 Hs. unfold old_measure.
+assert (Hsize : length (support (max s1)) = length (support (max s2))).
+{ now rewrite Hs. }
+destruct (support (max s1)) as [| pt1 [| ? ?]] eqn:Hs1,
+ (support (max s2)) as [| pt2 [| ? ?]] eqn:Hs2;
+simpl in Hsize; lia || clear Hsize.
++ reflexivity.
++ do 2 f_equal. rewrite Hs. f_equal.
+ rewrite <- (PermutationA_1 _). rewrite <- Hs1, <- Hs2. rewrite Hs. reflexivity.
++ clear -Hs size_G.
+ assert (Hperm : Permutation (on_SEC (support s1)) (on_SEC (support s2))).
+ { now rewrite <- PermutationA_Leibniz, Hs. }
+ destruct (on_SEC (support s1)) as [| a1 [| a2 [| a3 [| ? ?]]]] eqn:Hs1.
+ - apply Permutation_nil in Hperm. now rewrite Hperm.
+ - apply Permutation_length_1_inv in Hperm. now rewrite Hperm.
+ - apply Permutation_length_2_inv in Hperm.
+ destruct Hperm as [Hperm | Hperm]; rewrite Hperm; trivial;
+ rewrite Hs; destruct (is_clean s2); f_equal; now rewrite Hs.
+ - assert (Hlen : (length (on_SEC (support s2)) =3%nat)) by now rewrite <- Hperm.
+ destruct (on_SEC (support s2)) as [| b1 [| b2 [| b3 [| ? ?]]]]; simpl in Hlen; try lia.
+ rewrite Hs. destruct (is_clean s2); f_equal; now rewrite Hs.
+ - assert (Hlen : (length (on_SEC (support s2)) = 4 + length l)%nat) by now rewrite <- Hperm.
+ destruct (on_SEC (support s2)) as [| b1 [| b2 [| b3 [| ? ?]]]]; simpl in Hlen; try lia.
+ rewrite Hs; destruct (is_clean s2); f_equal; now rewrite Hs.
+Qed.
+
+Instance count_black_compat : Proper (equiv ==> Logic.eq) count_black.
+Proof using size_G.
+ intros s1 s2 Hs.
+ unfold count_black.
+ apply fold_compat;autoclass.
+ - repeat intro.
+ lia.
+ - repeat intro.
+ lia.
+ - now rewrite Hs.
+Qed.
+
+Instance measure_compat : Proper (equiv ==> Logic.eq) measure.
+Proof using size_G.
+ intros s1 s2 Hs. unfold measure.
+ rewrite Hs.
+ destruct (bivalent_obs s2).
+ - now repeat rewrite Hs.
+ - now rewrite Hs.
+Qed.
+
+
+Definition lt_config x y :=
+ Lexprod.lexprod lt lt (measure (!!! (x,(0%VS, witness)))) (measure (!!! (y,(0%VS, witness)))).
+
+Lemma wf_lt_config: well_founded lt_config.
+Proof using . unfold lt_config. apply wf_inverse_image, Lexprod.wf_lexprod; apply lt_wf. Qed.
+
+Global Instance lt_config_compat : Proper (equiv ==> equiv ==> iff) lt_config.
+Proof using size_G.
+intros config1 config1' Heq1 config2 config2' Heq2.
+unfold lt_config.
+now rewrite <- Heq1, <- Heq2.
+Qed.
+
+(** *** The robogram is invariant by a change of the frame of reference **)
+
+Section Morphisms.
+
+Local Existing Instance multiset_observation.
+
+(** We first prove how the functions used by the robogram are affected by a change of the frame of reference. *)
+Lemma target_triangle_morph:
+ forall (sim : similarity location) pt1 pt2 pt3, target_triangle (sim pt1) (sim pt2) (sim pt3)
+ = sim (target_triangle pt1 pt2 pt3).
+Proof using .
+intros sim pt1 pt2 pt3. unfold target_triangle.
+rewrite classify_triangle_morph.
+destruct (classify_triangle pt1 pt2 pt3); simpl; auto.
+- apply isobarycenter_3_morph.
+- apply opposite_of_max_side_morph.
+Qed.
+
+Lemma target_morph : forall (sim : similarity location) (s : observation),
+ support s <> nil -> target (map sim s) = sim (target s).
+Proof using size_G.
+intros sim s hnonempty. unfold target.
+assert (Hperm : Permutation (List.map sim (on_SEC (support s))) (on_SEC (support (map sim s)))).
+{ assert (Heq : on_SEC (support s)
+ = List.filter (fun x => on_circle (sim_circle sim (SEC (support s))) (sim x)) (support s)).
+ { apply ListComplements.filter_extensionality_compat; trivial; [].
+ repeat intro. subst. now rewrite on_circle_morph. }
+ rewrite Heq. rewrite <- filter_map.
+ rewrite <- PermutationA_Leibniz. rewrite <- map_injective_support; trivial.
+ - unfold on_SEC. rewrite ListComplements.filter_extensionality_compat; try reflexivity; [].
+ repeat intro. subst. f_equal. symmetry. rewrite <- SEC_morph.
+ apply SEC_compat. rewrite <- PermutationA_Leibniz.
+ change eq with (@equiv location _). apply map_sim_support.
+ - intros ? ? H. now rewrite H.
+ - apply injective. }
+rewrite <- PermutationA_Leibniz in Hperm. change eq with (@equiv location _) in Hperm.
+assert (Hlen := PermutationA_length Hperm).
+changeR2.
+destruct ((on_SEC (support s))) as [| pt1 [| pt2 [| pt3 [| ? ?]]]] eqn:Hn,
+ (on_SEC (support (map sim s))) as [| pt1' [| pt2' [| pt3' [| ? ?]]]];
+simpl in Hlen, Hperm; try (lia || reflexivity); clear Hlen.
++ rewrite on_SEC_nil in Hn. contradiction.
++ now rewrite (PermutationA_1 _) in Hperm.
++ change (sim (R2.center (SEC (support s)))) with (R2.center (sim_circle sim (SEC (support s)))).
+ f_equal. rewrite <- SEC_morph. apply SEC_compat.
+ rewrite <- PermutationA_Leibniz. change eq with (@equiv location _). apply map_sim_support.
++ rewrite PermutationA_Leibniz in Hperm. rewrite <- (target_triangle_compat Hperm). apply target_triangle_morph.
++ change (sim (R2.center (SEC (support s)))) with (R2.center (sim_circle sim (SEC (support s)))).
+ f_equal. rewrite <- SEC_morph. apply SEC_compat.
+ rewrite <- PermutationA_Leibniz. change eq with (@equiv location _). apply map_sim_support.
+Qed.
+
+Corollary SECT_morph : forall (sim : similarity location) s,
+ support s <> nil -> PermutationA (@equiv location _) (SECT (map sim s)) (List.map sim (SECT s)).
+Proof using size_G.
+intros sim s s_nonempty. unfold SECT.
+rewrite (target_morph _ _ s_nonempty). constructor; try reflexivity; [].
+transitivity (List.filter (on_circle (SEC (support (map sim s)))) (List.map sim (support s))).
++ apply filter_PermutationA_compat, map_sim_support; autoclass.
++ rewrite filter_map.
+ cut (List.map sim (List.filter (fun x => on_circle (SEC (support (map sim s))) (sim x)) (support s))
+ = (List.map sim (on_SEC (support s)))).
+ - intro Heq. now rewrite Heq.
+ - f_equal. apply ListComplements.filter_extensionality_compat; trivial; [].
+ repeat intro. subst. now rewrite map_sim_support, SEC_morph, on_circle_morph.
+Qed.
+
+Lemma is_clean_morph : forall (sim : similarity location) s,
+ support s <> nil -> is_clean (map sim s) = is_clean s.
+Proof using size_G.
+intros sim s s_nonempty. unfold is_clean. changeR2.
+destruct (inclA_bool _ equiv_dec (support (map sim s)) (SECT (map sim s))) eqn:Hx,
+ (inclA_bool _ equiv_dec (support s) (SECT s)) eqn:Hy;
+trivial; rewrite ?inclA_bool_true_iff, ?inclA_bool_false_iff, ?inclA_Leibniz in *; [|].
+- elim Hy. intros x Hin. apply (in_map sim) in Hin. rewrite <- map_sim_support in Hin.
+ apply Hx in Hin. rewrite SECT_morph, in_map_iff in Hin;auto.
+ destruct Hin as [x' [Heq ?]]. apply (Similarity.injective sim) in Heq. now rewrite <- Heq.
+- elim Hx. intros x Hin. rewrite SECT_morph; auto. rewrite map_sim_support in Hin.
+ rewrite in_map_iff in *. destruct Hin as [x' [? Hin]]. subst. exists x'. repeat split. now apply Hy.
+Qed.
+
+Lemma find_other_loc_morph : forall (sim : similarity location) obs pt,
+ find_other_loc (map sim obs) (sim pt) == sim (find_other_loc obs pt).
+Proof using n.
+intros sim obs pt. unfold find_other_loc.
+assert (Hperm := map_sim_support sim obs).
+assert (Hlen := PermutationA_length Hperm).
+assert (Hnodup := support_NoDupA obs).
+changeR2.
+destruct (support (map sim obs)) as [| pt1' [| pt2' []]],
+ (support obs) as [| pt1 [| pt2 []]];
+cbn -[equiv] in Hlen, Hperm; try (discriminate || reflexivity); [].
+rewrite PermutationA_2 in Hperm; auto; [].
+rewrite NoDupA_2 in Hnodup.
+assert (Heq : forall x y, (sim x ==b sim y) = (x ==b y)).
+{ intros x y. destruct (x ==b y) eqn:Heq.
+ + rewrite equiv_decb_spec in *. now rewrite Heq.
+ + rewrite <- not_true_iff_false, equiv_decb_spec in *.
+ intro Hsim. apply Heq. now apply (injective sim). }
+destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]];
+repeat rewrite Heq1, Heq2, Heq; changeR2;
+repeat destruct_match; try reflexivity; [].
+rewrite equiv_decb_spec in *. congruence.
+Qed.
+
+Lemma find_max_black_morph : forall sim : similarity location,
+ forall (obs : observation (Observation := Obs)) (pt1 pt2 : location),
+ find_max_black (map sim (fst obs), map_light sim (snd obs)) (sim pt1) (sim pt2)
+ == sim (find_max_black obs pt1 pt2).
+Proof using .
+intros sim obs pt1 pt2. unfold find_max_black.
+cbn -[equiv]. set (f := fun x : location * L => (sim (fst x), snd x)).
+change (map _ (colors ?A)) with (map f (colors A)).
+change (sim_f sim ?A, false) with (f (A, false)).
+assert (Hf : Proper (equiv ==> equiv) f).
+{ intros ? ? Heq. unfold f. now rewrite Heq. }
+assert (Hf_inj : Preliminary.injective equiv equiv f).
+{ intros [] [] [Heq1 Heq2]. split; cbn -[equiv] in *; trivial; [].
+ now apply (injective sim). }
+rewrite 2 (map_injective_spec Hf Hf_inj).
+simpl. now destruct_match.
+Qed.
+
+(** *** Lemmas about [target] **)
+
+(** **** The value of [target] in the various cases **)
+
+Lemma diameter_target : forall config ptx pty,
+ on_SEC (support (!! config)) = [ptx; pty] ->
+ target (!! config) = middle ptx pty.
+Proof using .
+intros config ptx pty HonSEC.
+unfold target.
+rewrite HonSEC.
+apply on_SEC_pair_is_diameter in HonSEC.
+now rewrite HonSEC.
+Qed.
+
+Lemma equilateral_target : forall config ptx pty ptz,
+ PermutationA equiv (on_SEC (support (!! config))) ([ptx; pty; ptz]) ->
+ classify_triangle ptx pty ptz = Equilateral ->
+ target (!! config) = isobarycenter ([ptx; pty; ptz]).
+Proof using .
+intros config ptx pty ptz Hperm Htriangle.
+unfold target.
+assert (Hlen : length (on_SEC (support (!! config))) = 3) by now rewrite Hperm.
+destruct (on_SEC (support (!! config))) as [| ? [| ? [| ? [| ? ?]]]]; simpl in Hlen; try discriminate.
+rewrite PermutationA_Leibniz in Hperm. rewrite (target_triangle_compat Hperm).
+unfold target_triangle. now rewrite Htriangle.
+Qed.
+
+Lemma isosceles_target : forall config ptx pty ptz vertex,
+ PermutationA equiv (on_SEC (support (!! config))) ([ptx; pty; ptz]) ->
+ classify_triangle ptx pty ptz = Isosceles vertex ->
+ target (!! config) = vertex.
+Proof using size_G.
+intros config ptx pty ptz vertex Hsec Htriangle.
+unfold target.
+assert (Hlen : length (on_SEC (support (!! config))) = length ([ptx; pty; ptz]))
+ by (f_equiv; eassumption).
+destruct (on_SEC (support (!! config))) as [| t [| t0 [| t1 [| t2 l]]]] eqn:Heq;
+simpl in Hlen; try lia; [].
+assert (h := @PermutationA_3 _ equiv _ t t0 t1 ptx pty ptz).
+destruct h. specialize (H Hsec).
+decompose [or and] H;
+match goal with
+ | |- target_triangle ?x ?y ?z = ?v =>
+ assert (hhh:classify_triangle x y z = classify_triangle ptx pty ptz);
+ [ eapply classify_triangle_compat; rewrite <- PermutationA_Leibniz, PermutationA_3; autoclass
+ | rewrite <- hhh in Htriangle; auto; unfold target_triangle; rewrite Htriangle; reflexivity ]
+end.
+Qed.
+
+Lemma scalene_target : forall config ptx pty ptz,
+ PermutationA equiv (on_SEC (support (!! config))) ([ptx; pty; ptz]) ->
+ classify_triangle ptx pty ptz = Scalene ->
+ target (!! config) = opposite_of_max_side ptx pty ptz.
+Proof using size_G.
+intros config ptx pty ptz Hsec Htriangle.
+remember (opposite_of_max_side ptx pty ptz) as vertex.
+unfold target.
+assert (Hlen : length (on_SEC (support (!! config))) = length ([ptx; pty; ptz]))
+ by (f_equiv; eassumption).
+destruct (on_SEC (support (!! config))) as [| t [| t0 [| t1 [| t2 l]]]] eqn:Heq;
+simpl in Hlen; try lia; [].
+assert (h := @PermutationA_3 _ equiv _ t t0 t1 ptx pty ptz).
+destruct h.
+specialize (H Hsec).
+decompose [or and] H;
+match goal with
+ | |- target_triangle ?x ?y ?z = ?v =>
+ assert (hhh:classify_triangle x y z = classify_triangle ptx pty ptz);
+ [ eapply classify_triangle_compat; rewrite <- PermutationA_Leibniz, PermutationA_3; autoclass
+ | rewrite <- hhh in Htriangle; auto; unfold target_triangle;
+ rewrite Htriangle, H2, H1, H4; symmetry; auto ]
+end;
+match goal with
+ | |- ?v = opposite_of_max_side ?x ?y ?z =>
+ assert (hhhh:opposite_of_max_side ptx pty ptz = opposite_of_max_side x y z);
+ [ apply opposite_of_max_side_compat; [now rewrite <- hhh
+ | rewrite <- PermutationA_Leibniz, PermutationA_3; auto 8; autoclass ]
+ | now rewrite <- hhhh;assumption ]
+end.
+Qed.
+
+Lemma generic_target : forall config,
+ generic_case config ->
+ target (!! config) = R2.center (SEC (support (!! config))).
+Proof using size_G.
+intros config [_ [? [? [? [? [? HpermSEC]]]]]]. unfold target.
+apply PermutationA_length in HpermSEC.
+destruct (on_SEC (support (!! config))) as [| ? [| ? [| ? [| ? ?]]]]; cbn in HpermSEC; lia || reflexivity.
+Qed.
+
+(** **** Results about [target] and [SEC] **)
+
+Lemma same_on_SEC_same_target : forall config1 config2,
+ PermutationA equiv (on_SEC (support (!! config1))) (on_SEC (support (!! config2))) ->
+ target (!! config1) = target (!! config2).
+Proof using size_G.
+intros config1 config2 Hperm. unfold target.
+assert (Hlen := PermutationA_length Hperm).
+destruct (on_SEC (support (!! config1))) as [| ? [| ? [| ? [| ? ?]]]] eqn:Hsec1,
+ (on_SEC (support (!! config2))) as [| ? [| ? [| ? [| ? ?]]]] eqn:Hsec2;
+reflexivity || simpl in Hlen; try lia.
+- now rewrite (PermutationA_1 _) in Hperm.
+- f_equal. setoid_rewrite SEC_on_SEC. now rewrite Hsec1, Hperm, Hsec2.
+- apply target_triangle_compat. now rewrite <- PermutationA_Leibniz.
+- f_equal. setoid_rewrite SEC_on_SEC. now rewrite Hsec1, Hperm, Hsec2.
+Qed.
+
+Lemma same_on_SEC_same_SECT : forall config1 config2,
+ PermutationA equiv (on_SEC (support (!! config1))) (on_SEC (support (!! config2))) ->
+ PermutationA equiv (SECT (!! config1)) (SECT (!! config2)).
+Proof using size_G.
+intros config1 config2 Hsame. unfold SECT.
+rewrite Hsame.
+apply same_on_SEC_same_target in Hsame.
+now rewrite Hsame.
+Qed.
+
+Lemma target_inside_SEC : forall config,
+ no_Majority config ->
+ (dist (target (!! config)) (R2.center (SEC (support (!! config))))
+ <= radius (SEC (support (!! config))))%R.
+Proof using size_G.
+Opaque Rmax. Opaque dist. Opaque middle.
+intros config Hmaj. unfold target.
+assert (Hlen := no_Majority_on_SEC_length Hmaj).
+destruct (on_SEC (support (!! config))) as [| pt1 [| pt2 [| pt3 [| pt l]]]] eqn:Hsec;
+simpl in Hlen; lia || clear Hlen; [| |].
++ rewrite R2_dist_defined_2.
+ rewrite SEC_on_SEC, Hsec, radius_is_max_dist, SEC_dueton.
+ simpl. unfold max_dist. simpl. etransitivity; apply Rmax_l.
++ rewrite SEC_on_SEC, Hsec. unfold target_triangle.
+ destruct (classify_triangle pt1 pt2 pt3) eqn:Htriangle.
+ - apply isobarycenter_3_pts_inside_SEC.
+ - rewrite classify_triangle_Isosceles_spec in Htriangle.
+ assert (Hin : InA equiv vertex (on_SEC (support (!! config)))).
+ { rewrite Hsec. decompose [and or] Htriangle; subst; intuition. }
+ unfold on_SEC in Hin. rewrite filter_InA in Hin; autoclass. destruct Hin as [_ Hin].
+ rewrite on_circle_true_iff, SEC_on_SEC, Hsec in Hin. changeR2. now rewrite Hin.
+ - unfold opposite_of_max_side. unfold Rle_bool.
+ do 2 match goal with |- context[Rle_dec ?x ?y] => destruct (Rle_dec x y) end;
+ match goal with |- (dist ?pt _ <= _)%R =>
+ assert (Hin : InA equiv pt (on_SEC (support (!! config)))) by (rewrite Hsec; intuition);
+ unfold on_SEC in Hin; rewrite filter_InA in Hin; autoclass; []; rewrite <- Hsec, <- SEC_on_SEC;
+ destruct Hin as [_ Hin]; rewrite on_circle_true_iff in Hin; changeR2; now rewrite Hin
+ end.
++ rewrite R2_dist_defined_2.
+ rewrite SEC_on_SEC, Hsec, radius_is_max_dist.
+ transitivity (dist pt1 (R2.center (SEC (pt1 :: pt2 :: pt3 :: pt :: l)))).
+ - apply dist_nonneg.
+ - apply max_dist_le. intuition.
+Transparent Rmax. Transparent middle.
+Qed.
+
+(** If the target is on the SEC, then we are in a non-equilateral triangle case. *)
+Lemma target_on_SEC_cases : forall config, no_Majority config ->
+ (on_circle (SEC (support (!! config))) (target (!! config)) = true <->
+ triangle_case config /\ ~equilateral_case config).
+Proof using size_G.
+intros config Hmaj. split.
+* intro Htarget.
+ rewrite SEC_on_SEC in Htarget. unfold target in *.
+ assert (Hlen := no_Majority_on_SEC_length Hmaj).
+ assert (Hnodup : NoDupA equiv (on_SEC (support (!! config)))) by apply on_SEC_NoDupA, support_NoDupA.
+ destruct (on_SEC (support (!! config))) as [| pt1 [| pt2 [| pt3 [| ? ?]]]] eqn:Hsec;
+ simpl in Hlen; lia || clear Hlen; [| |].
+ + exfalso.
+ assert (Heq : equiv pt1 pt2).
+ { rewrite SEC_dueton, on_circle_true_iff in Htarget.
+ rewrite SEC_on_SEC, Hsec, SEC_dueton in Htarget.
+ rewrite R2_dist_defined_2 in Htarget. cbn in Htarget.
+ rewrite <- dist_defined. changeR2. lra. }
+ inversion_clear Hnodup. intuition.
+ + unfold target_triangle in *. destruct (classify_triangle pt1 pt2 pt3) eqn:Htriangle.
+ - exfalso.
+ rewrite triangle_isobarycenter_inside in Htarget; try discriminate; [].
+ inversion_clear Hnodup. intuition.
+ - get_case config. split; trivial. intro Habs.
+ unfold triangle_case, equilateral_case in *.
+ destruct Habs as [_ [? [? [? [Hperm Hequilateral]]]]].
+ rewrite Hsec, PermutationA_Leibniz in Hperm.
+ rewrite <- (classify_triangle_compat Hperm), Htriangle in Hequilateral.
+ discriminate.
+ - get_case config. split; trivial. intro Habs.
+ unfold triangle_case, equilateral_case in *.
+ destruct Habs as [_ [? [? [? [Hperm Hequilateral]]]]].
+ rewrite Hsec, PermutationA_Leibniz in Hperm.
+ rewrite <- (classify_triangle_compat Hperm), Htriangle in Hequilateral.
+ discriminate.
+ + exfalso.
+ setoid_rewrite SEC_on_SEC in Htarget at 2. rewrite Hsec in Htarget.
+ rewrite center_on_circle in Htarget.
+ rewrite SEC_zero_radius_incl_singleton in Htarget. destruct Htarget as [pt Hpt].
+ assert (Heq : pt1 == pt2).
+ { transitivity pt.
+ - specialize (Hpt pt1). cbn in Hpt. intuition.
+ - specialize (Hpt pt2). cbn in Hpt. intuition. }
+ inversion_clear Hnodup. intuition.
+* intros [[_ [ptx [pty [ptz Hperm]]]] Hequilateral].
+ assert (Hlen := PermutationA_length Hperm).
+ destruct (on_SEC (support (!! config))) as [| pt1 [| pt2 [| pt3 [| ? ?]]]] eqn:Hsec; try discriminate; [].
+ destruct (classify_triangle pt1 pt2 pt3) eqn:Htriangle.
+ + get_case config. contradiction.
+ + erewrite (isosceles_target config ltac:(now rewrite Hsec)); try eassumption; [].
+ eapply proj2. rewrite <- (filter_InA _). unfold on_SEC in Hsec. rewrite Hsec.
+ rewrite classify_triangle_Isosceles_spec in Htriangle.
+ decompose [and or] Htriangle; subst; intuition.
+ + erewrite (scalene_target config ltac:(now rewrite Hsec)); try eassumption; [].
+ eapply proj2. rewrite <- (filter_InA _). unfold on_SEC in Hsec. rewrite Hsec.
+ unfold opposite_of_max_side.
+ do 2 match goal with |- context[Rle_bool ?x ?y] => destruct (Rle_bool x y) end; intuition.
+Qed.
+
+Lemma target_on_SEC_already_occupied : forall config,
+ no_Majority config ->
+ on_circle (SEC (support (!! config))) (target (!! config)) = true ->
+ InA equiv (target (!! config)) (support (!! config)).
+Proof using size_G.
+intros config Hmaj Htarget.
+apply target_on_SEC_cases in Htarget; trivial.
+destruct Htarget as [[_ [ptx [pty [ptz Hperm]]]] Hequilateral].
+assert (Hlen := PermutationA_length Hperm).
+destruct (on_SEC (support (!! config))) as [| pt1 [| pt2 [| pt3 [| ? ?]]]] eqn:Hsec;
+simpl in Hlen; discriminate || clear Hlen; [].
+unfold target. rewrite Hsec. unfold target_triangle.
+destruct (classify_triangle pt1 pt2 pt3) eqn:Htriangle.
++ get_case config. contradiction.
++ rewrite classify_triangle_Isosceles_spec in Htriangle.
+ decompose [and or] Htriangle; subst; clear Htriangle;
+ match goal with |- InA equiv ?pt (support (!! config)) =>
+ assert (Hin : InA equiv pt ([pt1; pt2; pt3])) by intuition;
+ rewrite <- Hsec in Hin; unfold on_SEC in Hin; now rewrite filter_InA in Hin; autoclass
+ end.
++ unfold opposite_of_max_side. unfold Rle_bool.
+ do 2 match goal with |- context[Rle_dec ?x ?y] => destruct (Rle_dec x y) end;
+ match goal with |- InA equiv ?pt (support (!! config)) =>
+ assert (Hin : InA equiv pt ([pt1; pt2; pt3])) by intuition;
+ rewrite <- Hsec in Hin; unfold on_SEC in Hin; now rewrite filter_InA in Hin; autoclass
+ end.
+Qed.
+
+End Morphisms.
+
+
+Lemma not_and_3: forall A B C: Prop,
+ Decidable.decidable A ->
+ Decidable.decidable B ->
+ ~ (A /\ B /\ C) <-> (~A \/ ~B \/ ~C).
+Proof using .
+ intros A B C hdecA hdecB.
+ split; intro h.
+ - rewrite not_and in h;auto.
+ destruct h as [h|h];auto.
+ rewrite not_and in h;auto.
+ - rewrite not_and;auto.
+ rewrite not_and;auto.
+Qed.
+
+Lemma not_and_4: forall A B C D: Prop,
+ Decidable.decidable A ->
+ Decidable.decidable B ->
+ Decidable.decidable C ->
+ ~ (A /\ B /\ C /\ D) <-> (~A \/ ~B \/ ~C \/ ~D).
+Proof using .
+ intros A B C D hdecA hdecB hdecC.
+ split; intro h.
+ - rewrite not_and_3 in h;auto.
+ destruct h as [h|[h|h]];auto.
+ rewrite not_and in h;auto.
+ - rewrite not_and_3;auto.
+ rewrite not_and;auto.
+Qed.
+
+(** Generic result of robograms using multiset observations. *)
+Lemma increase_move :
+ forall r da config pt,
+ ((!! config)[pt] < (!! (round r da config))[pt])%nat ->
+ exists id, get_location (round r da config id) == pt
+ /\ get_location (round r da config id) =/= get_location (config id).
+Proof using size_G.
+intros r da config pt Hlt.
+destruct (existsb (fun x => if get_location (round r da config x) =?= pt then
+ if get_location (config x) =?= pt then false else true else false) names) eqn:Hex.
+- apply existsb_exists in Hex.
+ destruct Hex as [id [Hin Heq_bool]].
+ exists id. revert Heq_bool. repeat destruct_match; discriminate || intros _.
+ split; congruence.
+- exfalso. rewrite <- negb_true_iff, forallb_existsb, forallb_forall in Hex.
+ (* Let us remove the In x (Gnames nG) and perform some rewriting. *)
+ assert (Hg : forall id, get_location (round r da config id) <> pt \/ get_location (config id) = pt).
+ { intro id. specialize (Hex id (In_names _)). revert Hex. repeat destruct_match; try discriminate; auto. }
+ (** We prove a contradiction by showing that the opposite inequality of Hlt holds. *)
+ clear Hex. revert Hlt. apply Nat.le_ngt.
+ assert ((@obs_is_ok (location * L) Loc _ MyRobots (@multiset_observation (location * L) Loc St MyRobots)
+ (!! config) config (origin, witness))).
+ { apply obs_from_config_spec. }
+ cbn -[config_list] in H.
+ assert ((@obs_is_ok (location * L) Loc _ MyRobots (@multiset_observation (location * L) Loc St MyRobots)
+ (!! (round r da config)) (round r da config) (origin, witness))).
+ { apply obs_from_config_spec. }
+ rewrite H ; autoclass; [].
+ rewrite H0 ; autoclass; [].
+ do 2 rewrite config_list_spec.
+ induction names as [| id l]; trivial; [].
+ destruct (get_location (round r da config id) =?= pt) as [Heq | Heq];cbn -[equiv_dec];
+ change (R2_EqDec (Datatypes.id (fst (config id))) pt) with ((Datatypes.id (fst (config id))) =?= pt);
+ (do 2 R2dec_full; simpl in *; subst; try lia; []); specialize (Hg id); intuition.
+Qed.
+
+Definition same_destination_if_moving r da config :=
+ forall id1 id2, List.In id1 (moving r da config) -> List.In id2 (moving r da config) ->
+ get_location (round r da config id1) == get_location (round r da config id2).
+
+Instance same_destination_if_moving_compat : Proper (equiv ==> equiv ==> equiv ==> iff) same_destination_if_moving.
+Proof using .
+intros r1 r2 Hr da1 da2 Hda config1 config2 Hconfig.
+unfold same_destination_if_moving.
+split; intros Hsame id1 id2 Hid1 Hid2.
+* transitivity (get_location (round r1 da1 config1 id1)).
+ + apply get_location_compat, round_compat; now symmetry.
+ + rewrite Hsame.
+ - now apply get_location_compat, round_compat.
+ - now rewrite Hr, Hda, Hconfig.
+ - now rewrite Hr, Hda, Hconfig.
+* transitivity (get_location (round r2 da2 config2 id1)).
+ + apply get_location_compat, round_compat; now symmetry.
+ + rewrite Hsame.
+ - now apply get_location_compat, round_compat.
+ - now rewrite <- Hr, <- Hda, <- Hconfig.
+ - now rewrite <- Hr, <- Hda, <- Hconfig.
+Qed.
+
+Definition same_destination_if_active r da config :=
+ forall id1 id2, List.In id1 (active da) -> List.In id2 (active da) ->
+ get_location (round r da config id1) == get_location (round r da config id2).
+
+Instance same_destination_if_active_compat : Proper (equiv ==> equiv ==> equiv ==> iff) same_destination_if_active.
+Proof using .
+intros r1 r2 Hr da1 da2 Hda config1 config2 Hconfig.
+unfold same_destination_if_active.
+split; intros Hsame id1 id2 Hid1 Hid2.
+* transitivity (get_location (round r1 da1 config1 id1)).
+ + apply get_location_compat, round_compat; now symmetry.
+ + rewrite Hsame.
+ - now apply get_location_compat, round_compat.
+ - now rewrite Hda.
+ - now rewrite Hda.
+* transitivity (get_location (round r2 da2 config2 id1)).
+ + apply get_location_compat, round_compat; now symmetry.
+ + rewrite Hsame.
+ - now apply get_location_compat, round_compat.
+ - now rewrite <- Hda.
+ - now rewrite <- Hda.
+Qed.
+
+Lemma same_destination_incl : forall r da config, SSYNC_da da ->
+ same_destination_if_active r da config -> same_destination_if_moving r da config.
+Proof using .
+intros r da config Hssync Hsame id1 id2 Hid1 Hid2.
+apply Hsame; eapply moving_active; eauto.
+Qed.
+
+
+(** With [same_destination], we can strengthen the previous result into an equivalence. *)
+Theorem increase_move_iff : forall r da config,
+ SSYNC_da da ->
+ same_destination_if_moving r da config ->
+ forall pt,
+ ((!! config)[pt] < (!! (round r da config))[pt])%nat <->
+ exists id, get_location (round r da config id) == pt
+ /\ get_location (round r da config id) =/= get_location (config id).
+Proof using size_G.
+intros r da config Hssync Hsame_destination pt. split.
+* apply increase_move.
+* intros [id [Hid Hroundid]].
+ assert (Hdest : forall id', List.In id' (moving r da config) ->
+ get_location (round r da config id') == pt).
+ { intros. rewrite <- Hid. apply Hsame_destination; trivial; [].
+ now rewrite moving_spec. }
+ assert (Hstay : forall id, get_location (config id) == pt -> get_location (round r da config id) == pt).
+ { intros id' Hid'. destruct (get_location (round r da config id') =?= pt) as [Heq | Heq]; trivial; [].
+ apply Hdest. rewrite (moving_spec r). intro Habs. rewrite Habs in Heq. contradiction. }
+ setoid_rewrite WithMultiplicityLight.obs_from_config_fst_spec; autoclass; [].
+ do 2 rewrite config_list_spec.
+ assert (Hin : List.In id names) by apply In_names.
+ induction names as [| id' l]; try (now inversion Hin); [].
+ inversion_clear Hin.
+ + subst id'. clear IHl. simpl. R2dec_full.
+ - rewrite <- Hid in Heq. now elim Hroundid.
+ - R2dec_full; try contradiction; [].
+ apply le_n_S. induction l as [| id' ?]; simpl.
+ -- reflexivity.
+ -- repeat R2dec_full; try now idtac + apply le_n_S + apply le_S; apply IHl.
+ exfalso. now generalize (Hstay id' ltac:(assumption)).
+ + apply IHl in H. simpl. repeat R2dec_full; try (simpl in *; lia); [].
+ elim Hneq. apply Hdest. rewrite moving_spec. intro Habs. rewrite Habs in Hneq. contradiction.
+Qed.
+
+
+Section SSYNC_Results.
+
+Variable da : similarity_da.
+Hypothesis Hssync : SSYNC_da da.
+
+(* Robots partitionned wrt to their location, activation and color. *)
+Definition light_on l pt config :=
+ List.filter (fun id => get_light (config id) ==b l) (on_loc pt config).
+Notation black_on := (light_on false).
+Notation white_on := (light_on true).
+Definition active_on pt config :=
+ List.filter (fun id => equiv_decb (get_location (config id)) pt) (active da).
+Definition idle_on pt config :=
+ List.filter (fun id => equiv_decb (get_location (config id)) pt) (idle da).
+Definition light_active_on l pt config :=
+ List.filter (fun id => get_light (config id) ==b l) (active_on pt config).
+Notation black_active_on := (light_active_on false).
+Notation white_active_on := (light_active_on true).
+Definition light_idle_on l pt config :=
+ List.filter (fun id => get_light (config id) ==b l) (idle_on pt config).
+Notation black_idle_on := (light_idle_on false).
+Notation white_idle_on := (light_idle_on true).
+
+Lemma active_on_split : forall pt config,
+ PermutationA equiv (active_on pt config) (black_active_on pt config ++ white_active_on pt config).
+Proof using .
+intros pt config. unfold black_active_on, white_active_on.
+induction (active_on pt) as [| id l]; cbn [List.filter]; try reflexivity; [].
+do 2 destruct_match; cbn [app].
+- reflect_bool. congruence.
+- now constructor.
+- rewrite <- PermutationA_middle; autoclass.
+ now constructor.
+- exfalso. destruct (get_light (config id)); cbn in *; discriminate.
+Qed.
+
+Lemma idle_on_split : forall pt config,
+ PermutationA equiv (idle_on pt config) (black_idle_on pt config ++ white_idle_on pt config).
+Proof using .
+intros pt config. unfold black_idle_on, white_idle_on.
+induction (idle_on pt) as [| id l]; cbn [List.filter]; try reflexivity; [].
+do 2 destruct_match; cbn [app].
+- reflect_bool. congruence.
+- now constructor.
+- rewrite <- PermutationA_middle; autoclass.
+ now constructor.
+- exfalso. destruct (get_light (config id)); cbn in *; discriminate.
+Qed.
+
+Lemma on_loc_split : forall pt config,
+ PermutationA equiv (on_loc pt config) (active_on pt config ++ idle_on pt config).
+Proof using .
+intros pt config. symmetry.
+unfold on_loc, active_on, active, idle_on, idle.
+induction names as [| id l]; cbn [List.filter]; try reflexivity; [].
+do 2 (destruct_match; cbn [app List.filter negb]).
+- now constructor.
+- apply IHl.
+- rewrite <- PermutationA_middle; autoclass.
+ now constructor.
+- apply IHl.
+Qed.
+
+Instance on_loc_compat : Proper (equiv ==> equiv ==> eq) on_loc.
+Proof using .
+intros pt1 pt2 Hpt config1 config2 Hconfig.
+unfold on_loc.
+apply ListComplements.filter_extensionality_compat.
+- intros xx id ?. subst xx. now rewrite Hconfig, Hpt.
+- reflexivity.
+Qed.
+
+Instance Light_on_compat : Proper (eq ==> equiv ==> equiv ==> eq) light_on.
+Proof using .
+intros xx l ? pt1 pt2 Hpt config1 config2 Hconfig. subst xx.
+unfold light_on.
+apply ListComplements.filter_extensionality_compat.
+- intros xx id ?. subst xx. now rewrite Hconfig.
+- now f_equiv.
+Qed.
+
+Lemma length_light_on : forall l pt config,
+ length (light_on l pt config) = (colors (snd (!!! (config, (0%VS, witness)))))[(pt, l)].
+Proof using .
+intros l pt config. destruct (obs_from_config_spec config (0%VS, witness)) as [_ [_ Hobs]].
+rewrite Hobs, config_list_spec, count_filter_length, filter_map, map_length.
+unfold black_on, on_loc. rewrite <- filter_andb. f_equal. f_equiv.
+intros xx id ?. subst xx. clear.
+symmetry. destruct_match; symmetry.
+- revert_one @equiv. intros [Heq1 Heq2]. unfold get_light. simpl get_location.
+ rewrite Heq1, Heq2. now simpl_bool.
+- reflect_bool. destruct (get_light (config id) =?= l); firstorder.
+Qed.
+
+Lemma on_loc_color_split : forall pt config,
+ PermutationA equiv (on_loc pt config) (black_on pt config ++ white_on pt config).
+Proof using .
+intros pt config.
+unfold light_on, on_loc.
+induction names as [| id l]; cbn [List.filter]; try reflexivity; [].
+repeat (destruct_match; cbn [app List.filter]); reflect_bool.
+- congruence.
+- now constructor.
+- rewrite <- PermutationA_middle; autoclass.
+ now constructor.
+- destruct (get_light (config id)); intuition.
+- assumption.
+Qed.
+
+(* TODO: use have_obs everywhere
+ TODO: make a tactic to reorder filtering *)
+
+Lemma active_on_loc_swap : forall pt config,
+ List.filter (activate da) (on_loc pt config) = active_on pt config.
+Proof using .
+intros pt config.
+unfold on_loc, active_on, active.
+rewrite <- 2 filter_andb.
+apply ListComplements.filter_extensionality_compat.
+- repeat intro. subst. apply andb_comm.
+- reflexivity.
+Qed.
+
+Lemma idle_on_loc_swap : forall pt config,
+ List.filter (fun id => negb (activate da id)) (on_loc pt config) = idle_on pt config.
+Proof using .
+intros pt config.
+unfold on_loc, idle_on, idle.
+rewrite <- 2 filter_andb.
+apply ListComplements.filter_extensionality_compat.
+- repeat intro. subst. apply andb_comm.
+- reflexivity.
+Qed.
+
+Lemma on_loc_color_swap : forall config pt l id_l,
+ List.filter (fun id => get_location (config id) ==b pt)
+ (List.filter (fun id => get_light (config id) ==b l) id_l)
+ = List.filter (fun id => get_light (config id) ==b l)
+ (List.filter (fun id => get_location (config id) ==b pt) id_l).
+Proof using .
+intros config pt l id_l.
+rewrite <- 2 filter_andb.
+apply ListComplements.filter_extensionality_compat.
+- repeat intro. subst. apply andb_comm.
+- reflexivity.
+Qed.
+
+Lemma on_loc_split_active_colors : forall pt config,
+ PermutationA equiv (on_loc pt config)
+ (active_on pt config ++ black_idle_on pt config ++ white_idle_on pt config).
+Proof using .
+intros pt config.
+assert (Hperm := partition_PermutationA (eqA := equiv) (activate da) (on_loc pt config)).
+rewrite <- Hperm, partition_filter, active_on_loc_swap, idle_on_loc_swap.
+cbn [fst snd]. f_equiv.
+unfold idle_on.
+assert (Hperm' := partition_PermutationA (eqA := equiv) (fun id => get_light (config id) ==b false) (idle da)).
+rewrite <- Hperm', partition_filter.
+cbn [fst snd].
+rewrite filter_app. f_equiv.
++ now rewrite on_loc_color_swap.
++ assert (Heq : (eq ==> eq)%signature (fun id => negb (get_light (config id) ==b false))
+ (fun id => get_light (config id) ==b true)).
+ { intros xx id ?. subst xx. now destruct (get_light (config id)). }
+ rewrite Heq, on_loc_color_swap.
+ reflexivity.
+Qed.
+
+Hint Resolve pos_in_config mult_div2_In color_bivalent_bivalent : core.
+
+
+Section BivalentResults.
+
+Variable config : configuration.
+Hypothesis Hbivalent : bivalent config.
+
+Definition loc_g1 := get_location (config (Good g1)).
+Definition loc_others := find_other_loc (!!config) loc_g1.
+
+Notation active_on_g1 := (active_on loc_g1 config).
+Notation active_on_other := (active_on loc_others config).
+Notation idle_on_g1 := (idle_on loc_g1 config).
+Notation idle_on_other := (idle_on loc_others config).
+Notation black_active_on_g1 := (black_active_on loc_g1 config).
+Notation black_active_on_other := (black_active_on loc_others config).
+Notation white_active_on_g1 := (white_active_on loc_g1 config).
+Notation white_active_on_other := (white_active_on loc_others config).
+Notation black_idle_on_g1 := (black_idle_on loc_g1 config).
+Notation black_idle_on_other := (black_idle_on loc_others config).
+Notation white_idle_on_g1 := (white_idle_on loc_g1 config).
+Notation white_idle_on_other := (white_idle_on loc_others config).
+Notation black_on_g1 := (black_on loc_g1 config).
+Notation black_on_other := (black_on loc_others config).
+Notation white_on_g1 := (white_on loc_g1 config).
+Notation white_on_other := (white_on loc_others config).
+
+(* Some trivial lemmas that are overused *)
+
+Lemma bivalent_even : Nat.Even (nG + nB).
+Proof using Hbivalent. now destruct Hbivalent. Qed.
+
+Local Definition loc_g1_In : In loc_g1 (!! config) := pos_in_config _ _ _.
+Local Definition loc_g1_In_fst : forall st, In loc_g1 (fst (!!! (config, st))) := fun st => pos_in_config _ st _.
+
+Local Lemma loc_others_In : In loc_others (!! config).
+Proof using Hbivalent.
+rewrite <- support_spec, obs_fst, find_other_loc_spec.
+- now right; left.
+- now rewrite bivalent_obs_spec.
+- apply pos_in_config.
+Qed.
+
+Local Lemma loc_others_In_fst : forall st, In loc_others (fst (!!! (config, st))).
+Proof using Hbivalent. intro. apply loc_others_In. Qed.
+
+Local Lemma In_fst_config : forall id, In (get_location (config id)) (fst (!!! (config, (0%VS, witness)))).
+Proof using . intro id. apply pos_in_config. Qed.
+
+Local Lemma loc_g1_diff_others: loc_g1 =/= loc_others.
+Proof using Hbivalent.
+unfold loc_others.
+symmetry.
+rewrite obs_fst.
+apply find_other_loc_diff.
+- now apply bivalent_obs_spec.
+- apply pos_in_config.
+Qed.
+
+Local Lemma loc_others_diff_g1 : loc_others =/= loc_g1.
+Proof using Hbivalent.
+unfold loc_others. rewrite obs_fst. apply find_other_loc_diff.
+- now rewrite bivalent_obs_spec.
+- apply loc_g1_In_fst.
+Qed.
+
+Local Lemma other_than_loc_g1 : forall id, get_location (config id) =/= loc_g1 -> get_location (config id) == loc_others.
+Proof using Hbivalent.
+intros.
+eapply (bivalent_same_location (0%VS, witness) Hbivalent (pt3 := loc_g1)).
+- apply pos_in_config.
+- apply loc_others_In_fst.
+- apply pos_in_config.
+- assumption.
+- symmetry. apply loc_g1_diff_others.
+Qed.
+
+Local Lemma other_than_loc_others : forall id, get_location (config id) =/= loc_others -> get_location (config id) == loc_g1.
+Proof using Hbivalent.
+intros.
+eapply (bivalent_same_location (0%VS, witness) Hbivalent (pt3 := loc_others)).
+- apply pos_in_config.
+- apply pos_in_config.
+- apply loc_others_In_fst.
+- assumption.
+- apply loc_g1_diff_others.
+Qed.
+
+Corollary find_other_loc_loc_others : find_other_loc (!! config) loc_others == loc_g1.
+Proof using Hbivalent.
+assert (Hin : In (find_other_loc (fst (!!! (config, (0%VS, witness)))) loc_others) (!! config)).
+{ apply find_other_loc_In.
+ - now rewrite bivalent_obs_spec.
+ - apply loc_others_In. }
+rewrite obs_from_config_In in Hin. destruct Hin as [id Hid].
+rewrite <- Hid. apply other_than_loc_others.
+rewrite Hid. apply find_other_loc_diff.
+- now rewrite bivalent_obs_spec.
+- apply loc_others_In.
+Qed.
+
+Local Lemma have_support : PermutationA equiv (support (!! (config))) (cons loc_g1 (cons loc_others nil)).
+Proof using Hbivalent.
+rewrite obs_fst.
+apply find_other_loc_spec.
+- now rewrite bivalent_obs_spec.
+- apply loc_g1_In_fst.
+Qed.
+
+Local Lemma loc_g1_mult : (!! config)[loc_g1] = Nat.div2 (nG + nB).
+Proof using Hbivalent.
+apply extend_bivalent in Hbivalent.
+destruct Hbivalent as [Heven [Hn [pt1 [pt2 [Hdiff [Hpt1 [Hpt2 [_ [Hin _]]]]]]]]].
+changeR2. specialize (Hin _ loc_g1_In).
+now destruct Hin as [Heq | Heq]; rewrite Heq.
+Qed.
+
+Local Lemma loc_others_mult : (!! config)[loc_others] = Nat.div2 (nG + nB).
+Proof using Hbivalent.
+assert (Hbiv := proj1 (extend_bivalent _) Hbivalent).
+destruct Hbiv as [Heven [Hn [pt1 [pt2 [Hdiff [Hpt1 [Hpt2 [_ [Hin _]]]]]]]]].
+changeR2. specialize (Hin _ loc_others_In).
+now destruct Hin as [Heq | Heq]; rewrite Heq.
+Qed.
+
+Lemma bivalent_In_iff_mult_eq_half :
+ forall pt, In pt (!! config) <-> (!! config)[pt] = Nat.div2 (nG + nB).
+Proof using size_G Hbivalent.
+intro pt. split; intro Hin.
++ rewrite <- support_spec in Hin.
+ apply extend_bivalent in Hbivalent.
+ destruct Hbivalent as [_ [_ [pt1 [pt2 [Hdiff [Hpt1 [Hpt2 [Hsupp [Hin_supp Hother]]]]]]]]].
+ changeR2. rewrite Hsupp, InA_cons, InA_singleton in Hin.
+ destruct Hin as [Heq | Heq]; rewrite Heq; auto.
++ unfold In. rewrite Hin. auto.
+Qed.
+
+Lemma loc_g1_or_loc_others_eqb : forall id,
+ get_location (config id) ==b loc_others = negb (get_location (config id) ==b loc_g1).
+Proof using Hbivalent.
+intro id. unfold loc_others.
+destruct (get_location (config id) ==b loc_g1) eqn:Hcase; cbn [negb]; reflect_bool.
++ rewrite Hcase, obs_fst.
+ symmetry. apply find_other_loc_diff.
+ - now rewrite bivalent_obs_spec.
+ - apply pos_in_config.
++ apply (bivalent_same_location (0%VS, witness) Hbivalent (pt3 := loc_g1)).
+ - apply pos_in_config.
+ - rewrite obs_fst.
+ apply find_other_loc_In, pos_in_config.
+ now rewrite bivalent_obs_spec.
+ - apply loc_g1_In.
+ - assumption.
+ - rewrite obs_fst.
+ apply find_other_loc_diff, pos_in_config.
+ now rewrite bivalent_obs_spec.
+Qed.
+
+Corollary bivalent_get_location_cases : forall id,
+ get_location (config id) == loc_g1 \/ get_location (config id) == loc_others.
+Proof using Hbivalent.
+intro id.
+assert (Hbool := loc_g1_or_loc_others_eqb id).
+destruct (get_location (config id) ==b loc_g1) eqn:Hcase.
+- left. now reflect_bool.
+- right. now reflect_bool.
+Qed.
+
+(* TODO: see if it is useful elsewhere *)
+Lemma wlog_sym : forall (x y : location) P, Proper (equiv ==> equiv ==> iff) P ->
+ (P x y -> P y x) ->
+ forall x' y', PermutationA equiv (cons x (cons y nil)) (cons x' (cons y' nil)) ->
+ P x y -> P x' y'.
+Proof using .
+intros x y P HP Hsym x' y' Hperm HPxy.
+rewrite PermutationA_2 in Hperm; auto; [].
+ destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]]; rewrite <- Heq1, <- Heq2; auto.
+Qed.
+
+Lemma find_max_black_comm : ~ color_bivalent config ->
+ forall st pt1 pt2,
+ In pt1 (!! config) -> In pt2 (!! config) ->
+ find_max_black (!!! (config, st)) pt1 pt2 == find_max_black (!!! (config, st)) pt2 pt1.
+Proof using size_G Hbivalent.
+intros Hcolor st pt1 pt2 Hin1 Hin2. unfold find_max_black.
+repeat destruct_match; try reflexivity || (rewrite Nat.leb_gt in *; lia); [].
+destruct (pt1 =?= pt2) as [? | Hneq]; auto; [].
+exfalso. apply Hcolor.
+assert (Hbiv := Hbivalent). destruct Hbiv as [Heven [Hn [pt1' [pt2' [Hdiff [Hpt1' Hpt2']]]]]].
+repeat split; trivial; [].
+exists pt1', pt2'. repeat split; trivial; [].
+assert (Heq : (colors (snd (!!! (config, st))))[(pt1, false)]
+ = (colors (snd (!!! (config, st))))[(pt2, false)]).
+{ rewrite Nat.leb_le in *. lia. }
+pattern pt1', pt2'.
+apply (@wlog_sym pt1 pt2).
++ intros ? ? Heq1 ? ? Heq2. rewrite 2 Forall_forall. now rewrite Heq1, Heq2.
++ rewrite 2 Forall_forall. intros Hsym l Hl. symmetry; auto.
++ transitivity (support (!! config)); rewrite obs_fst; changeR2.
+ - symmetry. apply bivalent_support; auto.
+ - apply bivalent_support; auto; rewrite <- obs_fst; now apply mult_div2_In.
++ rewrite Forall_forall. intros [] _; trivial; [].
+ (* white *)
+ rewrite <- 2 length_light_on in *.
+ rewrite 2 (colors_indep config (0%VS, witness) (0%VS, witness)), <- 2 length_light_on in Heq.
+ rewrite bivalent_In_iff_mult_eq_half in Hin1, Hin2; auto.
+ assert (Hlen : length (on_loc pt1 config) = length (on_loc pt2 config)).
+ { now rewrite <- (obs_from_config_on_loc _ (0%VS, witness)), Hin1, <- Hin2, obs_from_config_on_loc. }
+ rewrite (on_loc_color_split pt1 config), (on_loc_color_split pt2 config), 2 app_length in Hlen.
+ lia.
+Qed.
+
+Hint Resolve bivalent_even pos_in_config loc_g1_In loc_g1_In_fst loc_others_In loc_others_In_fst
+ In_fst_config loc_others_diff_g1 loc_g1_mult loc_others_mult loc_g1_diff_others
+ other_than_loc_g1 other_than_loc_others mult_div2_In color_bivalent_bivalent : core.
+
+Definition active_partition :=
+ List.partition (fun id => equiv_decb (get_location (config id)) loc_g1) (active da).
+
+Lemma active_partition_spec : active_partition = (active_on_g1, active_on_other).
+Proof using Hbivalent.
+unfold active_on, active_partition.
+rewrite partition_filter. f_equal.
+rewrite <- eqlistA_Leibniz.
+apply filter_extensionalityA_compat; try reflexivity; [].
+intros xx id ?. subst xx. unfold loc_others. symmetry.
+destruct (get_location (config id) ==b loc_g1) eqn:Hcase; reflect_bool.
++ rewrite Hcase. symmetry. rewrite obs_fst.
+ apply find_other_loc_diff; auto.
+ rewrite bivalent_obs_spec; auto.
++ eapply (bivalent_same_location (0%VS, witness) Hbivalent (pt3 := loc_g1)); auto.
+Qed.
+
+Lemma active_split : PermutationA equiv (active_on_g1 ++ active_on_other) (active da).
+Proof using Hbivalent.
+ replace active_on_g1 with (fst active_partition).
+ replace active_on_other with (snd active_partition).
+ { apply partition_PermutationA. }
+ { now rewrite active_partition_spec. }
+ { now rewrite active_partition_spec. }
+Qed.
+
+Lemma idle_split: PermutationA equiv (idle da) (idle_on_g1 ++ idle_on_other).
+Proof using Hbivalent.
+unfold idle_on.
+induction (idle da); cbn [List.filter]; try reflexivity; [].
+rewrite loc_g1_or_loc_others_eqb; auto; [].
+changeR2. destruct_match; cbn [negb app].
+- now constructor.
+- rewrite <- PermutationA_middle; autoclass.
+ now constructor.
+Qed.
+
+End BivalentResults.
+
+Hint Resolve bivalent_even pos_in_config loc_g1_In loc_g1_In_fst loc_others_In loc_others_In_fst
+ In_fst_config loc_others_diff_g1 loc_g1_mult loc_others_mult loc_g1_diff_others
+ other_than_loc_g1 other_than_loc_others mult_div2_In color_bivalent_bivalent : core.
+
+
+(** We express the behavior of the algorithm in the global (demon) frame of reference. *)
+Theorem round_simplify : forall config,
+ round gatherR2 da config
+ == fun id =>
+ if da.(activate) id
+ then
+ let obs := !!!(config, config id) in
+ if bivalent_obs obs
+ then if color_bivalent_obs obs
+ then if observer_lght (snd obs)
+ then (middle (loc_g1 config) (loc_others config), false)
+ else (get_location (config id), true) (* was: (other_loc, true) *)
+ else let maj_black := find_max_black obs (loc_g1 config) (loc_others config) in
+ (maj_black, observer_lght (snd obs))
+ else match support (max (fst obs)) with
+ | nil => config id (* only happen with no robots *)
+ | pt :: nil => (pt, snd (config id)) (* majority tower *)
+ | _ => if is_clean (fst obs) then (target (fst obs), snd (config id)) else
+ if mem equiv_dec (get_location (config id)) (SECT (fst obs))
+ then config id else (target (fst obs), snd (config id))
+ end
+ else config id.
+Proof using Hssync.
+intro config.
+rewrite SSYNC_round_simplify; trivial; [].
+apply no_byz_eq.
+intro g. destruct_match; try reflexivity; [].
+cbv zeta.
+set (sim := change_frame da config g).
+set (new_frame := frame_choice_bijection sim).
+assert (Hsim : Proper (equiv ==> equiv) new_frame). { intros ? ? Heq. now rewrite Heq. }
+assert (Proper (equiv ==> equiv) (Bijection.retraction sim)) by now apply Bijection.retraction_compat.
+assert (Hinj : Preliminary.injective equiv equiv new_frame) by apply injective.
+assert (Hcenter : 0%VS == sim (get_location (config (Good g)))).
+{ rewrite <- (center_prop sim).
+ f_equiv.
+ enough (center sim == get_location (config (Good g))).
+ { apply H1. }
+ changeR2.
+ apply similarity_center. }
+set (Psim := precondition_satisfied da config g).
+set (local_config := map_config (lift (existT precondition new_frame Psim)) config).
+set (local_state := local_config (Good g)).
+set (local_obs := !!! (local_config, local_state)).
+set (local_robot_decision := gatherR2 local_obs).
+set (choice := choose_update da local_config g local_robot_decision).
+set (new_local_state := update local_config g sim local_robot_decision choice).
+set (global_obs := (!!! (config, config (Good g)))).
+(* The update function does nothing. *)
+change new_local_state with local_robot_decision.
+unfold local_robot_decision, gatherR2. simpl pgm.
+unfold gatherR2_pgmLight.
+(* Expressing the local observation in terms of the global one. *)
+assert (Hobs : local_obs == (map (sim_f sim) (fst global_obs), map_light (sim_f sim) (snd global_obs))).
+{ unfold local_obs, local_state, local_config. unfold map_config at 2.
+ now rewrite (WithMultiplicityLight.obs_from_config_map _ Hsim Hinj
+ (precondition_satisfied da config g) config (config (Good g))). }
+(* Then the tests are the same in the local or global frame. *)
+assert (Hbiv : bivalent_obs local_obs = bivalent_obs global_obs).
+{ rewrite Hobs. apply bivalent_obs_morph. }
+assert (Hcol_biv : color_bivalent_obs local_obs = color_bivalent_obs global_obs).
+{ rewrite Hobs. apply color_bivalent_obs_morph. }
+assert (Hlight : observer_lght (snd local_obs) = observer_lght (snd global_obs)) by now rewrite Hobs.
+rewrite Hbiv, Hcol_biv, Hlight.
+change new_frame with (sim_f sim).
+destruct (bivalent_obs global_obs) eqn:Hcase_biv.
+* (* Bivalent cases *)
+ assert (Hperm : PermutationA equiv (cons (get_location (config (Good g)))
+ (cons (find_other_loc (fst global_obs) (get_location (config (Good g)))) nil))
+ (cons (loc_g1 config) (cons (loc_others config) nil))).
+ { rewrite <- have_support. apply NoDupA_inclA_length_PermutationA; auto.
+ + repeat constructor; [rewrite InA_singleton | now rewrite InA_nil].
+ intro Habs. symmetry in Habs. revert Habs.
+ apply find_other_loc_diff, pos_in_config; auto.
+ + intros pt Hpt. rewrite InA_cons, InA_singleton in Hpt.
+ destruct Hpt as [Hpt | Hpt]; rewrite Hpt.
+ - rewrite support_spec. apply pos_in_config.
+ - rewrite support_spec. apply find_other_loc_In; auto.
+ + rewrite have_support; auto. rewrite <- bivalent_obs_spec. apply Hcase_biv.
+ + rewrite <- bivalent_obs_spec. apply Hcase_biv. }
+ destruct (color_bivalent_obs global_obs) eqn:Hcase_col_biv;
+ [destruct (observer_lght (snd global_obs)) eqn:Hcase_light |].
+ + (* color bivalent and white observer *)
+ split; try reflexivity; [].
+ cbn -[equiv middle inverse loc_g1].
+ transitivity (middle (sim â»Â¹ 0%VS) (sim â»Â¹ (find_other_loc (fst local_obs) 0%VS))).
+ - now rewrite R2_middle_morph.
+ - change ((sim â»Â¹) 0%VS) with (center (change_frame da config g)).
+ rewrite similarity_center.
+ rewrite Hcenter, Hobs. cbn [fst]. rewrite find_other_loc_morph.
+ match goal with |- context[Bijection.section (sim_f (sim â»Â¹)) (Bijection.section (sim_f sim) ?x)] =>
+ change (Bijection.section (sim_f (sim â»Â¹)) (Bijection.section (sim_f sim) ?x)) with ((sim â»Â¹ ∘ sim) x) end.
+ rewrite (compose_inverse_l sim _). cbn [sim_f id Bijection.id Bijection.section].
+ rewrite PermutationA_2 in Hperm; auto.
+ destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]];
+ rewrite <- Heq1, <- Heq2; auto using middle_comm.
+ + (* color bivalent and black observer *)
+ Typeclasses eauto := (dfs) 5.
+ rewrite Hcenter. split; try reflexivity; [].
+ apply Bijection.retraction_section.
+ + (* bivalent but not color bivalent *)
+ split; try reflexivity; []. cbn -[equiv inverse loc_g1].
+ transitivity (find_max_black (map (sim â»Â¹) (fst local_obs), map_light (sim â»Â¹) (snd local_obs))
+ ((sim â»Â¹) 0%VS) ((sim â»Â¹) (find_other_loc (fst local_obs) 0%VS))).
+ { symmetry. apply find_max_black_morph. }
+ transitivity (find_max_black global_obs (get_location (config (Good g))) (find_other_loc (fst global_obs) (get_location (config (Good g))))).
+ 2:{ apply PermutationA_2 in Hperm; auto.
+ destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]]; rewrite <- Heq1, <- Heq2; auto.
+ apply find_max_black_comm.
+ - rewrite <- bivalent_obs_spec. apply Hcase_biv.
+ - rewrite <- color_bivalent_obs_spec, not_true_iff_false.
+ apply Hcase_col_biv.
+ - apply pos_in_config.
+ - apply find_other_loc_In, pos_in_config; auto. }
+ f_equiv.
+ - split; cbn -[equiv].
+ -- rewrite Hobs. cbn -[equiv]. rewrite map_merge; autoclass; [].
+ setoid_rewrite <- map_id at 3.
+ apply map_extensionality_compat; try (now repeat intro); [].
+ apply Bijection.retraction_section.
+ -- (* FIXME: rewrite Hobs fails here *)
+ transitivity (map_light (Bijection.retraction sim)
+ (snd (map new_frame (fst global_obs), map_light new_frame (snd global_obs)))).
+ { now apply map_light_compat, snd_compat_pactole. }
+ cbn [snd]. rewrite map_light_merge; trivial.
+ transitivity (map_light id (snd global_obs)); [| now apply map_light_id].
+ apply map_light_extensionality_compat; try (now repeat intro); [].
+ apply Bijection.retraction_section.
+ - apply (similarity_center da).
+ - (* TODO: perform the rewrite in the other direction *)
+ rewrite <- find_other_loc_morph. f_equiv.
+ -- rewrite Hobs. cbn [fst]. rewrite map_merge; auto; [].
+ setoid_rewrite <- map_id at 3. apply map_extensionality_compat; [now autoclass |].
+ apply Bijection.retraction_section.
+ -- apply (similarity_center da).
+* (* not bivalent *)
+ unfold gatherR2_old_pgm.
+ assert (supp_nonempty := support_non_nil config).
+ assert (Hperm : PermutationA equiv (List.map sim (support (max (fst global_obs))))
+ (support (max (fst local_obs)))).
+ { now rewrite <- map_sim_support, <- max_morph, Hobs. }
+ assert (Hlen := PermutationA_length Hperm).
+ destruct (support (max (fst global_obs))) as [| pt1 [| pt2 l]] eqn:Hmax,
+ (support (max (fst local_obs))) as [| pt1' [| pt2' l']];
+ simpl in Hlen; discriminate || clear Hlen; [| |].
+ + (* No maximal tower *)
+ rewrite support_nil, max_is_empty in Hmax. elim (obs_non_nil _ Hmax).
+ + (* One maximal tower *)
+ cbn -[equiv] in Hperm. rewrite (PermutationA_1 _) in Hperm.
+ rewrite <- Hperm. split; [apply Bijection.retraction_section | reflexivity].
+ + (* Multiple maximal towers *)
+ assert (Hclean : is_clean (fst local_obs) = is_clean (fst global_obs)).
+ { rewrite Hobs. cbn [fst]. now apply is_clean_morph. }
+ assert (Hmem : mem equiv_dec 0%VS (SECT (fst local_obs))
+ = mem equiv_dec (get_location (config (Good g))) (SECT (fst global_obs))).
+ { etransitivity; [| now apply (mem_injective_map _ Hsim)].
+ apply mem_compat; trivial; []. rewrite Hobs. cbn [fst]. now rewrite SECT_morph. }
+ rewrite Hclean, Hmem.
+ repeat destruct_match.
+ - (* Clean case *)
+ cbn -[equiv inverse]. split; try reflexivity; [].
+ rewrite Hobs. cbn [fst]. rewrite target_morph; trivial; [].
+ apply Bijection.retraction_section.
+ - (* Dirty case & on SECT *)
+ rewrite Hcenter. cbn -[equiv]. rewrite Bijection.retraction_section.
+ split; reflexivity.
+ - (* Dirty case & not on SECT *)
+ rewrite Hobs. cbn -[equiv].
+ rewrite target_morph, Bijection.retraction_section; trivial; [].
+ reflexivity.
+Qed.
+
+(** Since colors are not modified outside the color_bivalent case, changing robots are always moving. *)
+Lemma changing_eq_moving : forall config, ~color_bivalent config ->
+ changing gatherR2 da config = moving gatherR2 da config.
+Proof using Hssync.
+intros config Hcolor.
+unfold moving, changing, equiv_decb.
+induction names as [| id l]; cbn -[equiv_dec get_location]; trivial; [].
+repeat destruct_match; try discriminate.
++ apply IHl.
++ exfalso. match goal with H : _ == _ |- _ => rewrite H in * end. intuition.
++ exfalso. revert_one @complement. intro Habs. apply Habs. clear Habs.
+ split; trivial; [].
+ rewrite (round_simplify config id).
+ destruct_match; try reflexivity; [].
+ cbn zeta. destruct_match.
+ - rewrite <- (color_bivalent_obs_spec config (config id)), not_true_iff_false in Hcolor.
+ changeR2. rewrite Hcolor. cbn. changeR2. apply observer_light_get_light.
+ - now repeat destruct_match.
++ f_equal. apply IHl.
+Qed.
+
+Corollary no_moving_same_config : forall config, ~color_bivalent config ->
+ moving gatherR2 da config = [] -> round gatherR2 da config == config.
+Proof using Hssync.
+intros ? ?.
+rewrite <- changing_eq_moving; trivial; [].
+apply no_changing_same_config.
+Qed.
+
+
+Lemma gathered_at_MajTower_at_iff : forall config l, gathered_at l config -> MajTower_at l config.
+Proof using size_G.
+ intros cfg l H.
+ red in H.
+ red.
+ assert ((!! cfg)[l] > 0).
+ { assert (get_location (cfg (Good g1)) == l) by auto.
+ enough (In l (!! cfg)).
+ { auto. }
+ rewrite obs_from_config_In.
+ exists (Good g1);auto. }
+ intros y H1.
+ assert ((!! cfg)[y] = 0).
+ { destruct ((!! cfg)[y]) eqn:heq.
+ { reflexivity. }
+
+ assert ((!! cfg)[y] > 0) as hneq by lia.
+ assert (In y (!! cfg)) as hIn.
+ { red.
+ assumption. }
+ rewrite obs_from_config_In in hIn.
+ exfalso.
+ destruct hIn.
+ revert H2.
+ pattern x.
+ apply no_byz.
+ intros g H2.
+ rewrite H in H2.
+ symmetry in H2.
+ contradiction. }
+ lia.
+Qed.
+
+
+Section ColorBivalent.
+
+Variable config : configuration.
+Hypothesis Hcolor : color_bivalent config.
+
+Notation loc_g1 := (loc_g1 config).
+Notation loc_others := (loc_others config).
+Notation active_on_g1 := (active_on loc_g1 config).
+Notation active_on_other := (active_on loc_others config).
+Notation idle_on_g1 := (idle_on loc_g1 config).
+Notation idle_on_other := (idle_on loc_others config).
+Notation black_active_on_g1 := (black_active_on loc_g1 config).
+Notation black_active_on_other := (black_active_on loc_others config).
+Notation white_active_on_g1 := (white_active_on loc_g1 config).
+Notation white_active_on_other := (white_active_on loc_others config).
+Notation black_idle_on_g1 := (black_idle_on loc_g1 config).
+Notation black_idle_on_other := (black_idle_on loc_others config).
+Notation white_idle_on_g1 := (white_idle_on loc_g1 config).
+Notation white_idle_on_other := (white_idle_on loc_others config).
+Notation black_on_g1 := (black_on loc_g1 config).
+Notation black_on_other := (black_on loc_others config).
+Notation white_on_g1 := (white_on loc_g1 config).
+Notation white_on_other := (white_on loc_others config).
+
+
+Lemma color_bivalent_length_black :
+ length (black_on loc_g1 config) = length (black_on loc_others config).
+Proof using Hcolor.
+assert (Hblack : List.In false l_list) by now right; left.
+destruct Hcolor as [Heven [Hn [pt1 [pt2 [Hdiff [Hpt1 [Hpt2 Hcol]]]]]]].
+rewrite Forall_forall in Hcol. apply Hcol in Hblack. clear Hcol.
+rewrite <- 2 length_light_on in Hblack.
+assert (Hperm : PermutationA equiv (support (!! config)) (cons pt1 (cons pt2 nil))).
+{ rewrite obs_fst. changeR2. apply bivalent_support; auto. }
+rewrite have_support in Hperm; auto; [].
+apply PermutationA_2 in Hperm; auto; [].
+destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]]; now rewrite Heq1, Heq2.
+Qed.
+
+Lemma color_bivalent_length_white :
+ length (white_on loc_g1 config) = length (white_on loc_others config).
+Proof using Hcolor.
+assert (Hall : length (on_loc loc_g1 config) = length (on_loc loc_others config)).
+{ rewrite <- 2 (obs_from_config_on_loc config (0%VS, witness)), loc_g1_mult, loc_others_mult; auto. }
+rewrite 2 on_loc_color_split, 2 app_length, color_bivalent_length_black in Hall.
+lia.
+Qed.
+
+Definition ofc := @obs_from_config.
+Lemma obs_fst_colors : forall pt l,
+ (colors (snd (!!! (config, (0%VS, witness)))))[(pt, l)] <= (!! config)[pt].
+Proof using .
+intros pt l. rewrite obs_fst.
+destruct (Obs.(obs_from_config_spec) config (0%VS, witness)) as [Hobs_fst [Hlight Hcolors]].
+rewrite Hobs_fst, Hcolors.
+clear Hcolors Hlight Hobs_fst. changeR2.
+induction (config_list config) as [| [pt' l'] config_list].
++ reflexivity.
++ cbn -[equiv_dec equiv get_location].
+ repeat destruct_match.
+ - apply le_n_S, IHconfig_list.
+ - exfalso. revert_one @complement. intro Habs. apply Habs.
+ revert_all. now intros [].
+ - apply le_S, IHconfig_list.
+ - apply IHconfig_list.
+Qed.
+
+Definition ref_colors := let nb_loc_g1_black := length (black_on loc_g1 config) in
+ add (loc_g1, false) nb_loc_g1_black
+ (add (loc_g1, true) (Nat.div2 (nG + nB) - nb_loc_g1_black)
+ (add (loc_others, false) nb_loc_g1_black
+ (singleton (loc_others, true) (Nat.div2 (nG + nB) - nb_loc_g1_black)))).
+
+Lemma have_obs : forall st,
+ !!! (config, st) == ((add loc_g1 (Nat.div2 (nG + nB)) (singleton loc_others (Nat.div2 (nG + nB)))),
+ {| observer_lght := get_light st; colors := ref_colors |}).
+Proof using Hcolor.
+intros st.
+unfold ref_colors.
+split; [| split].
+* rewrite <- (obs_from_config_fst_ok (0%VS, witness) st). cbn [fst]. changeR2.
+ intro pt.
+ destruct (pt =?= loc_g1) as [Hpt | Hloc_g1];
+ [| destruct (pt =?= loc_others) as [Hpt | Hloc_others]].
+ + rewrite Hpt, add_same, singleton_other; auto.
+ + rewrite Hpt, add_other, singleton_same; auto.
+ + rewrite add_other, singleton_other; auto; [].
+ rewrite <- not_In, <- support_spec, have_support, InA_cons, InA_singleton; auto.
+ intuition.
+* intros [pt l]. cbn [snd colors].
+ assert (Heq : length (on_loc pt config) = length (white_on pt config) + length (black_on pt config)).
+ { rewrite on_loc_color_split, app_length. lia. }
+ rewrite <- (obs_from_config_on_loc config (0%VS, witness)) in Heq.
+ rewrite colors_indep, <- length_light_on.
+ destruct (pt =?= loc_g1) as [Hpt | Hloc_g1];
+ [| destruct (pt =?= loc_others) as [Hpt | Hloc_others]].
+ 1,2: destruct l.
+ + (* white on loc_g1 *)
+ rewrite Hpt in *.
+ rewrite loc_g1_mult in *; auto.
+ rewrite add_other, add_same, add_other, singleton_other.
+ - lia.
+ - intros [Hfst Hsnd]. cbn -[equiv get_location] in Hfst, Hsnd.
+ apply loc_g1_diff_others in Hfst; auto.
+ - intros []. intuition.
+ - intros []. intuition.
+ + (* black on loc_g1 *)
+ rewrite Hpt in *.
+ rewrite add_same, add_other, add_other, singleton_other.
+ - lia.
+ - intros []. intuition.
+ - intros []. clear Heq. cbn -[equiv get_location] in *.
+ apply loc_g1_diff_others in H; auto.
+ - intros []. intuition.
+ + (* white on loc_others *)
+ rewrite Hpt in *.
+ rewrite loc_others_mult, <- color_bivalent_length_black in *; auto.
+ rewrite 3 add_other, singleton_same.
+ - lia.
+ - intros []. intuition.
+ - intros []. intuition.
+ - intros []. intuition.
+ + (* black on loc_others *)
+ rewrite Hpt in *.
+ rewrite loc_others_mult, <- color_bivalent_length_black in *; auto.
+ rewrite 2 add_other, add_same, singleton_other.
+ - lia.
+ - intros []. intuition.
+ - intros []. intuition.
+ - intros []. intuition.
+ + (* on empty locations *)
+ rewrite 3 add_other, singleton_other.
+ - rewrite length_light_on, <- Nat.le_0_r, obs_fst_colors, Nat.le_0_r, <- not_In.
+ rewrite <- support_spec, have_support, InA_cons, InA_singleton; auto.
+ intuition.
+ - intros []. intuition.
+ - intros []. intuition.
+ - intros []. intuition.
+ - intros []. intuition.
+* cbn. reflexivity.
+Qed.
+
+Corollary have_colors : forall st, colors (snd (!!! (config, st))) == ref_colors.
+Proof using Hcolor. intro st. now rewrite have_obs. Qed.
+
+Lemma same_colors : forall col, (colors (snd (!!! (config, (0%VS, witness)))))[(loc_g1, col)] =
+ (colors (snd (!!! (config, (0%VS, witness)))))[(loc_others, col)].
+Proof using Hcolor.
+intro col. rewrite have_colors. unfold ref_colors.
+assert (loc_g1 =/= loc_others) by auto. unfold complement in *.
+destruct col.
++ rewrite add_other, add_same, 4 add_other, singleton_other, singleton_same;
+ reflexivity || intros []; cbn in *; intuition.
++ rewrite add_same, 4 add_other, add_same, 2 singleton_other;
+ reflexivity || intros []; cbn in *; intuition.
+Qed.
+
+Theorem round_simplify_color_bivalent :
+ round gatherR2 da config
+ == fun id =>
+ if da.(activate) id
+ then
+ let obs := !!!(config, config id) in
+ if observer_lght (snd obs)
+ then (middle loc_g1 loc_others, false)
+ else (get_location (config id), true) (* was: (other_loc, true) *)
+ else config id.
+Proof using Hssync Hcolor.
+rewrite round_simplify; trivial; [].
+intro id. destruct_match; auto; [].
+cbn zeta.
+assert (Hbivalent := color_bivalent_bivalent Hcolor).
+rewrite <- color_bivalent_obs_spec in Hcolor; auto; [].
+rewrite <- bivalent_obs_spec in Hbivalent; auto; [].
+now rewrite Hbivalent, Hcolor.
+Qed.
+
+Lemma moving_iff: forall id,
+ List.In id (moving gatherR2 da config)
+ <-> is_white config id /\ List.In id (active da).
+Proof using Hssync Hcolor.
+ intros id.
+ rewrite moving_spec, active_spec, (round_simplify_color_bivalent id).
+ split.
+ - cbn zeta.
+ repeat destruct_match; intuition.
+ - intros [h_white h_active].
+ rewrite h_active.
+ cbn zeta.
+ setoid_rewrite observer_light_get_light. rewrite h_white.
+ unfold get_location at 1. cbn -[middle equiv get_location].
+ assert (Hdiff := middle_diff (@loc_g1_diff_others config ltac:(auto))).
+ rewrite InA_cons, InA_singleton in Hdiff.
+ destruct (@bivalent_get_location_cases config ltac:(auto) id) as [Heq | Heq]; rewrite Heq; intuition.
+Qed.
+
+Lemma color_bivalent_moving_target : forall id, List.In id (moving gatherR2 da config) ->
+ round gatherR2 da config id == (middle loc_g1 loc_others, false).
+Proof using Hssync Hcolor.
+intros id Hid.
+rewrite (round_simplify_color_bivalent id).
+rewrite moving_iff, active_spec in Hid.
+unfold is_white in Hid.
+destruct Hid as [Hwhite Hactive].
+cbn zeta.
+now rewrite Hactive, (observer_light_get_light config), Hwhite.
+Qed.
+
+Lemma color_bivalent_same_destination : same_destination_if_moving gatherR2 da config.
+Proof using Hssync Hcolor.
+repeat intro.
+now rewrite 2 color_bivalent_moving_target.
+Qed.
+
+(** Some results when all active robots are black. *)
+Section AllActiveAreBlack.
+
+Hypothesis Hallblack : all_active_are_black config da.
+
+Lemma a3b_next_round :
+ round gatherR2 da config
+ == fun id => if activate da id then (get_location (config id), true) else config id.
+Proof using Hssync Hcolor Hallblack.
+intro id. rewrite (round_simplify_color_bivalent id).
+cbn zeta. destruct_match_eq Hactive; [| reflexivity].
+unfold all_active_are_black, all_are_black_in, is_black in Hallblack.
+rewrite Forall_forall in Hallblack. setoid_rewrite active_spec in Hallblack.
+apply Hallblack in Hactive.
+assert (Hobs := observer_light_get_light config id). changeR2.
+rewrite Hobs, Hactive. reflexivity.
+Qed.
+
+Corollary a3b_same_loc : forall id, get_location (round gatherR2 da config id) == get_location (config id).
+Proof using Hssync Hcolor Hallblack. intro id. rewrite (a3b_next_round id). now destruct_match. Qed.
+
+Lemma a3b_same_obs : !! (round gatherR2 da config) == !! config.
+Proof using Hssync Hcolor Hallblack.
+intro pt.
+destruct (obs_from_config_spec config (0%VS, witness)) as [Hobs _].
+specialize (Hobs pt). rewrite <- obs_fst in Hobs. changeR2. rewrite Hobs.
+destruct (obs_from_config_spec (round gatherR2 da config) (0%VS, witness)) as [Hobs' _].
+specialize (Hobs' pt). rewrite <- obs_fst in Hobs'. changeR2. rewrite Hobs'.
+do 2 rewrite config_list_spec, map_map, count_filter_length, filter_map, map_length.
+f_equiv. apply eqlistA_PermutationA, filter_extensionalityA_compat; try reflexivity; [].
+intros xx id h. rewrite h.
+repeat destruct_match; try reflexivity; [|]; rewrite (a3b_next_round id) in *;
+destruct (activate da id); contradiction.
+Qed.
+
+Lemma a3b_next_black : forall id,
+ is_black (round gatherR2 da config) id <-> is_black config id /\ activate da id = false.
+Proof using Hssync Hcolor Hallblack.
+intros id. unfold is_black.
+rewrite (round_simplify_color_bivalent id).
+destruct_match_eq Hactive.
++ rewrite all_active_are_black_equiv in Hallblack.
+ apply Hallblack in Hactive.
+ cbn zeta. rewrite (observer_light_get_light config), Hactive.
+ cbn. tauto.
++ tauto.
+Qed.
+
+Corollary a3b_next_white : forall id,
+ is_white (round gatherR2 da config) id <-> is_white config id \/ activate da id = true.
+Proof using Hssync Hcolor Hallblack.
+intro id.
+rewrite <- 2 black_white, a3b_next_black.
+destruct (activate da id); intuition.
+Qed.
+
+Corollary a3b_next_black_eqb : forall id,
+ get_light (round gatherR2 da config id) ==b false
+ = (get_light (config id) ==b false) && negb (activate da id).
+Proof using Hssync Hcolor Hallblack.
+intro id. symmetry.
+destruct (get_light (round gatherR2 da config id)) eqn:Hcase; reflect_bool.
++ rewrite (a3b_next_white id) in Hcase. cbn in *. intuition congruence.
++ rewrite (a3b_next_black id) in Hcase. cbn in *. intuition congruence.
+Qed.
+
+Corollary a3b_next_white_eqb : forall id,
+ get_light (round gatherR2 da config id) ==b true
+ = (get_light (config id) ==b true) || activate da id.
+Proof using Hssync Hcolor Hallblack.
+intro id. symmetry.
+destruct (get_light (round gatherR2 da config id)) eqn:Hcase; reflect_bool.
++ rewrite (a3b_next_white id) in Hcase. cbn in *. intuition congruence.
++ rewrite (a3b_next_black id) in Hcase. cbn in *. intuition congruence.
+Qed.
+
+Lemma state_eqb : forall st1 st2,
+ (st1 ==b st2) = (get_location st1 ==b get_location st2) && (get_light st1 ==b get_light st2).
+Proof using .
+intros [pt1 l1] [pt2 l2]. cbn. changeR2.
+destruct (pt1 ==b pt2) eqn:Hpt, (l1 ==b l2) eqn:Hl; reflect_bool; cbn in *; tauto.
+Qed.
+
+Corollary a3b_state_same_eqb : forall id,
+ (round gatherR2 da config id ==b config id)
+ = (get_light (round gatherR2 da config id) ==b get_light (config id)).
+Proof using Hssync Hcolor Hallblack. intro. rewrite state_eqb, a3b_same_loc. now simpl_bool. Qed.
+
+Lemma a3b_black_active_is_active : forall pt,
+ black_active_on pt config = active_on pt config.
+Proof using Hallblack.
+intro pt. unfold light_active_on, active_on, active.
+repeat rewrite <- filter_andb. f_equiv.
+intros xx id ?. subst xx.
+unfold all_active_are_black, all_are_black_in in *. rewrite Forall_forall in *.
+match goal with |- _ = ?x => destruct x eqn:Hcase end;
+clear -Hallblack Hcase; reflect_bool; intuition.
+apply Hallblack. now rewrite active_spec.
+Qed.
+
+Lemma a3b_next_black_idle_is_black_idle : forall pt,
+ black_idle_on pt (round gatherR2 da config) = black_idle_on pt config.
+Proof using Hssync Hcolor Hallblack.
+intro pt. unfold black_idle_on, idle_on, idle.
+repeat rewrite <- filter_andb. f_equiv.
+intros xx id ?. subst xx.
+rewrite a3b_next_black_eqb, a3b_same_loc.
+now destruct (activate da id); simpl_bool.
+Qed.
+
+Lemma a3b_next_black_is_black_idle :forall pt,
+ black_on pt (round gatherR2 da config) = black_idle_on pt config.
+Proof using Hssync Hcolor Hallblack.
+intro pt.
+unfold black_idle_on, black_on, idle_on, idle, on_loc.
+repeat rewrite <- filter_andb.
+induction names as [| id l]; try reflexivity; [].
+cbn [List.filter].
+rewrite (a3b_same_loc id).
+rewrite all_active_are_black_equiv in Hallblack.
+destruct_match_eq Htest1; destruct_match_eq Htest2; reflect_bool.
++ now f_equal.
++ exfalso.
+ destruct Htest1 as [Hlight' Hloc].
+ revert Hlight'. rewrite (round_simplify_color_bivalent id).
+ cbn zeta. setoid_rewrite (observer_light_get_light config id).
+ destruct_match_eq Hactive; try destruct_match_eq Hlight.
+ - apply Hallblack in Hactive. unfold is_black in *. congruence.
+ - discriminate.
+ - intuition.
++ exfalso.
+ destruct Htest2 as [[Hlight Hloc] Hactive].
+ destruct Htest1 as [Htest1 | Htest1]; try congruence; [].
+ rewrite (round_simplify_color_bivalent id), Hactive in Htest1. congruence.
++ apply IHl.
+Qed.
+
+Lemma a3b_white_idle_is_white : forall pt, white_idle_on pt config = white_on pt config.
+Proof using Hallblack.
+intros pt. unfold light_idle_on, idle_on, idle, white_on, on_loc.
+repeat rewrite <- filter_andb. f_equiv.
+intros xx id ?. subst xx.
+unfold all_active_are_black, all_are_black_in in *. rewrite Forall_forall in *.
+match goal with |- _ = ?x => destruct x eqn:Hcase end;
+clear -Hallblack Hcase; reflect_bool; intuition.
+rewrite <- not_true_iff_false, <- active_spec.
+intro Habs. apply Hallblack in Habs.
+unfold is_black in *. congruence.
+Qed.
+
+Lemma a3b_next_white_idle_is_white : forall pt,
+ white_idle_on pt (round gatherR2 da config) = white_on pt config.
+Proof using Hssync Hcolor Hallblack.
+intros pt. unfold light_idle_on, idle_on, idle, white_on, on_loc.
+repeat rewrite <- filter_andb. f_equiv.
+intros xx id ?. subst xx.
+rewrite a3b_same_loc, a3b_next_white_eqb.
+unfold all_active_are_black, all_are_black_in in *. rewrite Forall_forall in *.
+match goal with |- _ = ?x => destruct x eqn:Hcase end;
+clear -Hallblack Hcase; reflect_bool; intuition.
+- rewrite <- not_true_iff_false, <- active_spec.
+ intro Habs. apply Hallblack in Habs.
+ unfold is_black in *. congruence.
+- destruct (activate da id); tauto.
+Qed.
+
+Lemma a3b_length_idle_active : forall pt,
+ length (List.filter (fun id => (config id ==b (pt, false)) && negb (activate da id)) (active da)) = 0.
+Proof using .
+intro pt. unfold active. rewrite <- filter_andb.
+induction names; cbn; trivial; [].
+destruct_match; auto; [].
+exfalso. reflect_bool. intuition congruence.
+Qed.
+
+Lemma a3b_length_black_idle_eq : forall pt pt',
+ length (List.filter (fun id => (config id ==b (pt, false)) && negb (activate da id)) (black_idle_on pt' config))
+ = if pt' ==b pt then length (black_idle_on pt' config) else 0.
+Proof using .
+intros pt pt'. unfold black_idle_on, idle_on, idle. repeat rewrite <- filter_andb.
+destruct (pt' ==b pt) eqn:Heq_pt.
+* induction names as [| id l]; cbn; trivial; [].
+ destruct_match; reflect_bool.
+ + revert_one and. intros [[[[H1 H2] H3] H4] H5].
+ rewrite H3, H2, H4. simpl_bool. cbn. f_equal. apply IHl.
+ + destruct_match; cbn; reflect_bool.
+ - exfalso. clear - Heq_pt H H0. cbn in *. rewrite Heq_pt in *.
+ destruct (config id); cbn in *; intuition congruence.
+ - apply IHl.
+* induction names as [| id l]; try reflexivity; [].
+ cbn. destruct_match; auto; [].
+ exfalso. reflect_bool. apply Heq_pt. cbn in *. transitivity (fst (config id)); intuition.
+Qed.
+
+Lemma a3b_length_white_idle : forall pt pt',
+ length (List.filter (fun id => (config id ==b (pt, false))
+ && negb (activate da id)) (white_idle_on pt' config)) = 0.
+Proof using .
+intros pt pt'. unfold white_idle_on. rewrite <- filter_andb.
+induction (idle_on pt'); cbn; try reflexivity; [].
+destruct_match; auto; [].
+exfalso. reflect_bool. unfold get_light in *.
+destruct H as [[[] ?] ?]. cbn in *. congruence.
+Qed.
+
+End AllActiveAreBlack.
+
+
+Definition cb_cb_precondition :=
+ (* All active robots are black *)
+ all_active_are_black config da
+ /\ (* same number of activated robots on each tower *)
+ length active_on_g1 = length active_on_other.
+
+Lemma cb_cb_precondition_dec: cb_cb_precondition \/ ~ cb_cb_precondition.
+Proof using .
+assert (Hdec : forall id, {is_black config id} + {~is_black config id}). { intros id. apply bool_dec. }
+destruct (Forall_dec (is_black config) Hdec (active da)).
++ (* All active robots are black *)
+ destruct (length active_on_g1 =? length active_on_other) eqn:heq.
+ - left.
+ rewrite Nat.eqb_eq in *.
+ now split.
+ - right.
+ intros [h1 h2].
+ rewrite Nat.eqb_neq in *.
+ contradiction.
++ right.
+ intros [h1 h2].
+ contradiction.
+Qed.
+
+Lemma color_bivalent_next_color_bivalent :
+ cb_cb_precondition ->
+ color_bivalent (round gatherR2 da config).
+Proof using Hssync Hcolor.
+intros [Hactive Hlen].
+assert (Hcol := Hcolor). destruct Hcol as [Heven [Hn _]].
+repeat split; trivial; [].
+exists loc_g1, loc_others.
+repeat split; auto; changeR2.
+* rewrite a3b_same_obs; auto.
+* rewrite a3b_same_obs; auto.
+* rewrite Forall_forall in *.
+ intros col _.
+ assert (Hwhite := color_bivalent_length_white).
+ assert (Hblack := color_bivalent_length_black).
+ rewrite <- 2 length_light_on in *.
+ (* Splitting robots wrt. activation, color in the goal: active (black), idle black, idle white *)
+ unfold light_on, on_loc.
+ rewrite (active_idle_is_partition da).
+ repeat rewrite filter_app.
+ change (List.filter (fun id => get_location (?config id) ==b ?pt) (idle da))
+ with (idle_on pt config).
+ change (List.filter (fun id => get_location (?config id) ==b ?pt) (active da))
+ with (active_on pt config).
+ assert (Hfun : forall (c : configuration) b, (eq ==> eq)%signature
+ (fun id => (get_light (c id) ==b b) && (get_light (c id) ==b negb b))
+ (fun id => false)).
+ { intros c l xx id ?. subst xx. destruct (get_light (c id)), l; reflexivity. }
+ destruct col.
+ + (* white *)
+ Typeclasses eauto := (dfs).
+ rewrite 2 idle_on_split.
+ repeat rewrite ?filter_app, <- ?filter_andb, ?app_length.
+ unfold light_idle_on.
+ rewrite 2 filter_twice, <- 2 filter_andb.
+ change (List.filter (fun id => get_light (round gatherR2 da config id) ==b true)
+ (idle_on ?pt (round gatherR2 da config)))
+ with (white_idle_on pt (round gatherR2 da config)).
+ rewrite 2 (filter_extensionalityA_compat (Hfun (round gatherR2 da config) true) (reflexivity _)), 2 filter_false.
+ assert (Hlen' : forall pt,
+ length (List.filter (fun id => get_light (round gatherR2 da config id) ==b true)
+ (active_on pt (round gatherR2 da config))) = length (active_on pt config)).
+ { intro pt. unfold active_on, active.
+ rewrite <- 3 filter_andb. f_equiv.
+ apply eqlistA_PermutationA, filter_extensionalityA_compat; try reflexivity; [].
+ intros xx id h. rewrite h.
+ rewrite a3b_next_white_eqb, a3b_same_loc; trivial; [].
+ destruct (activate da id) eqn:Hid; now simpl_bool. }
+ rewrite 2 Hlen', 2 a3b_next_white_idle_is_white; trivial; [].
+ lia.
+ + (* black *)
+ rewrite 2 active_on_split.
+ repeat rewrite ?filter_app, <- ?filter_andb, ?app_length.
+ unfold light_active_on.
+ rewrite 2 filter_twice, <- 2 filter_andb.
+ change (List.filter (fun id => get_light (round gatherR2 da config id) ==b false)
+ (idle_on ?pt (round gatherR2 da config)))
+ with (black_idle_on pt (round gatherR2 da config)).
+ rewrite 2 (filter_extensionalityA_compat (Hfun (round gatherR2 da config) false) (reflexivity _)), 2 filter_false.
+ assert (Hlen' : forall pt,
+ length (List.filter (fun id => get_light (round gatherR2 da config id) ==b false)
+ (active_on pt (round gatherR2 da config))) = 0).
+ { intro pt. unfold active_on, active.
+ change 0 with (length (@nil ident)). rewrite <- (filter_false names).
+ rewrite <- 2 filter_andb. f_equiv.
+ apply eqlistA_PermutationA, filter_extensionalityA_compat; try reflexivity; [].
+ intros xx id h. rewrite h.
+ rewrite a3b_next_black_eqb, a3b_same_loc; trivial; [].
+ destruct (activate da id) eqn:Hid; now simpl_bool. }
+ rewrite 2 Hlen', 2 a3b_next_black_idle_is_black_idle; trivial; [].
+ assert (Heq : length (on_loc loc_g1 config) = length (on_loc loc_others config)).
+ { rewrite <- 2 (obs_from_config_on_loc _ (0%VS, witness)), loc_others_mult; auto. }
+ rewrite 2 on_loc_split_active_colors, 2a3b_white_idle_is_white, 4 app_length in Heq; auto.
+ simpl. lia.
+Qed.
+
+Definition cb_b_precondition_all_white :=
+ (* All robots are white *)
+ all_are_white config
+ /\ active da = on_loc (get_location (config (hd (Good g1) (active da)))) config.
+ (* TODO: rename g1 *)
+
+Lemma cb_b_precondition_all_white_dec :
+ cb_b_precondition_all_white \/ ~cb_b_precondition_all_white.
+Proof using .
+assert (Hdec : forall id, {is_white config id} + {~ is_white config id}).
+{ unfold is_white. intro id. apply bool_dec. }
+destruct (Forall_dec (is_white config) Hdec names) as [Hall | Hsome].
++ (* All robots are white *)
+ pose (P' := fun id => get_location (config id) == get_location (config (hd (Good g1) (active da)))).
+ destruct (eqlistA_dec names_eq_dec (active da)
+ (on_loc (get_location (config (hd (Good g1) (active da)))) config)) as [Heq | Hneq].
+ - (* All active robots are on the same tower *)
+ left. split; trivial; [].
+ now rewrite eqlistA_Leibniz in *.
+ - (* Not all active robots are on the same tower *)
+ right. intros [_ ?]. apply Hneq. now rewrite eqlistA_Leibniz.
++ (* Not all robots are white *)
+ right. intros [? _]. contradiction.
+Qed.
+
+Lemma color_bivalent_next_bivalent_all_white :
+ cb_b_precondition_all_white ->
+ bivalent (round gatherR2 da config)
+ /\ ~color_bivalent (round gatherR2 da config).
+Proof using Hssync Hcolor.
+intros [Hall Hloc].
+assert (Hlen_active : length (active da) = Nat.div2 (nG + nB)).
+{ rewrite Hloc, <- (obs_from_config_on_loc config (0%VS, witness)).
+ rewrite <- bivalent_In_iff_mult_eq_half, obs_from_config_In; auto.
+ destruct (active da) as [| id_active l].
+ + exfalso. cut (List.In (Good g1) nil); intuition; [].
+ now rewrite Hloc, on_loc_spec.
+ + now exists id_active. }
+assert (Hlen_idle : length (idle da) = Nat.div2 (nG + nB)).
+{ assert (Hlen' : length (idle da) + length (active da) = nG + nB).
+ { rewrite <- names_length, (active_idle_is_partition da), app_length. lia. }
+ destruct Hcolor as [Heven _]. apply even_div2 in Heven. lia. }
+assert (Nat.div2 (nG + nB) > 0) by auto.
+destruct (active da) as [| id_move l_active] eqn:Heq_active; [cbn in *; lia |].
+destruct (idle da) as [| id_inactive l_inactive] eqn:Heq_idle; [cbn in *; lia |].
+cbn [hd] in Hloc. rewrite <- Heq_active, <- Heq_idle in *.
+pose (pt1 := get_location (config id_move)).
+pose (pt2 := find_other_loc (fst (!!! (config, (0%VS, witness)))) pt1).
+assert (Hwhite : forall id, get_light (config id) == true).
+{ intros id. unfold all_are_white, all_are_white_in in Hall.
+ rewrite Forall_forall in Hall. apply Hall. apply In_names. }
+clear Hall.
+assert (Hbivalent : bivalent_obs (!!! (config, (0%VS, witness))) = true).
+{ rewrite bivalent_obs_spec. now apply color_bivalent_bivalent. }
+assert (Hdiff : forall id, middle loc_g1 loc_others =/= (get_location (config id))).
+{ intro id.
+ assert (Hdiff := @loc_g1_diff_others config ltac:(auto)).
+ apply middle_diff in Hdiff.
+ rewrite InA_cons, InA_singleton in Hdiff.
+ destruct (@bivalent_get_location_cases config ltac:(auto) id) as [Heq | Heq];
+ rewrite Heq; intuition. }
+assert (Hmoving : active da = moving gatherR2 da config).
+{ unfold active, moving. induction names as [| id l]; try reflexivity; [].
+ cbn -[get_location equiv_dec equiv]. unfold equiv_decb in *.
+ destruct_match_eq Hactive; destruct_match; cbn.
+ + exfalso. revert_one equiv. rewrite (round_simplify_color_bivalent id).
+ changeR2. rewrite Hactive. cbn zeta.
+ setoid_rewrite observer_light_get_light. rewrite Hwhite.
+ intro Habs. apply (Hdiff id), Habs.
+ + f_equal. apply IHl.
+ + apply IHl.
+ + exfalso. revert_one @complement.
+ rewrite (round_simplify_color_bivalent id).
+ changeR2. rewrite Hactive. intuition. }
+assert (Hpt1 : In pt1 (fst (!!! (config, (0%VS, witness))))). { apply pos_in_config. }
+assert (Hperm := find_other_loc_spec _ Hbivalent Hpt1). fold pt2 in Hperm.
+assert (Hmiddle_diff_2 : middle loc_g1 loc_others =/= pt2).
+{ rewrite <- obs_fst, have_support, PermutationA_2 in Hperm; auto; [].
+ assert (Hmiddle := middle_diff (find_other_loc_diff _ Hbivalent Hpt1)). fold pt2 in Hmiddle.
+ rewrite InA_cons, InA_singleton in Hmiddle.
+ destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]]; rewrite Heq1, Heq2; clear -Hmiddle;
+ solve [intuition | rewrite middle_comm; intuition]. }
+(* Let us explicit the configuration *)
+assert (Hconfig : config == fun id => if activate da id then (pt1, true) else (pt2, true)).
+{ intro id. specialize (Hwhite id).
+ destruct_match_eq Hactive.
+ + rewrite <- active_spec, Hloc, on_loc_spec in Hactive.
+ now destruct (config id).
+ + rewrite <- not_true_iff_false, <- active_spec, Hloc, on_loc_spec in Hactive. fold pt1 in Hactive.
+ assert (Hin := pos_in_config config (0%VS, witness) id).
+ rewrite <- support_spec, Hperm, InA_cons, InA_singleton in Hin.
+ destruct (config id); intuition. }
+(* Then we can explicit the configuration after the round *)
+assert (Hconfig' : round gatherR2 da config
+ == fun id => if activate da id then (middle loc_g1 loc_others, false) else (pt2, true)).
+{ intro id. rewrite (round_simplify_color_bivalent id).
+ destruct_match_eq Hactive.
+ + cbn zeta. assert (Hlight := observer_light_get_light config id).
+ changeR2. now rewrite Hlight, Hwhite.
+ + rewrite <- not_true_iff_false, <- active_spec, Hloc, on_loc_spec in Hactive. fold pt1 in Hactive.
+ assert (Hin := pos_in_config config (0%VS, witness) id).
+ rewrite <- support_spec, Hperm, InA_cons, InA_singleton in Hin.
+ specialize (Hwhite id). destruct (config id); intuition. }
+assert (dep_and : forall A B : Prop, A -> (A -> B) -> A /\ B) by intuition.
+apply dep_and; clear dep_and.
+* (* bivalent at the next round *)
+ assert (Hcol := Hcolor). destruct Hcol as [Heven [Hle _]].
+ repeat split; trivial; []. changeR2.
+ exists (middle loc_g1 loc_others), pt2.
+ repeat split.
+ + assumption.
+ + destruct (obs_from_config_spec (round gatherR2 da config) (0%VS, witness)) as [Hobs _].
+ specialize (Hobs (middle loc_g1 loc_others)).
+ rewrite config_list_spec, map_map, <- obs_fst in Hobs. changeR2.
+ rewrite Hobs, count_filter_length, filter_map, map_length.
+ assert (Hfun : (eq ==> eq)%signature (activate da)
+ (fun id => if get_location (round gatherR2 da config id) =?= middle loc_g1 loc_others
+ then true else false)).
+ { intros xx id ?. subst xx. destruct_match.
+ + revert_one equiv. rewrite (Hconfig' id). destruct_match; intuition.
+ + revert_one @complement. rewrite (Hconfig' id). destruct_match; intuition. }
+ rewrite <- (filter_extensionalityA_compat Hfun (reflexivity names)).
+ apply Hlen_active.
+ + destruct (obs_from_config_spec (round gatherR2 da config) (0%VS, witness)) as [Hobs _].
+ specialize (Hobs pt2).
+ rewrite config_list_spec, map_map, <- obs_fst in Hobs. changeR2.
+ rewrite Hobs, count_filter_length, filter_map, map_length.
+ assert (Hfun : (eq ==> eq)%signature (fun id => negb (activate da id))
+ (fun id => if get_location (round gatherR2 da config id) =?= pt2
+ then true else false)).
+ { intros xx id ?. subst xx. destruct_match.
+ + revert_one equiv. rewrite (Hconfig' id). destruct_match; intuition.
+ + revert_one @complement. rewrite (Hconfig' id). destruct_match; intuition. }
+ now rewrite <- (filter_extensionalityA_compat Hfun (reflexivity names)).
+* (* not color bivalent at the next round *)
+ intros Hbivalent' [Heven [Hn [pt1_biv [pt2_biv [Hdiff_biv [Hpt1_biv [Hpt2_biv Hcol]]]]]]].
+ changeR2.
+ assert (Hperm2 : PermutationA equiv (cons pt1_biv (cons pt2_biv nil))
+ (cons (middle loc_g1 loc_others) (cons pt2 nil))).
+ { transitivity (support (fst (!!! (round gatherR2 da config, (0%VS, witness))))).
+ + symmetry. changeR2. apply bivalent_support; auto.
+ + changeR2. apply bivalent_support; auto.
+ - rewrite <- obs_fst, obs_from_config_In.
+ exists id_move.
+ rewrite (Hconfig' id_move).
+ assert (Hin : List.In id_move (active da)).
+ { rewrite Heq_active. now left. }
+ rewrite active_spec in Hin. now rewrite Hin.
+ - rewrite <- obs_fst, obs_from_config_In.
+ exists id_inactive.
+ rewrite (Hconfig' id_inactive).
+ assert (Hin : List.In id_inactive (idle da)).
+ { rewrite Heq_idle. now left. }
+ rewrite idle_spec in Hin. now rewrite Hin. }
+ apply PermutationA_2 in Hperm2; autoclass.
+ assert (Hsame_col : (colors (snd (!!! (round gatherR2 da config, (0%VS, witness)))))[(middle loc_g1 loc_others, true)]
+ = (colors (snd (!!! (round gatherR2 da config, (0%VS, witness)))))[(pt2, true)]).
+ { rewrite Forall_forall in Hcol.
+ destruct Hperm2 as [[Heq1 Heq2] | [Heq1 Heq2]].
+ + rewrite <- Heq1, <- Heq2. apply Hcol. now left.
+ + rewrite <- Heq2, <- Heq1. symmetry. apply Hcol. now left. }
+ (* One tower is fully black while the other is fully white, which is not color bivalent. *)
+ revert Hsame_col.
+ destruct (obs_from_config_spec (round gatherR2 da config) (0%VS, witness)) as [_ [_ Hobs]].
+ rewrite (Hobs (middle loc_g1 loc_others, true)). specialize (Hobs (pt2, true)).
+ progress change bool with (@L Lght) in *. rewrite Hobs.
+ rewrite config_list_spec, 2 count_filter_length, 2 filter_map, 2 map_length.
+ assert (Hfun1 : (eq ==> eq)%signature (fun _ => false)
+ (fun id => if round gatherR2 da config id =?= (middle loc_g1 loc_others, true)
+ then true else false)).
+ { intros xx id ?. subst xx. destruct_match; trivial; [].
+ revert_one equiv. rewrite (Hconfig' id). destruct_match.
+ - intros [_ Habs]. apply Habs.
+ - intros [Habs _]. cbn [fst] in Habs. symmetry in Habs. contradiction. }
+ rewrite <- (filter_extensionalityA_compat Hfun1 (reflexivity names)).
+ assert (Hfun2 : (eq ==> eq)%signature (fun id => negb (activate da id))
+ (fun id => if round gatherR2 da config id =?= (pt2, true)
+ then true else false)).
+ { intros xx id ?. subst xx. destruct_match.
+ + revert_one equiv. rewrite (Hconfig' id).
+ destruct_match; trivial; []. intros [_ Habs]. apply Habs.
+ + revert_one @complement. rewrite (Hconfig' id). destruct_match; intuition. }
+ rewrite <- (filter_extensionalityA_compat Hfun2 (reflexivity names)).
+ assert (Heq0 : length (List.filter (fun _ : ident => false) names) = 0).
+ { induction names; auto. }
+ unfold idle in *. rewrite Heq0, Hlen_idle. lia.
+Qed.
+
+Definition cb_b_precondition_only_black_active :=
+ (* All active robots are black *)
+ all_active_are_black config da
+ (* different number of activated robots on each tower *)
+ /\ length active_on_g1 <> length active_on_other.
+
+Lemma cb_b_precondition_only_black_active_dec :
+ cb_b_precondition_only_black_active \/ ~ cb_b_precondition_only_black_active.
+Proof using .
+set (P := fun id => get_light (config id) == false) in *.
+assert (Hdec : forall id, {P id} + {~P id}). { intros id. apply bool_dec. }
+destruct (Forall_dec P Hdec (active da)).
++ (* All active robots are black *)
+ destruct (length active_on_g1 =? length active_on_other) eqn:heq.
+ - right.
+ intros [h1 h2].
+ rewrite Nat.eqb_eq in *.
+ contradiction.
+ - left.
+ rewrite Nat.eqb_neq in *.
+ now split.
++ right.
+ intros [h1 h2].
+ contradiction.
+Qed.
+
+Lemma color_bivalent_next_bivalent_only_black_active :
+ cb_b_precondition_only_black_active ->
+ bivalent (round gatherR2 da config)
+ /\ ~color_bivalent (round gatherR2 da config).
+Proof using Hssync Hcolor.
+intros [Hallblack Htowers].
+assert (Hconfig' := a3b_next_round Hallblack).
+assert (Hsame_loc := a3b_same_loc).
+assert (Hsame_obs := a3b_same_obs Hallblack).
+assert (dep_and : forall A B : Prop, A -> (A -> B) -> A /\ B) by intuition.
+apply dep_and; clear dep_and.
+* (* bivalent after the round *)
+ repeat split; eauto; []. changeR2.
+ exists loc_g1, loc_others. rewrite Hsame_obs. auto.
+* (* not color bivalent after the round *)
+ intros Hbivalent' [_ [_ [pt1_biv [pt2_biv [Hdiff_biv [Hpt1_biv [Hpt2_biv Hcol']]]]]]].
+ assert (Hperm1 := @have_support config ltac:(auto)).
+ rewrite <- Hsame_obs, obs_fst in Hperm1. changeR2.
+ revert Hperm1 Hcol'.
+ set (obs := (!!! (round gatherR2 da config, (0%VS, witness)))).
+ intros Hperm1 Hcol'.
+ assert (Hperm2 : PermutationA equiv (support (fst obs)) (cons pt1_biv (cons pt2_biv nil))).
+ { apply (bivalent_support Hbivalent'); auto. }
+ assert (Hblack' : (colors (snd (!!! (round gatherR2 da config, (0%VS, witness)))))[(loc_g1, false)]
+ = (colors (snd (!!! (round gatherR2 da config, (0%VS, witness)))))[(loc_others, false)]).
+ { rewrite Hperm1 in Hperm2.
+ apply PermutationA_2 in Hperm2; autoclass; [].
+ rewrite Forall_forall in Hcol'. changeR2.
+ destruct Hperm2 as [[Heq1 Heq2] | [Heq1 Heq2]];
+ rewrite Heq1, Heq2; rewrite Hcol'; reflexivity || now right; left. }
+ clear Hcol' Hpt1_biv Hpt2_biv. revert Hblack'.
+ changeR2. assert (Hcol := same_colors).
+ (* Let us express the number of black robots on each tower after one round. *)
+ destruct (obs_from_config_spec (round gatherR2 da config) (0%VS, witness)) as [_ [_ Hobs']].
+ do 2 rewrite Hobs', config_list_spec, count_filter_length, filter_map, map_length.
+ (* First, black robots after the round are black and inactive robots. *)
+ assert (Hfun : forall pt, (eq ==> eq)%signature
+ (fun id => round gatherR2 da config id ==b (pt, false))
+ (fun id => (config id ==b (pt, false)) && negb (activate da id))).
+ { intros pt xx id ?. subst xx.
+ rewrite 2 state_eqb, a3b_same_loc, a3b_next_black_eqb; intuition. }
+ rewrite (filter_extensionalityA_compat (Hfun loc_g1) (reflexivity names)),
+ (filter_extensionalityA_compat (Hfun loc_others) (reflexivity names)).
+ (* Then, let us split robots wrt colors, location, activation and simplify. *)
+ rewrite (active_idle_is_partition da), (@idle_split config), 2 idle_on_split; auto.
+ repeat rewrite ?filter_app, ?app_length.
+ rewrite 2 a3b_length_idle_active, 4 a3b_length_white_idle, 4 a3b_length_black_idle_eq.
+ assert (loc_g1 =/= loc_others) by auto.
+ cut (length black_idle_on_g1 <> length black_idle_on_other).
+ { simpl_bool; do 2 destruct_match; reflect_bool; auto. lia. }
+ assert (Hblack' := color_bivalent_length_black).
+ assert (Hlen : forall pt, length (black_idle_on pt config) + length (active_on pt config)
+ = length (black_on pt config)).
+ { intro pt. rewrite <- a3b_black_active_is_active; trivial; [].
+ unfold black_idle_on, black_active_on, black_on, active_on, idle_on.
+ now rewrite Nat.add_comm, <- app_length, <- 2 filter_app, <- active_idle_is_partition. }
+ assert (Hpt1' := Hlen loc_g1). specialize (Hlen loc_others).
+ lia.
+Qed.
+
+(* (1 or 2) towers afterward, but one maj. *)
+Definition cb_nb_precondition_wholecolmove :=
+ exists id1 id2,
+ get_location (config id2) =/= get_location (config id1)
+ /\ (forall id, get_location (config id) == get_location (config id1) -> is_moving gatherR2 da config id)
+ /\ is_moving gatherR2 da config id2.
+
+(* Three towers afterward *)
+Definition cb_nb_precondition_somestay :=
+ exists id_move id1 id2,
+ get_location (config id2) =/= get_location (config id1)
+ /\ is_moving gatherR2 da config id_move
+ /\ is_stationary gatherR2 da config id1
+ /\ is_stationary gatherR2 da config id2.
+
+Lemma color_bivalent_next_not_bivalent_wholecolmove :
+ cb_nb_precondition_wholecolmove ->
+ ~ bivalent (round gatherR2 da config).
+Proof using Hssync Hcolor.
+(* More than half the robots move, so a majority tower is created *)
+intros [id1 [id2 [Hdiff [Hid1 Hid2]]]].
+apply (Majority_not_bivalent (pt := get_location (round gatherR2 da config id2))).
+intros pt Hpt.
+cut (Nat.div2 (nG + nB) < (!! (round gatherR2 da config))[get_location (round gatherR2 da config id2)]).
+{ destruct Hcolor as [Heven _]. apply even_div2 in Heven.
+ assert (Hle := sum2_le_total (round gatherR2 da config) (0%VS, witness) Hpt).
+ rewrite <- obs_fst in Hle. changeR2.
+ lia. }
+assert (Hmult : (!! config)[get_location (config id1)] = Nat.div2 (nG + nB)).
+{ assert (Hperm : PermutationA equiv (cons (get_location (config id1)) (cons (get_location (config id2)) nil))
+ (cons loc_g1 (cons loc_others nil))).
+ { etransitivity; [| apply have_support; auto]. symmetry. rewrite obs_fst.
+ apply (bivalent_support (config := config)); auto. }
+ rewrite PermutationA_2 in Hperm; auto; [].
+ destruct Hperm as [[Heq _] | [Heq _ ]]; rewrite Heq; auto. }
+apply Nat.lt_le_trans with (length (moving gatherR2 da config)).
++ cut (incl (id2 :: on_loc (get_location (config id1)) config) (moving gatherR2 da config)).
+ { intro Hincl. eapply Nat.lt_le_trans; [| apply NoDup_incl_length; [| eassumption]].
+ + cbn [length]. erewrite <- obs_from_config_on_loc, Hmult. lia.
+ + constructor.
+ - now rewrite on_loc_spec.
+ - apply on_loc_NoDup. }
+ intros id [Hid | Hid].
+ - now subst id.
+ - apply Hid1. now rewrite on_loc_spec in Hid.
++ rewrite obs_from_config_on_loc.
+ apply NoDup_incl_length.
+ - apply moving_NoDup.
+ - intros id Hid. rewrite on_loc_spec. apply color_bivalent_same_destination; auto.
+Qed.
+
+Lemma color_bivalent_next_not_bivalent_somestay :
+ cb_nb_precondition_somestay ->
+ ~ bivalent (round gatherR2 da config).
+Proof using Hssync Hcolor.
+intros [id_move [id1 [id2 [Hdiff [Hid_move [Hid1 Hid2]]]]]] Hbivalent.
+symmetry in Hdiff.
+unfold is_moving, is_stationary in *.
+rewrite stationary_spec in Hid1, Hid2.
+apply color_bivalent_moving_target in Hid_move.
+assert (Hmiddle : middle loc_g1 loc_others
+ == middle (get_location (config id1)) (get_location (config id2))).
+{ assert (Hperm : PermutationA equiv (support (fst (!!! (config, (0%VS, witness)))))
+ (cons (get_location (config id1)) (cons (get_location (config id2)) nil))).
+ { apply (bivalent_support (color_bivalent_bivalent Hcolor) (0%VS, witness)); auto. }
+ rewrite <- obs_fst, have_support in Hperm; auto.
+ apply PermutationA_2 in Hperm; auto; [].
+ destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]]; rewrite Heq1, Heq2; auto; apply middle_comm. }
+assert (Hsupp : PermutationA equiv (support (!! (round gatherR2 da config)))
+ (cons (get_location (config id1)) (cons (get_location (config id2)) nil))).
+{ rewrite obs_fst. apply (bivalent_support Hbivalent (0%VS, witness)); auto.
+ - rewrite <- Hid1. auto.
+ - rewrite <- Hid2. auto. }
+assert (Hin := pos_in_config (round gatherR2 da config) (0%VS, witness) id_move).
+rewrite Hid_move, Hmiddle, <- support_spec, Hsupp in Hin.
+apply middle_diff in Hdiff.
+contradiction.
+Qed.
+
+
+Lemma forall_ident pred: Forall pred names <-> forall id:ident, pred id.
+Proof using .
+ split.
+ - intros H id.
+ eapply Forall_forall in H;eauto.
+ apply In_names.
+ - intros H.
+ apply Forall_forall.
+ intros x H0.
+ apply H;auto.
+Qed.
+
+Lemma exists_ident pred: List.Exists pred names <-> exists id:ident, pred id.
+Proof using .
+ split.
+ - intros H.
+ eapply Exists_exists in H;eauto.
+ destruct H as [x [hx hx']].
+ exists x.
+ assumption.
+ - intros H.
+ destruct H as [x predx].
+ apply Exists_exists.
+ exists x.
+ split.
+ + apply In_names.
+ + assumption.
+Qed.
+
+
+Lemma Exists_decidable :
+ forall [A : Type] (P : A -> Prop),
+ (forall x : A, P x \/ ~ P x)
+ -> forall (l : list A), List.Exists P l \/~ List.Exists P l.
+Proof using .
+ intros A P H l.
+ induction l.
+ - right.
+ intro abs.
+ inversion abs.
+ - destruct (H a).
+ + left.
+ constructor 1.
+ assumption.
+ + destruct IHl.
+ * left.
+ constructor 2.
+ assumption.
+ * right.
+ intro abs.
+ inversion abs;auto.
+Qed.
+
+
+Lemma Forall_decidable :
+ forall [A : Type] (P : A -> Prop),
+ (forall x : A, P x \/ ~ P x)
+ -> forall (l : list A), List.Forall P l \/~ List.Forall P l.
+Proof using .
+ intros A P H l.
+ induction l.
+ - left.
+ constructor 1.
+ - destruct (H a).
+ + destruct IHl.
+ * left;auto.
+ * right.
+ intro abs.
+ inversion abs;auto.
+ + right.
+ intro abs; inversion abs.
+ auto.
+Qed.
+
+
+Lemma dec1 id1 id:
+ (get_location (config id) == get_location (config id1) ->
+ is_moving gatherR2 da config id)
+ \/ ~ (get_location (config id) == get_location (config id1) ->
+ is_moving gatherR2 da config id).
+Proof using .
+ destruct (equiv_dec (get_location (config id)) (get_location (config id1))).
+ - destruct (in_dec names_eq_dec id (moving gatherR2 da config)).
+ + left.
+ intuition.
+ + right.
+ intuition.
+ - left.
+ intros H.
+ intuition.
+Qed.
+
+Lemma sub_cb_nb_precondition_wholecolmove_dec id1:
+ (forall id : ident,
+ get_location (config id) == get_location (config id1) ->
+ is_moving gatherR2 da config id)
+ \/ ~ (forall id : ident,
+ get_location (config id) == get_location (config id1) ->
+ is_moving gatherR2 da config id).
+Proof using .
+ rewrite <- forall_ident.
+ match goal with
+ |- Forall ?pred _ \/ _ => destruct (Forall_decidable pred (dec1 id1) names)
+ end.
+ - now left.
+ - now right.
+Qed.
+
+
+Lemma dec3 x:
+ Decidable.decidable
+ (exists id2 : ident,
+ get_location (config id2) =/= get_location (config x) /\
+ (forall id : ident,
+ get_location (config id) == get_location (config x) ->
+ is_moving gatherR2 da config id) /\ is_moving gatherR2 da config id2).
+Proof using .
+ red.
+ rewrite <- exists_ident.
+ apply Exists_decidable.
+ intros x0.
+ apply Decidable.dec_and.
+ - unfold Decidable.decidable.
+ destruct ((get_location (config x0) =?= get_location (config x)));intuition.
+ - apply Decidable.dec_and.
+ + red.
+ rewrite <- forall_ident.
+ apply Forall_decidable.
+ apply dec1.
+ + apply is_moving_dec.
+Qed.
+
+
+Lemma cb_nb_precondition_wholecolmove_dec:
+ cb_nb_precondition_wholecolmove \/ ~ cb_nb_precondition_wholecolmove .
+Proof using .
+ unfold cb_nb_precondition_wholecolmove.
+ setoid_rewrite <- exists_ident.
+ apply Exists_decidable.
+ intro x.
+ apply dec3.
+Qed.
+
+
+Lemma observer_light_get_light: forall id,
+ observer_lght (snd (obs_from_config config (config id))) = get_light (config id).
+Proof using .
+ intros id.
+ reflexivity.
+Qed.
+
+(* cb_nb means: someone moves and not a wholecolumn moves. *)
+Lemma cb_nb_spec_1:
+ cb_nb_precondition_wholecolmove
+ -> (exists id_move, is_moving gatherR2 da config id_move)
+ /\ ~ Forall (fun id => get_location (config id) == get_location (config (hd (Good g1) (active da)))) (active da).
+Proof using Hssync Hcolor.
+ intros h_wholecolmoves.
+ unfold cb_nb_precondition_wholecolmove , cb_nb_precondition_somestay in *.
+ destruct h_wholecolmoves as [ida [idb [h_diffab [h_colmove_on_ida h_somemove_on_idb]]]].
+ split.
+ { exists idb;auto. }
+ assert (get_location (config ida) == get_location (config (hd (Good g1) (active da)))
+ \/ get_location (config idb) == get_location (config (hd (Good g1) (active da)))).
+ { destruct (equiv_dec (get_location (config ida)) (get_location (config (hd (Good g1) (active da)))));auto.
+ right.
+ specialize bivalent_same_location_2 as h.
+ specialize (h config (get_location (config idb))).
+ specialize (h (get_location (config (hd (Good g1) (active da))))).
+ specialize (h (get_location (config ida))).
+ eapply h; auto. }
+ assert (List.In idb (active da)) as h_acive_idb.
+ { eapply moving_active; eauto. }
+
+ destruct H as [h | h].
+ - intro abs.
+ rewrite Forall_forall in abs.
+ specialize (abs _ h_acive_idb).
+ rewrite <- h in abs.
+ contradiction.
+ - assert (List.In ida (active da)) as h_acive_ida.
+ { specialize h_colmove_on_ida with (1:=eq_refl).
+ eapply moving_active;eauto. }
+ intro abs.
+ rewrite Forall_forall in abs.
+ specialize (abs _ h_acive_ida).
+ rewrite <- h in abs.
+ symmetry in abs.
+ contradiction.
+Qed.
+
+(* TODO: functions to extract robots on a given location without using observation
+ + thms about splitting and merging configs *)
+
+Lemma black_dont_move: forall id, is_black config id -> is_stationary gatherR2 da config id.
+Proof using Hssync Hcolor.
+ intros id H.
+ unfold is_stationary.
+ rewrite stationary_iff_not_moving, moving_iff.
+ fold is_white.
+ intro abs.
+ destruct abs as [abs abs2].
+ rewrite <- black_white in abs;contradiction.
+Qed.
+
+
+Lemma not_false_iff_true_equiv: forall b:bool, ~ (b == false) <-> b == true.
+Proof using .
+ destruct b;intros;intuition.
+Qed.
+
+Lemma not_true_iff_false_equiv: forall b:bool, ~ (b == true) <-> b == false.
+Proof using .
+ destruct b;intros;intuition.
+Qed.
+
+Ltac light_simp :=
+ repeat
+ match goal with
+ | H: context [(negb _ == true)] |- _ => setoid_rewrite negb_true_iff in H
+ | H: context [(negb _ = true)] |- _ => setoid_rewrite negb_true_iff in H
+ | H: context [~(_ == false)] |- _ => setoid_rewrite not_false_iff_true in H
+ | H: context [~(_ == true)] |- _ => setoid_rewrite not_true_iff_false in H
+ | H: context [~(_ = false)] |- _ => setoid_rewrite not_false_iff_true in H
+ | H: context [~(_ = true)] |- _ => setoid_rewrite not_true_iff_false in H
+ end.
+
+Ltac discharge_dec :=
+ try apply get_light_dec_1;
+ try apply get_light_dec_2;
+ try apply get_light_decidable;
+ try apply get_location_dec;
+ try apply dec_eq_nat;
+ try apply Forall_decidable_color;
+ fail.
+
+
+Lemma all_white_active_moving:
+ all_are_white config -> Permutation (active da) (moving gatherR2 da config).
+Proof using Hcolor Hssync.
+ intros h.
+ changeR2.
+ apply NoDup_Permutation.
+ { apply active_NoDup. }
+ { apply moving_NoDup. }
+ intros x.
+ split;intros h'.
+ - apply moving_iff.
+ red in h.
+ red in h.
+ rewrite Forall_forall in h.
+ split;auto.
+ apply h.
+ apply In_names.
+ - now apply (moving_active Hssync gatherR2 config).
+Qed.
+
+Lemma ident_eq_decidable: ListDec.decidable_eq ident.
+Proof using.
+ red.
+ intros.
+ red.
+ destruct (names_eq_dec x y);auto.
+Qed.
+
+Lemma color_bivalent_exhaustive_cases :
+ cb_cb_precondition
+ \/ (cb_b_precondition_all_white \/ cb_b_precondition_only_black_active)
+ \/ (cb_nb_precondition_wholecolmove \/ cb_nb_precondition_somestay).
+Proof using Hssync Hcolor.
+destruct (active da) as [| id l] eqn:Hactive.
+- (* No active robot *)
+ left.
+ assert (Heq := no_active_same_config Hssync gatherR2 config Hactive).
+ red.
+ split.
+ + red.
+ rewrite Hactive. constructor.
+ + assert (active_on_g1 ++ active_on_other = []).
+ { eapply (@PermutationA_nil _ equiv _);try typeclasses eauto.
+ rewrite <- Hactive.
+ symmetry.
+ apply active_split.
+ auto. }
+ apply app_eq_nil in H.
+ destruct H as [heq1 heq2].
+ now rewrite heq1,heq2.
+- (* Some active robot id *)
+ destruct cb_cb_precondition_dec as [ ? | h_cb_cb].
+ { left;auto. }
+ destruct cb_b_precondition_all_white_dec as [ ? | h_cb_b_allw ].
+ { right;left;auto. }
+ destruct cb_b_precondition_only_black_active_dec as [ ? | h_cb_b_onlyb ].
+ { right;left;right;auto. }
+ destruct cb_nb_precondition_wholecolmove_dec as [ ? | h_cb_nb_wm].
+ { right. right. left. auto. }
+ do 3 right.
+
+ unfold cb_cb_precondition, cb_b_precondition_all_white,
+ cb_b_precondition_only_black_active, cb_nb_precondition_wholecolmove in *.
+ rewrite not_and in *; auto with color_dec.
+
+ assert ((forall id1 id2 : ident,
+ get_location (config id2) == get_location (config id1) \/
+ (exists id : ident,
+ get_location (config id) == get_location (config id1) /\
+ ~ is_moving gatherR2 da config id) \/
+ ~is_moving gatherR2 da config id2)).
+ { intros id1 id2.
+ clear -h_cb_nb_wm.
+ apply Classical_Pred_Type.not_ex_all_not with (n:=id1) in h_cb_nb_wm.
+ apply Classical_Pred_Type.not_ex_all_not with (n:=id2) in h_cb_nb_wm.
+ rewrite not_and in *.
+ 2:{ red.
+ destruct (get_location (config id2)
+ =?= get_location (config id1));auto. }
+ destruct h_cb_nb_wm.
+ { left.
+ destruct (get_location (config id2)
+ =?= get_location (config id1));auto. }
+ right.
+ rewrite not_and in *.
+ 2:{ red. apply sub_cb_nb_precondition_wholecolmove_dec. }
+ destruct H.
+ - left.
+ rewrite <- exists_ident.
+ rewrite <- forall_ident in H.
+ rewrite <- Exists_Forall_neg in H.
+ + revert H.
+ apply Exists_impl.
+ intros a H.
+ destruct (get_location (config a) =?= get_location (config id1)).
+ * split;auto.
+ * exfalso.
+ apply H.
+ intros H0.
+ contradiction.
+ + apply dec1.
+ - now right. }
+ clear h_cb_nb_wm.
+ rename H into h_cb_nb_wm.
+
+ assert (forall id1:ident,
+ (exists id : ident,
+ get_location (config id) == get_location (config id1) /\
+ ~ is_moving gatherR2 da config id)
+ \/ forall id2 : ident, get_location (config id2) =/= get_location (config id1)
+ -> ~is_moving gatherR2 da config id2) as h_cb_nb_wm'.
+ { setoid_rewrite or_comm in h_cb_nb_wm.
+ setoid_rewrite or_assoc in h_cb_nb_wm.
+ assert
+ (forall id1 id2 : ident,
+ (exists id : ident,
+ get_location (config id) == get_location (config id1)
+ /\ ~ is_moving gatherR2 da config id)
+ \/ (~ (exists id : ident,
+ get_location (config id) == get_location (config id1)
+ /\ ~ is_moving gatherR2 da config id))
+ /\ (~ is_moving gatherR2 da config id2
+ \/ get_location (config id2) == get_location (config id1))).
+ { intros id0 id2.
+ specialize (h_cb_nb_wm id0 id2).
+ rewrite <-exists_ident in h_cb_nb_wm.
+ destruct (Exists_decidable ((fun id : ident =>
+ get_location (config id) == get_location (config id0) /\ ~ is_moving gatherR2 da config id))) with (l:=names).
+ { intros id'.
+ apply Decidable.dec_and.
+ - apply get_location_dec.
+ - apply Decidable.dec_not.
+ destruct (is_moving_dec gatherR2 da config id'); now left + right. }
+ + left; apply exists_ident;auto.
+ + destruct h_cb_nb_wm as [h | [h | h]].
+ * contradiction.
+ * right.
+ split.
+ -- rewrite <- exists_ident;auto.
+ -- now left.
+ * right.
+ split.
+ -- rewrite <- exists_ident;auto.
+ -- now right. }
+
+ intros id1.
+ specialize (H id1 id1) as h.
+ destruct h as [h | [h' [h | h]]].
+ - left;auto.
+ - clear h.
+ right.
+ intros id2.
+ destruct (H id1 id2) as [h | [h'' [h | h]]].
+ + contradiction.
+ + auto.
+ + auto.
+ - clear h.
+ right.
+ intros id2.
+ destruct (H id1 id2) as [h | [h'' [h | h]]].
+ + contradiction.
+ + auto.
+ + auto. }
+ clear h_cb_nb_wm.
+ rename h_cb_nb_wm' into h_cb_nb_wm.
+
+ red.
+ assert (~all_active_are_black config da) as not_all_blacks.
+ { destruct h_cb_cb;auto.
+ destruct h_cb_b_onlyb;auto. }
+ clear h_cb_cb h_cb_b_onlyb.
+
+ (* not_all_blacks is enough to have one moving robot *)
+ assert (exists id_move, is_moving gatherR2 da config id_move) as hex.
+ { unfold all_active_are_black, all_are_black_in in not_all_blacks.
+ apply <- Exists_Forall_neg in not_all_blacks.
+ - rewrite Exists_exists in not_all_blacks.
+ destruct not_all_blacks as [ id_move [ hIn hwhite] ].
+ exists id_move.
+ apply moving_iff.
+ split;auto.
+ now apply black_white.
+ - apply is_black_dec. }
+
+ destruct hex as [id_move hmove].
+ exists id_move.
+ enough (exists id1 id2 : ident,
+ get_location (config id2) =/= get_location (config id1) /\
+ is_stationary gatherR2 da config id1 /\ is_stationary gatherR2 da config id2) as h.
+ { decompose [ex and] h.
+ exists x, x0;auto. }
+
+ destruct (Forall_decidable_white config) as [h_allw | h_notallw].
+ all:swap 1 2.
+ { rewrite <- all_white_black_names in h_notallw.
+ apply <- Exists_Forall_neg in h_notallw.
+ 2:{ intros.
+ setoid_rewrite black_white.
+ apply is_white_dec.
+ }
+
+ apply Exists_exists in h_notallw.
+ destruct h_notallw as [id_black [ _ hblack]].
+ rewrite black_white in hblack.
+ rewrite white_black in hblack.
+
+ assert (h_colbiv:=Hcolor).
+ destruct h_colbiv as [heven [hgt2 [pt1 [pt2 [hneq [hobs1 [hobs2 h_samecol]]]]]]].
+ destruct (get_location (config id_black) =?= pt1).
+ + assert (exists id_black2, is_black config id_black2
+ /\ (get_location (config id_black2) == pt2)) as hex.
+ { rewrite Forall_forall in h_samecol.
+ specialize (h_samecol false).
+ assert (List.In false l_list) as h_In.
+ { right;left.
+ reflexivity. }
+ specialize (h_samecol h_In).
+ changeR2.
+ match type of h_samecol with
+ _ = ?A => assert (A>0) as h_nb_black_pt1
+ end.
+ { rewrite <- h_samecol.
+ change (In (pt1, false) (colors (snd (!!! (config, (0%VS, witness)))))).
+ changeR2.
+ rewrite -> obs_from_config_In_gen.
+ exists id_black.
+ split.
+ - assumption.
+ - apply hblack. }
+ change (In (pt2, false) (colors (snd (!!! (config, (0%VS, witness)))))) in h_nb_black_pt1.
+ changeR2.
+ rewrite obs_from_config_In_gen in h_nb_black_pt1.
+ destruct h_nb_black_pt1 as [id_black2 hblack2].
+ exists id_black2.
+ unfold is_black.
+ changeR2.
+ rewrite hblack2.
+ split;auto. }
+ destruct hex as [id_black2 [h_black2 hloc2]].
+ exists id_black, id_black2.
+ repeat split;auto.
+ * rewrite hloc2, e.
+ now symmetry.
+ * now apply black_dont_move.
+ * now apply black_dont_move.
+ + assert ((get_location (config id_black) == pt2)) as h_idblack_pt2.
+ Typeclasses eauto := (bfs).
+ { apply bivalent_same_location with (pt3:=pt1) (config:=config) (st:=(0%VS, witness)); auto. }
+ assert (exists id_black2, is_black config id_black2
+ /\ (get_location (config id_black2) == pt1)) as hex.
+ { rewrite Forall_forall in h_samecol.
+ specialize (h_samecol false).
+ assert (List.In false l_list) as h_In.
+ { right;left.
+ reflexivity. }
+ specialize (h_samecol h_In).
+ changeR2.
+ match type of h_samecol with
+ ?A = _ => assert (A>0) as h_nb_black_pt1
+ end.
+ { rewrite h_samecol.
+ change (In (pt2, false) (colors (snd (!!! (config, (0%VS, witness)))))).
+ changeR2.
+ rewrite -> obs_from_config_In_gen.
+ exists id_black.
+ split.
+ - assumption.
+ - apply hblack. }
+ change (In (pt1, false) (colors (snd (!!! (config, (0%VS, witness)))))) in h_nb_black_pt1.
+ changeR2.
+ rewrite obs_from_config_In_gen in h_nb_black_pt1.
+ destruct h_nb_black_pt1 as [id_black2 hblack2].
+ exists id_black2.
+ unfold is_black.
+ changeR2.
+ Typeclasses eauto := (dfs) 7.
+ rewrite hblack2.
+ split;auto. }
+ destruct hex as [id_black2 [h_black2 hloc2]].
+ exists id_black, id_black2.
+ repeat split;auto.
+ * rewrite hloc2, h_idblack_pt2.
+ now symmetry.
+ * now apply black_dont_move.
+ * now apply black_dont_move. }
+ { (* All robots are white *)
+ (* let us simplify hypothesis *)
+ apply Classical_Prop.imply_and_or in h_cb_b_allw.
+ 2:{ contradiction. }
+ assert (length (active da) <> Nat.div2 (nG + nB) \/
+ length (active da) == Nat.div2 (nG + nB)
+ /\ active da <> on_loc (get_location (config (hd (Good g1) (active da)))) config) as h.
+ { destruct (length (active da) =?= Nat.div2 (nG + nB));auto. }
+ clear h_cb_b_allw.
+ rename h into h_cb_b_allw.
+ destruct h_cb_b_allw as [h_not_div2_active | [h_exactly_div2 h_not_all_sameloc]].
+
+ - (* (h_cb_nb_wm idopp) proves that there is a robot id' opposite
+ to id_move that does not move. *)
+ assert (exists id', get_location (config id') <> get_location (config id_move)
+ /\ ~ is_moving gatherR2 da config id') as [id' [h_id'_otherloc h_id'_nomove]].
+ { (* We need a robot idopp not colocated with id_move. *)
+
+ destruct (bivalent_exists_opposite_id id_move (color_bivalent_bivalent Hcolor)) as [idopp h_idopp].
+ (* now we can apply h_cb_nb_wm on it to obtain a stationary one. *)
+ specialize (h_cb_nb_wm idopp).
+ destruct h_cb_nb_wm as [[id_other [id_other_loc id_other_nomove]] | h_forall].
+ - exists id_other;split;auto.
+ rewrite id_other_loc.
+ assumption.
+ - exfalso.
+ specialize (h_forall id_move).
+ apply h_forall; auto. }
+
+ assert ((exists id'', get_location (config id'') = get_location (config id_move)
+ /\ ~ is_moving gatherR2 da config id'')
+ \/ ~(exists id'', get_location (config id'') = get_location (config id_move)
+ /\ ~ is_moving gatherR2 da config id''))
+ as [[id'' [h_id''_loc h_id''_move]]| h].
+ { setoid_rewrite <- exists_ident.
+ apply Exists_decidable.
+ intros x.
+ apply Decidable.dec_and.
+ - apply get_location_dec.
+ - apply Decidable.dec_not.
+ apply is_moving_dec. }
+ + exists id', id'';repeat split;auto.
+ * rewrite h_id''_loc.
+ symmetry.
+ assumption.
+ * now apply stationary_moving.
+ * now apply stationary_moving.
+ + rewrite <- exists_ident in h.
+ rewrite <- Forall_Exists_neg in h.
+ changeR2.
+ assert (Forall (fun x : ident =>
+ (get_location (config x) = get_location (config id_move) -> is_moving gatherR2 da config x)) names)
+ as h'.
+ { eapply @Forall_Permutation_compat.
+ 3:eassumption.
+ 2:reflexivity.
+ repeat intro.
+ rewrite H.
+ destruct (is_moving_dec gatherR2 da config y); intuition. }
+ clear h.
+ rewrite Forall_forall in h'.
+
+ specialize (h_cb_nb_wm id_move) as h.
+ destruct h as [ abs | h].
+ * exfalso.
+ destruct abs as [idabs [h_idabs_loc h_idabs_move]].
+ apply h_idabs_move.
+ apply h' ;auto.
+ apply In_names.
+ * (* h and h' imply length (active da) == Nat.div2 (nG + nB) ===> contradiction. *)
+ exfalso.
+ specialize (color_bivalent_bivalent Hcolor) as hcolor.
+
+ assert (hbiv := fun pt3 id3 => @bivalent_same_location_2 _ _ _ _ _
+ (get_location (config id_move)) (get_location (config id'))
+ pt3 id_move id' id3 hcolor eq_refl eq_refl).
+ assert (forall (pt3 : location) (id3 : ident),
+ get_location (config id3) = pt3 ->
+ get_location (config id3) = get_location (config id')
+ \/ get_location (config id3) = get_location (config id_move)).
+ { intros pt3 id3 H.
+ destruct (equiv_dec (get_location (config id3)) (get_location (config id'))).
+ { now left. }
+ destruct (equiv_dec (get_location (config id3)) (get_location (config id_move))).
+ { now right. }
+ exfalso.
+ apply h_id'_otherloc.
+ symmetry.
+ apply hbiv with (pt3:= pt3) (id3:=id3);auto.
+ - rewrite <- H. now symmetry.
+ - rewrite <- H. now symmetry. }
+ clear hbiv.
+ rename H into hbiv.
+ red in hcolor.
+ destruct hcolor as [Heven [Hn [pt1 [pt2 [Hdiff [Hpt1 Hpt2 ]]]]]].
+ assert (In pt1 (!! config)) as h_in_pt1.
+ { changeR2.
+ red.
+ rewrite Hpt1.
+ apply Exp_prop.div2_not_R0.
+ lia. }
+ assert (In pt2 (!! config)) as h_in_pt2.
+ { changeR2.
+ red.
+ rewrite Hpt2.
+ apply Exp_prop.div2_not_R0.
+ lia. }
+ apply obs_from_config_In in h_in_pt1, h_in_pt2.
+ destruct h_in_pt1 as [id_biv1 h_id_biv1].
+ destruct h_in_pt2 as [id_biv2 h_id_biv2].
+ assert (length (moving gatherR2 da config) = Nat.div2 (nG + nB)).
+ { unfold is_moving in h'.
+ assert (h_loc :=
+ filter_weakened
+ (fun id => negb (get_location (round gatherR2 da config id) ==b get_location (config id)))
+ (fun x => get_location (config x) ==b get_location (config id_move))
+ names).
+ changeR2.
+ assert (h_loc' :=
+ filter_weakened
+ (fun x => get_location (config x) ==b get_location (config id_move))
+ (fun id => negb (get_location (round gatherR2 da config id) ==b get_location (config id)))
+ names).
+ changeR2.
+ rewrite ListComplements.filter_comm in h_loc'.
+ rewrite h_loc in h_loc'.
+ match type of h_loc with
+ _ -> _ = ?A => change A with (moving gatherR2 da config) in h_loc'
+ end.
+ clear h_loc.
+ rewrite h_loc'.
+ - destruct (hbiv pt1 id_biv1 h_id_biv1).
+ + destruct (hbiv pt2 id_biv2 h_id_biv2).
+ { rewrite <- H in H0.
+ rewrite h_id_biv1, h_id_biv2 in H0.
+ symmetry in H0.
+ contradiction. }
+ rewrite <- H0.
+ rewrite h_id_biv2.
+ changeR2.
+ change (count_if (fun id => R2dec_bool (get_location (config id)) pt2) = Nat.div2 (nG + nB)).
+ rewrite count_if_multiplicity.
+ assumption.
+ + rewrite <- H.
+ rewrite h_id_biv1.
+ changeR2.
+ change (count_if (fun id => R2dec_bool (get_location (config id)) pt1) = Nat.div2 (nG + nB)).
+ rewrite count_if_multiplicity.
+ assumption.
+ - intros x H H0.
+ setoid_rewrite List.filter_In in h'.
+ apply h'; auto.
+ now apply R2dec_bool_true_iff.
+ - intros x H H0.
+ match goal with
+ |- ?a = true => destruct a eqn:heq; auto
+ end.
+ exfalso.
+ rewrite -> R2dec_bool_false_iff in heq.
+ apply (h _ heq);auto.
+ apply List.filter_In.
+ split; auto. }
+ rewrite <- H in h_not_div2_active.
+ apply h_not_div2_active.
+ rewrite all_white_active_moving; auto.
+ - assert (exists id', get_location (config id') <> get_location (config id_move)
+ /\ ~ is_moving gatherR2 da config id') as [id' [h_id'_otherloc h_id'_nomove]].
+ { (* We need a robot idopp not colocated with id_move. *)
+ destruct (bivalent_exists_opposite_id id_move (color_bivalent_bivalent Hcolor)) as [idopp h_idopp].
+ (* now we can apply h_cb_nb_wm on it to obtain a stationary one. *)
+ specialize (h_cb_nb_wm idopp).
+ destruct h_cb_nb_wm as [[id_other [id_other_loc id_other_nomove]] | h_forall].
+ - exists id_other;split;auto.
+ rewrite id_other_loc.
+ assumption.
+ - exfalso.
+ specialize (h_forall id_move).
+ apply h_forall;auto. }
+
+ (* destruct (exists_dec id', id' colocated with id_move /\ ~ is_moving id)
+ - trivial.
+ - by (h_cb_nb_wm id_move) the case where all robots on id_move move implies that there are
+ exactly (div2 n) robots moving, which is contradictory. *)
+ assert ((exists id'', get_location (config id'') = get_location (config id_move)
+ /\ ~ is_moving gatherR2 da config id'')
+ \/ ~(exists id'', get_location (config id'') = get_location (config id_move)
+ /\ ~ is_moving gatherR2 da config id''))
+ as [[id'' [h_id''_loc h_id''_move]]| h].
+ { setoid_rewrite <- exists_ident.
+ apply Exists_decidable.
+ intros x.
+ apply Decidable.dec_and.
+ - apply get_location_dec.
+ - apply Decidable.dec_not.
+ apply is_moving_dec. }
+ + exists id', id'';repeat split;auto.
+ * rewrite h_id''_loc.
+ symmetry.
+ assumption.
+ * now apply stationary_moving.
+ * now apply stationary_moving.
+ + rewrite <- exists_ident in h.
+ rewrite <- Forall_Exists_neg in h.
+ changeR2.
+ assert (Forall (fun x : ident =>
+ (get_location (config x) = get_location (config id_move) -> is_moving gatherR2 da config x)) names)
+ as h'.
+ { eapply @Forall_Permutation_compat.
+ 3:eassumption.
+ 2:reflexivity.
+ repeat intro.
+ rewrite H.
+ destruct (is_moving_dec gatherR2 da config y); intuition. }
+ clear h.
+ rewrite Forall_forall in h'.
+
+ specialize (h_cb_nb_wm id_move) as h.
+ destruct h as [ abs | h].
+ * exfalso.
+ destruct abs as [idabs [h_idabs_loc h_idabs_move]].
+ apply h_idabs_move.
+ apply h' ;auto.
+ apply In_names.
+ * (* h and h' imply length (active da) == Nat.div2 (nG + nB) ===> contradiction. *)
+ exfalso.
+ specialize (color_bivalent_bivalent Hcolor) as hcolor.
+
+ assert (hbiv := fun pt3 id3 => @bivalent_same_location_2 _ _ _ _ _
+ (get_location (config id_move)) (get_location (config id'))
+ pt3 id_move id' id3 hcolor eq_refl eq_refl).
+ assert (forall (pt3 : location) (id3 : ident),
+ get_location (config id3) = pt3 ->
+ get_location (config id3) = get_location (config id')
+ \/ get_location (config id3) = get_location (config id_move)).
+ { intros pt3 id3 H.
+ destruct (equiv_dec (get_location (config id3)) (get_location (config id'))).
+ { now left. }
+ destruct (equiv_dec (get_location (config id3)) (get_location (config id_move))).
+ { now right. }
+ exfalso.
+ apply h_id'_otherloc.
+ symmetry.
+ apply hbiv with (pt3:= pt3) (id3:=id3);auto.
+ - rewrite <- H. now symmetry.
+ - rewrite <- H. now symmetry. }
+ clear hbiv.
+ rename H into hbiv.
+ red in hcolor.
+ destruct hcolor as [Heven [Hn [pt1 [pt2 [Hdiff [Hpt1 Hpt2 ]]]]]].
+ assert (In pt1 (!! config)) as h_in_pt1.
+ { changeR2.
+ red.
+ rewrite Hpt1.
+ apply Exp_prop.div2_not_R0.
+ lia. }
+ assert (In pt2 (!! config)) as h_in_pt2.
+ { changeR2.
+ red.
+ rewrite Hpt2.
+ apply Exp_prop.div2_not_R0.
+ lia. }
+ apply obs_from_config_In in h_in_pt1, h_in_pt2.
+ destruct h_in_pt1 as [id_biv1 h_id_biv1].
+ destruct h_in_pt2 as [id_biv2 h_id_biv2].
+
+ assert (exists id_counterexample,
+ List.In id_counterexample (active da)
+ /\ get_location (config id_counterexample) = get_location (config id')) as [id_counter [h_counter1 h_counter2]].
+ { apply Decidable.dec_not_not.
+ { red.
+ setoid_rewrite <- exists_ident.
+ apply Exists_decidable.
+ intros x.
+ apply Decidable.dec_and.
+ - red.
+ apply ListDec.In_decidable;try typeclasses eauto.
+ apply ident_eq_decidable.
+ - apply get_location_dec. }
+ intros abs.
+ apply h_not_all_sameloc.
+ rewrite <- Exists_exists in abs.
+ rewrite <- Forall_Exists_neg in abs.
+ rewrite Forall_forall in abs.
+ assert ((hd (Good g1) (List.filter (activate da) names)) = id) as h_eq_id.
+ { unfold active in Hactive.
+ rewrite Hactive.
+ now cbn -[equiv]. }
+ assert ((hd (Good g1) (active da)) = id) as h_eq_id2.
+ { rewrite <- h_eq_id.
+ rewrite Hactive.
+ unfold active in Hactive.
+ rewrite Hactive.
+ reflexivity. }
+ rewrite h_eq_id2.
+ unfold active.
+ apply filter_ext.
+ intros a.
+ assert (List.In id (active da)) as h_id_active.
+ { rewrite Hactive.
+ cbn.
+ now left. }
+ assert (forall x, is_moving gatherR2 da config x <-> activate da x = true) as h_iff.
+ { intros x.
+ split;intro h_split.
+ - apply active_spec.
+ eapply moving_active with (r:=gatherR2) (config:=config);auto.
+ - apply active_spec in h_split.
+ rewrite all_white_active_moving in h_split;auto. }
+ assert (forall x : ident, List.In x (active da)
+ -> get_location (config x) == get_location (config id_move)).
+ { intros x H.
+ destruct (equiv_dec (get_location (config x)) (get_location (config id_move))).
+ - assumption.
+ - exfalso.
+ apply (h _ c).
+ rewrite h_iff.
+ now apply active_spec. }
+ destruct (activate da a) eqn:h_activate.
+ - apply active_spec in h_activate.
+ assert (get_location (config id) == get_location (config id_move)) as h_loc_id.
+ { now apply (H id). }
+ rewrite h_loc_id.
+ specialize (H a h_activate) as h_a.
+ rewrite <- equiv_decb_spec in h_a.
+ now rewrite h_a.
+ -
+ destruct (equiv_dec (get_location (config a)) (get_location (config id_move))).
+ + apply h' in e.
+ 2:apply In_names.
+ exfalso.
+ assert (forall x : ident, ~is_moving gatherR2 da config x <-> activate da x = false) as h_iff2.
+ { intros x.
+ rewrite <- not_true_iff_false.
+ apply not_iff_compat.
+ apply h_iff. }
+ rewrite <- h_iff2 in h_activate.
+ now apply h_activate.
+ + rewrite <- equiv_decb_false in c.
+ assert (get_location (config id) == get_location (config id_move)) as h_loc_id.
+ { now apply (H id). }
+ rewrite h_loc_id.
+ now rewrite c. }
+ eapply h with id_counter.
+ -- rewrite h_counter2.
+ apply h_id'_otherloc.
+ -- apply moving_iff.
+ split.
+ ++ (* TODO: reformulate all_are_white *)
+ do 2 red in h_allw.
+ rewrite Forall_forall in h_allw.
+ apply h_allw.
+ apply In_names.
+ ++ assumption.
+ }
+Qed.
+
+Lemma get_light_decb_spec id col: get_light (config id) = col <-> get_light_decb config col id = true.
+Proof using .
+ unfold get_light_decb.
+ destruct_match.
+ - split;auto.
+ - split;intro; try contradiction; try discriminate.
+Qed.
+
+End ColorBivalent.
+
+Theorem color_bivalent_round_lt_config : forall config, color_bivalent config ->
+ changing gatherR2 da config <> nil ->
+ lt_config (round gatherR2 da config) config.
+Proof using Hssync.
+intros config Hcolor Hchanging. unfold lt_config, measure.
+assert (Hbivalent := color_bivalent_bivalent Hcolor).
+rewrite <- bivalent_obs_spec in Hbivalent.
+assert (Hcol := Hcolor). rewrite <- color_bivalent_obs_spec in Hcol.
+rewrite Hbivalent, Hcol.
+destruct (color_bivalent_exhaustive_cases Hcolor)
+ as [Hcb | [Hb | Hnb]].
+* (* color bivalent after the round *)
+ assert (Hnext := color_bivalent_next_color_bivalent Hcolor Hcb).
+ assert (Hbivalent' := color_bivalent_bivalent Hnext).
+ rewrite <- bivalent_obs_spec in Hbivalent'. rewrite <- color_bivalent_obs_spec in Hnext.
+ rewrite Hbivalent', Hnext. right.
+ destruct Hcb as [h_all_are_black h_same_number].
+ set (g:= fun (c:configuration) (id:ident) => get_light (c id)).
+ assert (
+ forall c st,
+ count_black (!!!(c,st)) =
+ List.count_occ bool_dec
+ (List.map (fun id => if activate da id then g c id else g c id) names)
+ false).
+ { intros c st.
+ unfold count_black.
+ erewrite fold_extensionality_compat with (g:=(fun (_ : location * bool) (n0 acc : nat) => n0 + acc));eauto.
+ - rewrite <- cardinal_spec.
+ rewrite <- count_occ_alt.
+ unfold count_occ'.
+ rewrite map_ext with (g:=g c).
+ 2:{ intros a.
+ destruct (activate da a);auto. }
+ unfold obs_from_config.
+ unfold Obs, PairObservation.pair_observation, multiset_observation.
+ cbn [snd].
+ unfold obs_from_config,Obs2, multiset_observation, obs_from_config2.
+ cbn [colors].
+ rewrite config_list_spec.
+ setoid_rewrite <- make_multiset_filter.
+ + setoid_rewrite cardinal_make_multiset.
+ unfold g.
+ setoid_rewrite <- map_map at 2.
+ setoid_rewrite filter_map at 2.
+ setoid_rewrite map_length.
+ f_equal.
+ apply filter_ext.
+ unfold get_light.
+ changeR2.
+ intros a.
+ destruct (snd a) ;auto.
+ + repeat intro.
+ now rewrite H.
+ - repeat intro.
+ now subst.
+ - red.
+ repeat intro.
+ lia.
+ - intros.
+ lia. }
+ do 2 rewrite H.
+ set (new_config := round gatherR2 da config) in *.
+ specialize @map_cond_Permutation with (A:=ident) (f:=(activate da)) (gâ‚ := g config) (gâ‚‚ := g config) as h.
+ specialize @map_cond_Permutation with (A:=ident) (f:=(activate da)) (gâ‚ := g new_config) (gâ‚‚ := g new_config) as h'.
+ unshelve setoid_rewrite Permutation_count_occ in h.
+ { apply bool_dec. }
+ rewrite h.
+ unshelve setoid_rewrite Permutation_count_occ in h'.
+ { apply bool_dec. }
+ rewrite h'.
+ setoid_rewrite count_occ_app.
+ match goal with
+ |- ?A + ?B < ?C + ?D => assert (B = D);[ | assert (A < C) ]
+ end.
+ 3: lia.
+ { rewrite (map_ext_Forall (g new_config) (g config)).
+ - reflexivity.
+ - apply Forall_forall.
+ intros x hIn.
+ apply List.filter_In in hIn.
+ destruct hIn as [hIn h_inactive].
+ unfold g, new_config.
+ rewrite Formalism.SSync_inactive_nochange;auto.
+ now rewrite negb_true_iff in h_inactive. }
+ assert (count_occ bool_dec (List.map (g new_config) (List.filter (activate da) names)) false = 0) as heq_0.
+ { apply count_occ_not_In.
+ intro abs.
+ rewrite in_map_iff in abs.
+ destruct abs as [id_abs [h_abs_black h_abs_active]].
+ rewrite List.filter_In in h_abs_active.
+ destruct h_abs_active as [ _ h_active].
+ assert (is_black (round gatherR2 da config) id_abs) as h''.
+ { assumption. }
+ rewrite a3b_next_black in h''; auto; [].
+ destruct h'' as [h'' h'''].
+ rewrite h_active in h'''.
+ discriminate. }
+ changeR2.
+ rewrite heq_0.
+ destruct (changing gatherR2 da config) eqn:heq.
+ - exfalso.
+ now apply Hchanging.
+ - assert (List.In i (List.filter (activate da) names)) as h_i_active.
+ { changeR2.
+ change (List.In i (active da)).
+ changeR2.
+ eapply changing_active with (r:=gatherR2)(config:=config) ;eauto.
+ rewrite heq.
+ cbn.
+ now left. }
+ assert (h_i_active':=h_i_active).
+ apply (in_map (g config)) in h_i_active.
+ apply count_occ_In.
+ assert (g config i = false) as h_i_black.
+ { unfold all_active_are_black,all_are_black_in in h_all_are_black.
+ rewrite Forall_forall in h_all_are_black.
+ apply h_all_are_black.
+ assumption. }
+ rewrite h_i_black in h_i_active.
+ assumption.
+* (* bivalent but not color bivalent after the round *)
+ assert (Hnext : bivalent (round gatherR2 da config) /\ ~ color_bivalent (round gatherR2 da config)).
+ { destruct Hb as [Hb_white | Hb_black].
+ - now apply color_bivalent_next_bivalent_all_white in Hb_white.
+ - now apply color_bivalent_next_bivalent_only_black_active in Hb_black. }
+ destruct Hnext as [Hbivalent' Hcolor'].
+ rewrite <- bivalent_obs_spec in Hbivalent'.
+ rewrite <- color_bivalent_obs_spec in Hcolor'.
+ rewrite not_true_iff_false in Hcolor'.
+ rewrite Hbivalent', Hcolor'.
+ left. lia.
+* (* not bivalent after the round *)
+ assert (Hnext : ~ bivalent (round gatherR2 da config)).
+ { destruct Hnb as [Hnb_wholecolmove | Hnb_somestay].
+ - now apply color_bivalent_next_not_bivalent_wholecolmove in Hnb_wholecolmove.
+ - now apply color_bivalent_next_not_bivalent_somestay in Hnb_somestay. }
+ rewrite <- bivalent_obs_spec, not_true_iff_false in Hnext.
+ rewrite Hnext.
+ unfold old_measure. repeat destruct_match; left; lia.
+Qed.
+
+
+Section BivalentButNotColorBivalent.
+
+Variable config : configuration.
+Hypothesis Hbivalent : bivalent config.
+Hypothesis Hcolor : ~ color_bivalent config.
+
+Theorem round_simplify_bivalent :
+ round gatherR2 da config
+ == fun id =>
+ if da.(activate) id
+ then
+ let obs := !!!(config, config id) in
+ let maj_black := find_max_black obs (loc_g1 config) (loc_others config) in
+ (maj_black, observer_lght (snd obs))
+ else config id.
+Proof using Hssync Hbivalent Hcolor.
+rewrite round_simplify; trivial; [].
+intro id. destruct_match; auto; [].
+cbn zeta.
+rewrite <- color_bivalent_obs_spec, not_true_iff_false in Hcolor; auto; [].
+rewrite <- bivalent_obs_spec in Hbivalent; auto; [].
+now rewrite Hbivalent, Hcolor.
+Qed.
+
+(* If a configuration is bivalent but not color_bivalent, we have:
+ 1) All robots target the tower with the most black robots
+ 2) Thus, this tower can only increase and all other location can only decrease
+ 3) If a robot moves it creates a majority tower. *)
+(* Any active robot targets the blackest tower *)
+Lemma not_color_bivalent_target : forall id, List.In id (active da) ->
+ get_location (round gatherR2 da config id)
+ == find_max_black (!!! (config, config id)) (loc_g1 config) (loc_others config).
+Proof using Hssync Hbivalent Hcolor.
+intros id Hid.
+rewrite (round_simplify_bivalent id).
+rewrite active_spec in Hid. now rewrite Hid.
+Qed.
+
+Corollary not_color_bivalent_moving_target : forall id, List.In id (moving gatherR2 da config) ->
+ get_location (round gatherR2 da config id)
+ == find_other_loc (fst (!!! (config, config id))) (get_location (config id)).
+Proof using Hssync Hbivalent Hcolor.
+intros id Hid.
+assert (List.In id (active da)).
+{ revert Hid. now apply moving_active. }
+rewrite not_color_bivalent_target; auto.
+rewrite moving_spec in Hid.
+changeR2.
+match goal with |- find_max_black ?a ?b ?c == _ =>
+ destruct (find_max_black_either a b c) as [Heq1 | Heq1]
+end;
+destruct (bivalent_get_location_cases Hbivalent id) as [Heq2 | Heq2];
+rewrite <- not_color_bivalent_target in * |- *; rewrite ?Heq1, ?Heq2; auto.
+- congruence.
+- now rewrite fold_obs_fst, find_other_loc_loc_others.
+- congruence.
+Qed.
+
+Lemma not_color_bivalent_same_destination : same_destination_if_active gatherR2 da config.
+Proof using Hssync Hbivalent Hcolor.
+intros id1 id2 Hid1 Hid2.
+etransitivity; [now eapply not_color_bivalent_target; eauto |].
+now rewrite not_color_bivalent_target.
+Qed.
+
+Theorem not_color_bivalent_wither_and_grow : forall id,
+ List.In id (moving gatherR2 da config) ->
+ let pt' := find_other_loc (!! config) (get_location (config id)) in
+ (forall pt, pt =/= pt' -> (!! (round gatherR2 da config))[pt] <= (!! config)[pt])
+ /\ (!! config)[pt'] < (!! (round gatherR2 da config))[pt'].
+Proof using Hssync Hbivalent Hcolor.
+intros id Hmove. cbn zeta.
+set (pt' := find_other_loc (!! config) (get_location (config id))).
+ (* We assume the large inequalities. *)
+cut ((forall pt, pt =/= pt' -> (!! (round gatherR2 da config))[pt] <= (!! config)[pt]) /\
+ (!! config)[pt'] <= (!! (round gatherR2 da config))[pt']).
+{ intros [Hle1 Hle2]. split; trivial; [].
+ rewrite (increase_move_iff Hssync (same_destination_incl Hssync not_color_bivalent_same_destination)).
+ exists id. split.
+ + now apply not_color_bivalent_moving_target.
+ + now rewrite moving_spec in Hmove. }
+(* We prove the large inequalities. *)
+setoid_rewrite round_simplify_bivalent.
+Typeclasses eauto := (bfs) 8.
+setoid_rewrite WithMultiplicityLight.obs_from_config_fst_spec; try exact (origin,witness) ; [].
+repeat rewrite config_list_spec. repeat rewrite List.map_map.
+induction names as [| id' l]; cbn [List.map].
+* cbn. now split.
+* destruct (activate da id') eqn:Hactive.
+ + (* As they are both active, id and id' target the same location. *)
+ assert (Heq' : get_location (round gatherR2 da config id) == get_location (round gatherR2 da config id')).
+ { apply not_color_bivalent_same_destination.
+ - eapply moving_active; eauto.
+ - now rewrite active_spec. }
+ cbn [countA_occ fst]. split.
+ - (* As id moves, the target cannot be its starting location. *)
+ intros pt Hpt.
+ rewrite <- active_spec in Hactive.
+ rewrite <- not_color_bivalent_target, <- Heq', not_color_bivalent_moving_target; trivial.
+ assert (Htest : exists H, find_other_loc (fst (!!! (config, config id)))
+ (get_location (config id)) =?= pt = right H).
+ { match goal with |- exists H, ?A = right H => destruct A as [Heq | ?]; eauto; [] end.
+ exfalso. apply Hpt. now rewrite <- Heq. }
+ destruct Htest as [? Htest]. changeR2. setoid_rewrite Htest. clear Htest.
+ destruct_match; now idtac + apply le_S; apply IHl.
+ - (* As id moves, the target is its ending location. *)
+ assert (Htest : exists H, find_max_black (!!! (config, config id')) (loc_g1 config) (loc_others config)
+ =?= pt' = left H).
+ { clear IHl.
+ destruct (find_max_black (!!! (config, config id')) (loc_g1 config) (loc_others config)
+ =?= pt') as [? | Hneq]; eauto; [].
+ exfalso. apply Hneq. clear Hneq.
+ rewrite <- active_spec in Hactive.
+ rewrite <- not_color_bivalent_target, <- Heq',
+ not_color_bivalent_moving_target, fold_obs_fst; auto. }
+ destruct Htest as [? Htest]. changeR2. rewrite Htest. clear Htest.
+ repeat destruct_match; now apply le_n_S + apply le_S; apply IHl.
+ + cbn [countA_occ]. split; intros; destruct_match; try apply le_n_S; apply IHl; auto.
+Qed.
+
+Lemma not_color_bivalent_next :
+ moving gatherR2 da config <> nil ->
+ exists pt, MajTower_at pt (round gatherR2 da config).
+Proof using Hssync Hbivalent Hcolor.
+intro Hmove.
+assert (Hevolve := not_color_bivalent_wither_and_grow).
+destruct (moving gatherR2 da config) as [| id l] eqn:Hmoving; try tauto; [].
+specialize (Hevolve id ltac:(now left)). generalize Hevolve.
+set (pt_id := get_location (config id)).
+set (pt'_id := find_other_loc (!! config) pt_id).
+Unshelve.
+assert (pt'_id =/= pt_id).
+{ unfold pt'_id. rewrite obs_fst. apply find_other_loc_diff.
+ - now rewrite bivalent_obs_spec.
+ - apply pos_in_config. }
+assert (In pt'_id (fst (!!! (config, config id)))).
+{ rewrite <- support_spec, find_other_loc_spec.
+ - now right; left.
+ - now rewrite bivalent_obs_spec.
+ - apply pos_in_config. }
+intros [Hwither Hgrow].
+assert (Hsame : (!! config)[pt_id] = (!! config)[pt'_id]).
+{ inversion Hbivalent as [Heven Hbiv]. destruct Hbiv as [Hle [pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]].
+ assert (Hcase : pt1 == pt_id /\ pt2 == pt'_id \/ pt1 == pt'_id /\ pt2 == pt_id).
+ { assert (In pt1 (fst (!!! (config, config id)))).
+ { unfold In. rewrite fold_obs_fst. changeR2. rewrite Hpt1.
+ apply Exp_prop.div2_not_R0. lia. }
+ assert (In pt2 (fst (!!! (config, config id)))).
+ { unfold In. rewrite fold_obs_fst. changeR2. rewrite Hpt2.
+ apply Exp_prop.div2_not_R0. lia. }
+ changeR2. destruct (pt1 =?= pt_id) as [Heq | Heq].
+ * left. split; trivial; [].
+ eapply (bivalent_same_location _ (pt3 := pt_id)); try eassumption; [|].
+ - apply (pos_in_config _ _ id).
+ - changeR2. fold pt_id. now rewrite <- Heq.
+ * right.
+ assert (pt2 == pt_id).
+ { symmetry in Hdiff, Heq. changeR2.
+ eapply bivalent_same_location; [.. | eassumption]; eauto; []; apply pos_in_config. }
+ split; trivial; [].
+ eapply (bivalent_same_location _ (pt3 := pt_id)); try eassumption; [].
+ apply pos_in_config. }
+ transitivity (Nat.div2 (nG+nB)).
+ + destruct Hcase as [[Heq _] | [_ Heq]]; rewrite <- Heq; assumption.
+ + symmetry. destruct Hcase as [[_ Heq] | [Heq _]]; rewrite <- Heq; assumption. }
+exists pt'_id.
+intros pt Hneq.
+destruct (pt =?= pt_id) as [Hcase | Hcase].
+* apply Nat.le_lt_trans with ((!! config)[pt_id]).
+ + rewrite Hcase. now apply Hwither.
+ + rewrite Hsame. apply Hgrow.
+* assert (Hout : (!! (round gatherR2 da config))[pt] = 0).
+ { assert (Hout : (!! config)[pt] = 0).
+ { generalize Hneq Hcase. apply (bivalent_other_locs Hbivalent); try eassumption; [].
+ apply pos_in_config. }
+ rewrite <- Nat.le_0_r, <- Hout.
+ now apply Hwither. }
+ rewrite Hout. unfold pt'_id, pt_id. rewrite <- not_color_bivalent_moving_target.
+ + apply pos_in_config.
+ + rewrite Hmoving. now left.
+Qed.
+
+End BivalentButNotColorBivalent.
+
+
+(** We express the behavior of the algorithm in the global (demon) frame of reference. *)
+Theorem round_simplify_non_bivalent : forall config, ~bivalent config ->
+ round gatherR2 da config
+ == fun id => if da.(activate) id
+ then let s := !! config in
+ match support (max s) with
+ | nil => config id (* only happen with no robots *)
+ | pt :: nil => (pt, snd (config id)) (* majority tower *)
+ | _ => if is_clean s then (target s, snd (config id)) else
+ if mem equiv_dec (get_location (config id)) (SECT s)
+ then config id else (target s, snd (config id))
+ end
+ else config id.
+Proof using Hssync.
+intros config Hbivalent. rewrite round_simplify.
+apply no_byz_eq. intro g.
+rewrite <- bivalent_obs_spec, not_true_iff_false in Hbivalent; auto; [].
+lazy zeta. now rewrite Hbivalent.
+Qed.
+
+
+Section NonBivalent.
+
+Variable config : configuration.
+Hypothesis Hbivalent : ~ bivalent config.
+
+Corollary round_simplify_Lights : forall id,
+ get_light (round gatherR2 da config id) == get_light (config id).
+Proof using Hssync Hbivalent.
+intro id.
+assert (Hrew := round_simplify_non_bivalent).
+eapply get_light_compat in Hrew; eauto; []. rewrite Hrew.
+now repeat (destruct_match; cbn).
+Qed.
+
+(** **** Specialization of [round_simplify] in the three main cases of the robogram **)
+
+(** If we have a majority tower, every robot goes there. **)
+Lemma round_simplify_Majority : forall pt,
+ MajTower_at pt config ->
+ round gatherR2 da config == fun id => if da.(activate) id then (pt, snd (config id)) else config id.
+Proof using Hssync.
+clear Hbivalent. intros pt Hmaj.
+assert (~bivalent config) by now eapply Majority_not_bivalent; eauto.
+rewrite round_simplify_non_bivalent; eauto using Majority_not_bivalent; [].
+intro id. apply no_info.
++ destruct (da.(activate) id); try reflexivity; [].
+ rewrite MajTower_at_equiv in Hmaj. cbn zeta. now rewrite Hmaj.
++ now repeat (destruct_match; cbn).
+Qed.
+
+(** If the configuration is clean, every robot goes to the target. *)
+Lemma round_simplify_clean :
+ no_Majority config ->
+ is_clean (!! config) = true ->
+ round gatherR2 da config == fun id => if da.(activate) id then (target (!! config), snd (config id)) else config id.
+Proof using Hssync Hbivalent.
+intros Hmaj Hclean. rewrite round_simplify_non_bivalent; trivial; [].
+intro id. destruct (da.(activate) id); try reflexivity; [].
+lazy zeta. rewrite Hclean.
+rewrite no_Majority_equiv in Hmaj. destruct Hmaj as [? [? [? Hmaj]]].
+now rewrite Hmaj.
+Qed.
+
+(** If the configuration is dirty, every robot /not on the SECT/ goes to the target. *)
+Lemma round_simplify_dirty :
+ no_Majority config ->
+ is_clean (!! config) = false ->
+ round gatherR2 da config == fun id => if da.(activate) id
+ then if mem equiv_dec (get_location (config id)) (SECT (!! config))
+ then config id else (target (!! config), snd (config id))
+ else config id.
+Proof using Hssync Hbivalent.
+intros Hmaj Hclean. rewrite round_simplify_non_bivalent; trivial; [].
+intro id. destruct (da.(activate) id); try reflexivity; [].
+lazy zeta. rewrite Hclean.
+rewrite no_Majority_equiv in Hmaj. destruct Hmaj as [? [? [? Hmaj]]].
+now rewrite Hmaj.
+Qed.
+
+(* In the case where one majority tower exists, target is not used and does not compute the real target.
+ Hence the no_Majority hypothesis. *)
+Theorem destination_is_target :
+ no_Majority config ->
+ forall id, List.In id (moving gatherR2 da config) ->
+ get_location (round gatherR2 da config id) = target (!! config).
+Proof using Hssync Hbivalent.
+intros Hmaj id Hmove. rewrite (round_simplify_non_bivalent Hbivalent id).
+destruct (da.(activate) id) eqn:Hactive.
+* rewrite moving_spec, (round_simplify_non_bivalent Hbivalent id), Hactive in Hmove.
+ lazy zeta in *. unfold no_Majority in Hmaj. rewrite size_spec in Hmaj.
+ destruct (support (max (!! config))) as [| ? [| ? ?]]; simpl in Hmaj; try lia; [].
+ destruct (is_clean (!! config)) eqn:Hclean.
+ + reflexivity.
+ + destruct (mem equiv_dec (get_location (config id)) (SECT (!! config))) eqn:Hmem.
+ - now elim Hmove.
+ - reflexivity.
+* apply moving_active in Hmove; trivial; []. rewrite active_spec in Hmove. congruence.
+Qed.
+
+Corollary non_bivalent_same_destination : same_destination_if_moving gatherR2 da config.
+Proof using Hssync Hbivalent.
+intros id1 id2 Hmove1 Hmove2.
+change (@equiv _ (@robot_choice_Setoid _ _)) with (@equiv _ state_Setoid).
+destruct (le_lt_dec 2 (length (support (max (!! config))))) as [Hle |Hlt].
++ assert (no_Majority config). { unfold no_Majority. now rewrite size_spec. }
+ now repeat rewrite destination_is_target.
++ rewrite moving_spec in Hmove1, Hmove2.
+ rewrite (round_simplify_non_bivalent Hbivalent id1) in Hmove1 |- *.
+ rewrite (round_simplify_non_bivalent Hbivalent id2) in Hmove2 |- *.
+ destruct (da.(activate) id1), (da.(activate) id2); try (now elim Hmove1 + elim Hmove2); [].
+ lazy zeta in *.
+ destruct (support (max (!! config))) as [| ? [| ? ?]] eqn:Hsupp.
+ - now elim Hmove1.
+ - reflexivity.
+ - simpl in Hlt. lia.
+Qed.
+
+(** *** Generic results about the [SEC] after one round **)
+
+Lemma incl_next :
+ inclA equiv (support (!! (round gatherR2 da config)))
+ ((target (!! config)) :: (support (!! config))).
+Proof using Hssync Hbivalent.
+intros x Hin.
+rewrite support_elements in Hin.
+apply elements_spec in Hin.
+destruct Hin as [_ Hin].
+destruct (x =?= target (!! config)) as [Heq | Heq]; try (now left); [].
+right.
+rewrite support_elements.
+apply elements_spec.
+split; trivial; [].
+destruct (le_lt_dec ((!! config)[x]) 0); trivial; [].
+exfalso.
+destruct (@increase_move gatherR2 da config x) as [r_moving [Hdest_rmoving Hrmoving]].
+* simpl in *. now apply Nat.le_lt_trans with 0.
+* destruct (le_lt_dec 2 (length (support (max (!! config))))) as [Hle | Hlt].
+ + rewrite destination_is_target in Hdest_rmoving.
+ - now elim Heq.
+ - unfold no_Majority. now rewrite size_spec.
+ - rewrite moving_spec. intro Habs. apply Hrmoving. now rewrite Habs.
+ + assert ((support (max (!! config))) = [x]).
+ { destruct (support (max (!! config))) as [| pt [| ? ?]] eqn:Heq'; cbv in Hlt; try lia.
+ + now destruct (support_max_non_nil config).
+ + get_case config.
+ rewrite (@round_simplify_Majority pt Hcase r_moving) in Hdest_rmoving.
+ destruct (da.(activate) r_moving).
+ - now rewrite <- Hdest_rmoving.
+ - assert (H := pos_in_config config (origin, witness) r_moving).
+ rewrite Hdest_rmoving in H. unfold In in H. lia. }
+ assert (Hperm : PermutationA equiv (support (max (!! config))) ([x])) by now rewrite H.
+ rewrite support_1 in Hperm.
+ destruct Hperm as [_ Hperm].
+ destruct (max_case (!! config) x); changeR2; lia.
+Qed.
+
+Lemma incl_clean_next :
+ is_clean (!! config) = true ->
+ inclA equiv (support (!! (round gatherR2 da config)))
+ (target (!! config) :: on_SEC (support (!! config))).
+Proof using Hssync Hbivalent.
+intro Hclean.
+transitivity ((target (!! config)) :: (support (!! config))).
+- now apply incl_next.
+- rewrite inclA_Leibniz.
+ apply incl_cons.
+ + now left.
+ + now rewrite <- inclA_Leibniz, <- is_clean_spec.
+Qed.
+
+Lemma next_SEC_enclosed :
+ no_Majority config ->
+ enclosing_circle (SEC (support (!! config))) (support (!! (round gatherR2 da config))).
+Proof using Hssync Hbivalent.
+intros Hmaj pt Hin.
+rewrite <- InA_Leibniz in Hin. change eq with (@equiv location _) in Hin.
+rewrite support_spec in Hin. unfold In in Hin. changeR2.
+setoid_rewrite WithMultiplicityLight.obs_from_config_fst_spec in Hin.
+2:exact (origin,witness).
+rewrite config_list_spec in Hin.
+induction names as [| id l]; try (simpl in *; lia); [].
+cbn -[get_location equiv_dec] in Hin.
+revert Hin. destruct_match; intro Hin; auto; [].
+match goal with H : _ == _ |- _ => rewrite <- H end.
+rewrite (round_simplify_non_bivalent Hbivalent id); trivial; [].
+destruct (activate (proj_sim_da da) id).
+* assert (Hmax := Hmaj). rewrite no_Majority_equiv in Hmax. destruct Hmax as [pt1 [pt2 [lmax Hmax]]].
+ cbn zeta. rewrite Hmax.
+ destruct (is_clean (!! config)).
+ + now apply target_inside_SEC.
+ + destruct (mem equiv_dec (get_location (config id)) (SECT (!! config))) eqn:Hmem.
+ - apply SEC_spec1. rewrite <- InA_Leibniz.
+ change eq with (@equiv location _). rewrite support_spec.
+ change fst with get_location. apply pos_in_config.
+ - now apply target_inside_SEC.
+* apply SEC_spec1. rewrite <- InA_Leibniz.
+ change eq with (@equiv location _). rewrite support_spec.
+ change fst with get_location. apply pos_in_config.
+Qed.
+
+(** *** Lemmas about the dirty cases **)
+
+(* To prove dirty_next_on_SEC_same below, we first prove that any point on the SEC does not move. *)
+Lemma dirty_next_still_on_SEC : forall id,
+ no_Majority config ->
+ is_clean (!! config) = false ->
+ on_circle (SEC (support (!! config))) (get_location (config id)) = true ->
+ round gatherR2 da config id == config id.
+Proof using Hssync Hbivalent.
+intros id Hmaj Hclean Hcircle.
+rewrite (round_simplify_dirty Hmaj Hclean id).
+destruct (da.(activate) id); try reflexivity; [].
+destruct (mem equiv_dec (get_location (config id)) (SECT (!! config))) eqn:Hmem; try reflexivity; [].
+rewrite mem_false_iff in Hmem. elim Hmem.
+unfold SECT. right. unfold on_SEC. rewrite filter_InA; autoclass; [].
+split; trivial; [].
+rewrite support_spec. apply pos_in_config.
+Qed.
+
+Lemma dirty_next_SEC_same :
+ no_Majority config ->
+ is_clean (!! config) = false ->
+ SEC (support (!! (round gatherR2 da config))) = SEC (support (!! config)).
+Proof using Hssync Hbivalent.
+intros Hmaj Hclean.
+assert (HonSEC : forall id, List.In (get_location (config id)) (on_SEC (support (!! config))) ->
+ round gatherR2 da config id == config id).
+{ intros id Hid. rewrite (round_simplify_dirty Hmaj Hclean id).
+ destruct (da.(activate) id); try reflexivity; [].
+ assert (Heq : mem equiv_dec (get_location (config id)) (SECT (!! config)) = true).
+ { rewrite mem_true_iff. right. now apply InA_Leibniz. }
+ now rewrite Heq. }
+apply enclosing_same_on_SEC_is_same_SEC.
++ now apply next_SEC_enclosed.
++ intros pt Hin.
+ assert (Hid : exists id, get_location (config id) == pt).
+ { unfold on_SEC in Hin. setoid_rewrite List.filter_In in Hin. destruct Hin as [Hin Hsec].
+ rewrite <- InA_Leibniz in Hin. change eq with (@equiv location _) in Hin.
+ now rewrite support_spec, (obs_from_config_In config) in Hin. }
+ destruct Hid as [id Hid]. rewrite <- Hid in *.
+ rewrite <- HonSEC; trivial. rewrite <- InA_Leibniz. change eq with (@equiv location _).
+ rewrite support_spec. apply pos_in_config.
+Qed.
+
+Lemma dirty_next_on_SEC_same :
+ no_Majority config ->
+ is_clean (!! config) = false ->
+ PermutationA equiv (on_SEC (support (!! (round gatherR2 da config)))) (on_SEC (support (!! config))).
+Proof using Hssync Hbivalent.
+intros Hmaj Hclean. apply (NoDupA_equivlistA_PermutationA _).
+* unfold on_SEC. apply (NoDupA_filter_compat _), support_NoDupA.
+* unfold on_SEC. apply (NoDupA_filter_compat _), support_NoDupA.
+* intro pt.
+ unfold on_SEC in *. rewrite dirty_next_SEC_same; trivial; [].
+ do 2 (rewrite filter_InA; autoclass); [].
+ split; intros [Hin Hcircle]; split; trivial; [|].
+ + rewrite support_spec, (obs_from_config_In (round gatherR2 da config)) in Hin.
+ destruct Hin as [id Hid].
+ rewrite (round_simplify_dirty Hmaj Hclean id) in Hid.
+ destruct (activate da id).
+ - destruct (mem equiv_dec (get_location (config id)) (SECT (!! config))) eqn:Hmem.
+ -- rewrite <- Hid, support_spec. apply pos_in_config.
+ -- rewrite <- Hid in *. clear Hid pt.
+ now apply target_on_SEC_already_occupied.
+ - rewrite <- Hid, support_spec. apply pos_in_config.
+ + rewrite support_spec, (obs_from_config_In config) in Hin. destruct Hin as [id Hid].
+ rewrite <- Hid in *.
+ assert (Heq : round gatherR2 da config id == config id) by now apply dirty_next_still_on_SEC.
+ Typeclasses eauto := (dfs) 7.
+ rewrite <- Heq, support_spec. apply pos_in_config.
+Qed.
+
+(** *** Lemma about the majority case **)
+
+(* Next lemmas taken from the gathering algo in R. *)
+(** When there is a majority tower, it grows and all other towers wither. **)
+Theorem Majority_grow : forall pt, MajTower_at pt config ->
+ (!! config)[pt] <= (!! (round gatherR2 da config))[pt].
+Proof using Hssync Hbivalent.
+intros pt Hmaj.
+rewrite (round_simplify_Majority Hmaj).
+Typeclasses eauto := (bfs) 7.
+setoid_rewrite WithMultiplicityLight.obs_from_config_fst_spec; try exact (origin,witness) ; [].
+do 2 rewrite config_list_spec.
+induction names as [| id l]; cbn -[get_location].
++ reflexivity.
++ changeR2. destruct (activate da id); cbn -[get_location].
+ - changeR2. repeat destruct_match;
+ solve [ now apply le_n_S + apply le_S; apply IHl
+ | simpl in *; unfold Datatypes.id in *; congruence ].
+ - destruct_match; try apply le_n_S; apply IHl.
+Qed.
+
+(* This proof follows the exact same structure. *)
+Theorem Majority_wither : forall pt, MajTower_at pt config ->
+ forall pt', pt <> pt' -> (!! (round gatherR2 da config))[pt'] <= (!! config)[pt'].
+Proof using Hssync Hbivalent.
+intros pt Hmaj pt' Hdiff.
+rewrite (round_simplify_Majority Hmaj).
+setoid_rewrite WithMultiplicityLight.obs_from_config_fst_spec; try exact (origin,witness); [].
+do 2 rewrite config_list_spec.
+induction names as [| id l]; simpl.
++ reflexivity.
++ changeR2. destruct (activate (proj_sim_da da) id); simpl.
+ - destruct_match; try contradiction; []. R2dec_full; try apply le_S; apply IHl.
+ - R2dec_full; try apply le_n_S; apply IHl.
+Qed.
+
+(** Whenever there is a majority tower, it remains forever so. *)
+Theorem MajTower_at_forever : forall pt,
+ MajTower_at pt config -> MajTower_at pt (round gatherR2 da config).
+Proof using Hssync Hbivalent.
+intros pt Hmaj x Hx. assert (Hs := Hmaj x Hx).
+apply Nat.le_lt_trans with ((!! config)[x]); try eapply Nat.lt_le_trans; try eassumption; [|].
+- eapply Majority_wither; eauto.
+- eapply Majority_grow; eauto.
+Qed.
+
+Lemma solve_measure_clean :
+ no_Majority config ->
+ moving gatherR2 da config <> nil ->
+ target (!! (round gatherR2 da config)) = target (!! config) ->
+ measure_clean (!! (round gatherR2 da config)) < measure_clean (!! config).
+Proof using Hssync Hbivalent.
+intros Hmaj Hmoving Htarget.
+unfold measure_clean. rewrite Htarget.
+assert (Hle := multiplicity_le_nG (target (!! config)) (round gatherR2 da config)).
+cut ((!! config)[target (!! config)] < (!! (round gatherR2 da config))[target (!! config)]).
++ lia.
++ rewrite (increase_move_iff Hssync non_bivalent_same_destination).
+ apply not_nil_In in Hmoving. destruct Hmoving as [gmove Hmove].
+ exists gmove. split.
+ - now apply destination_is_target.
+ - rewrite (moving_spec gatherR2) in Hmove.
+ intro Habs. apply Hmove, no_info; trivial; [].
+ now apply round_simplify_Lights.
+Qed.
+
+Opaque obs_from_config.
+
+Lemma solve_measure_dirty :
+ moving gatherR2 da config <> nil ->
+ no_Majority config ->
+ is_clean (!! config) = false ->
+ no_Majority (round gatherR2 da config) ->
+ is_clean (!! (round gatherR2 da config)) = false ->
+ measure_dirty (!! (round gatherR2 da config)) < measure_dirty (!! config).
+Proof using Hssync Hbivalent.
+intros Hmoving Hmaj Hclean Hmaj' Hclean'.
+assert (HsameSEC := dirty_next_on_SEC_same Hmaj Hclean).
+assert (Htarget := same_on_SEC_same_target _ _ HsameSEC).
+assert (HsameSECT := same_on_SEC_same_SECT _ _ HsameSEC).
+unfold measure_dirty.
+assert (HlenG : SECT_cardinal (!! (round gatherR2 da config)) <= nG) by apply SECT_cardinal_le_nG.
+cut (SECT_cardinal (!! config) < SECT_cardinal (!! (round gatherR2 da config))); try lia; [].
+assert (Hlt : (!! config)[target (!! config)] < (!! (round gatherR2 da config))[target (!! config)]).
+{ rewrite (increase_move_iff Hssync non_bivalent_same_destination).
+ apply not_nil_In in Hmoving. destruct Hmoving as [gmove Hmove].
+ exists gmove. split.
+ - now apply destination_is_target.
+ - rewrite (moving_spec gatherR2) in Hmove.
+ intro Habs. apply Hmove. apply no_info; trivial; [].
+ now apply round_simplify_Lights. }
+unfold SECT_cardinal.
+pose (f s x := if InA_dec equiv_dec x (SECT s) then true else false).
+assert (Hext : forall x, f (!! (round gatherR2 da config)) x = f (!! config) x).
+{ intro pt. unfold f.
+ destruct (InA_dec equiv_dec pt (SECT (!! config))) as [Htest1 | Htest1],
+ (InA_dec equiv_dec pt (SECT (!! (round gatherR2 da config)))) as [Htest2 | Htest2]; trivial.
+ - elim Htest2. now rewrite HsameSECT.
+ - elim Htest1. now rewrite <- HsameSECT. }
+unfold f in Hext.
+rewrite (filter_extensionality_compat _ _ Hext). clear Hext.
+pose (f_target := fun x => if equiv_dec x (target (!! config)) then true else false).
+pose (f_out_target := fun x => if InA_dec equiv_dec x (SECT (!! config)) then negb (f_target x) else false).
+assert (Hext : forall x, f (!! config) x = f_target x || f_out_target x).
+{ intro pt. unfold f, f_out_target, f_target. simpl. changeR2. repeat destruct_match; reflexivity. }
+unfold f in Hext. setoid_rewrite (filter_extensionality_compat _ _ Hext). clear Hext f.
+assert (Hdisjoint : forall m x, In x m -> f_target x && f_out_target x = false).
+{ intros m x Hin.
+ destruct (f_target x) eqn:Heq1, (f_out_target x) eqn:Heq2; trivial.
+ exfalso. unfold f_out_target, f_target in *. clear f_target f_out_target.
+ revert Heq1 Heq2. repeat destruct_match; discriminate. }
+setoid_rewrite filter_disjoint_or_union; try (try (intros ? ? Heq; rewrite Heq); autoclass); [].
+do 2 rewrite cardinal_union.
+unfold f_target. setoid_rewrite cardinal_filter_is_multiplicity.
+assert (Heq : equiv (filter f_out_target (!! (round gatherR2 da config)))
+ (filter f_out_target (!! config))).
+{ intro pt. repeat rewrite filter_spec; try (now intros ? ? Heq; rewrite Heq); [].
+ destruct (f_out_target pt) eqn:Htest; trivial.
+ rewrite round_simplify_dirty; trivial. symmetry.
+ (* by induction on the list of robot names *)
+ (unshelve setoid_rewrite obs_fst); try exact (origin,witness).
+ setoid_rewrite WithMultiplicityLight.obs_from_config_fst_spec; [].
+ do 2 rewrite config_list_spec.
+ induction names as [| id l].
+ * reflexivity.
+ * cbn -[witness equiv_dec]. R2dec_full; changeR2.
+ + rewrite Heq. destruct (activate da id) eqn:Hactive.
+ - assert (Hmem : mem equiv_dec pt (SECT (!! config)) = true).
+ { rewrite mem_true_iff. unfold f_out_target in Htest.
+ destruct (InA_dec equiv_dec pt (SECT (!! config))) as [Hin | Hin]; trivial; discriminate. }
+ change (@eq (@location Loc)) with (@equiv (@location Loc) (@location_Setoid Loc)).
+ unfold Datatypes.id. changeR2. rewrite Hmem.
+ destruct_match; try contradiction; []. f_equal. apply IHl.
+ - destruct_match; try contradiction; []. f_equal. apply IHl.
+ + destruct (activate da id) eqn:Hactive.
+ - change (@eq R2) with (@equiv location _).
+ destruct_match_eq Hmem.
+ ++ destruct_match; contradiction || apply IHl.
+ ++ destruct_match.
+ -- exfalso.
+ unfold f_out_target in Htest.
+ destruct (InA_dec equiv_dec pt (SECT (!! config))); try discriminate; [].
+ rewrite negb_true_iff in Htest.
+ unfold f_target in Htest.
+ revert Htest. destruct_match; try discriminate; auto.
+ -- apply IHl.
+ - destruct_match; (now elim Hneq) || apply IHl. }
+rewrite Heq.
+lia.
+Qed.
+
+(** *** An bivalent configuration cannot appear **)
+
+(* For [never_bivalent] *)
+Lemma towers_elements_3 : forall config pt1 pt2,
+ (size (!! config) >= 3)%nat ->
+ In pt1 (!! config) -> In pt2 (!! config) -> pt1 <> pt2 ->
+ exists pt3, pt1 <> pt3 /\ pt2 <> pt3 /\ In pt3 (!! config).
+Proof using size_G.
+clear config Hbivalent Hssync.
+intros config pt1 pt2 Hlen Hpt1 Hpt2 Hdiff12.
+rewrite <- support_spec in Hpt1, Hpt2. rewrite size_spec in Hlen.
+apply (PermutationA_split _) in Hpt1. destruct Hpt1 as [supp1 Hperm].
+rewrite Hperm in Hpt2. inversion_clear Hpt2; try (now elim Hdiff12); []. rename H into Hpt2.
+apply (PermutationA_split _) in Hpt2. destruct Hpt2 as [supp2 Hperm2].
+rewrite Hperm2 in Hperm. rewrite Hperm in Hlen.
+destruct supp2 as [| pt3 supp]; try (now simpl in Hlen; lia); [].
+exists pt3.
+rewrite <- support_spec. assert (Hnodup := support_NoDupA (!! config)).
+rewrite Hperm in *. inversion_clear Hnodup. inversion_clear H0. repeat split.
+- intro Habs. subst. apply H. now right; left.
+- intro Habs. subst. apply H1. now left.
+- now right; right; left.
+Qed.
+
+(* Taken from the gathering in R.
+ Any non-bivalent config without a majority tower contains at least three towers.
+ All robots move toward the same place (same_destination), wlog pt1.
+ |\before(pt2)| >= |\after(pt2)| = nG / 2
+ As there are nG robots, nG/2 at p2, we must spread nG/2 into at least two locations
+ thus each of these towers has less than nG/2 and pt2 was a majority tower. *)
+
+Theorem never_bivalent : ~bivalent (round gatherR2 da config).
+Proof using Hssync Hbivalent.
+(* Three cases for the robogram *)
+destruct (support (max (!! config))) as [| pt [| pt' l']] eqn:Hmaj.
+- assert (round gatherR2 da config == config).
+ { rewrite round_simplify_non_bivalent; cbv zeta; trivial; []; try rewrite Hmaj.
+ intro id. now destruct (da.(activate) id). }
+ now rewrite H.
+ (* There is a majority tower *)
+- apply Majority_not_bivalent with pt.
+ rewrite <- MajTower_at_equiv in *.
+ apply (@MajTower_at_forever pt) in Hmaj.
+ assumption.
+- get_case config.
+ clear pt pt' l' Hmaj. rename Hmaj0 into Hmaj.
+ (* A robot has moved otherwise we have the same configuration before and it is bivalent. *)
+ assert (Hnil := no_changing_same_config gatherR2 da config).
+ destruct (changing gatherR2 da config) as [| rmove l] eqn:Heq.
+ * now rewrite Hnil.
+ * intro Habs.
+ clear Hnil.
+ assert (Hmove : List.In rmove (changing gatherR2 da config)). { rewrite Heq. now left. }
+ rewrite changing_spec in Hmove.
+ (* the robot moves to one of the two locations in round robogram config *)
+ assert (Hbivalent' := Habs). destruct Habs as [HnG [HsizeG[pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
+ cbn -[nG] in HsizeG. cbn -[nG] in HnG. rewrite Nat.add_0_r in HnG.
+ assert (Hpt : exists pt pt', (pt = pt1 /\ pt' = pt2 \/ pt = pt2 /\ pt' = pt1)
+ /\ get_location (round gatherR2 da config rmove) == pt).
+ { assert (Hperm : Permutation (support (!! (round gatherR2 da config))) (pt1 :: pt2 :: nil)).
+ { symmetry. apply NoDup_Permutation_bis.
+ + repeat constructor.
+ - intro Habs. inversion Habs. now elim Hdiff. now inversion H.
+ - intro Habs. now inversion Habs.
+ + now setoid_rewrite <- (bivalent_size (origin, witness) Hbivalent').
+ + intros pt Hpt. inversion_clear Hpt.
+ - subst. rewrite <- InA_Leibniz. change eq with (@equiv location _). rewrite support_spec.
+ unfold In. setoid_rewrite Hpt1. apply Exp_prop.div2_not_R0. lia.
+ - inversion H; (now inversion H0) || subst. rewrite <- InA_Leibniz. change eq with (@equiv location _).
+ rewrite support_spec. unfold In. setoid_rewrite Hpt2. apply Exp_prop.div2_not_R0. lia. }
+ assert (Hpt : List.In (get_location (round gatherR2 da config rmove)) (pt1 :: pt2 :: nil)).
+ { rewrite <- Hperm, <- InA_Leibniz. change eq with (@equiv location _).
+ rewrite support_spec. apply pos_in_config. }
+ inversion_clear Hpt; try (now exists pt1, pt2; eauto); [].
+ inversion_clear H; now exists pt2, pt1; eauto. }
+ destruct Hpt as [pt [pt' [Hpt Hrmove_pt]]].
+ assert (Hdiff2 : pt <> pt').
+ { decompose [and or] Hpt; congruence. }
+ assert (Hdest : forall g, List.In g (moving gatherR2 da config) ->
+ get_location (round gatherR2 da config g) == pt).
+ { intros id Hid. rewrite <- Hrmove_pt.
+ apply non_bivalent_same_destination; auto; [].
+ rewrite <- changing_eq_moving, Heq.
+ - now left.
+ - auto using color_bivalent_bivalent. }
+ assert ((Nat.div2 nG) <= (!! config)[pt']).
+ { transitivity ((!! (round gatherR2 da config))[pt']).
+ - decompose [and or] Hpt; clear Hpt; subst.
+ + setoid_rewrite Hpt2. simpl.
+ apply Nat.eq_le_incl.
+ f_equal.
+ lia.
+ + setoid_rewrite Hpt1. simpl.
+ apply Nat.eq_le_incl.
+ f_equal.
+ lia.
+ - generalize (increase_move_iff Hssync non_bivalent_same_destination pt').
+ intro H1. apply Nat.nlt_ge.
+ rewrite H1. intros [id [Hid1 Hid2]].
+ apply Hdiff2.
+ rewrite <- Hid1.
+ symmetry.
+ apply Hdest. rewrite moving_spec. intro Habs. apply Hid2. now rewrite Habs. }
+ assert (Hlt : forall p, p <> pt' -> (!! config)[p] < Nat.div2 nG).
+ { assert (Hpt'_in : In pt' (!! config)).
+ { unfold In. eapply Nat.lt_le_trans; try eassumption. apply Exp_prop.div2_not_R0. lia. }
+ assert (Hle := not_bivalent_no_majority_size Hmaj Hbivalent).
+ intros p Hp. apply Nat.nle_gt. intro Habs. apply (Nat.lt_irrefl nG).
+ destruct (@towers_elements_3 config pt' p Hle Hpt'_in) as [pt3' [Hdiff13 [Hdiff23 Hpt3_in]]]; trivial.
+ + apply Nat.lt_le_trans with (Nat.div2 nG); trivial; []. apply Exp_prop.div2_not_R0. lia.
+ + auto.
+ + rewrite <- Nat.add_0_r, <- nB_eq_0.
+ eapply Nat.lt_le_trans.
+ all: swap 1 2.
+ * apply (sum3_le_total config (origin,witness) Hp Hdiff13 Hdiff23).
+ * unfold In in Hpt3_in.
+ rewrite <- obs_fst, (Nat.Even_double nG); auto; []. changeR2. unfold Nat.double. lia. }
+ assert (Hmaj' : MajTower_at pt' config).
+ { intros x Hx. apply Nat.lt_le_trans with (Nat.div2 nG); trivial. now apply Hlt. }
+ apply MajTower_at_equiv in Hmaj'.
+ red in Hmaj.
+ rewrite size_spec in Hmaj.
+ rewrite Hmaj' in Hmaj.
+ simpl in Hmaj.
+ lia.
+Qed.
+
+(** *** Lemmas about the diameter case **)
+
+Lemma diameter_clean_support : forall config ptx pty,
+ ~ bivalent config ->
+ no_Majority config ->
+ is_clean (!! config) = true ->
+ on_SEC (support (!! config)) = [ptx; pty] ->
+ PermutationA equiv (support (!! config)) (middle ptx pty :: [ptx; pty]).
+Proof using size_G.
+clear config Hbivalent Hssync.
+intros config ptx pty Hbivalent hmax Hclean HonSEC.
+assert (Htarget : target (!! config) = middle ptx pty) by (apply (diameter_target); auto).
+apply (NoDupA_inclA_length_PermutationA _).
+- apply support_NoDupA.
+- intros x Hin.
+ rewrite is_clean_spec in Hclean. apply Hclean in Hin.
+ now rewrite <- Htarget, <- HonSEC.
+- rewrite <- size_spec. now apply not_bivalent_no_majority_size.
+Qed.
+
+Lemma diameter_round_same : forall ptx pty,
+ no_Majority (round gatherR2 da config) ->
+ PermutationA equiv (support (!! config)) (middle ptx pty :: ptx :: pty :: nil) ->
+ PermutationA equiv (support (!! (round gatherR2 da config)))
+ (middle ptx pty :: [ptx; pty]).
+Proof using Hssync Hbivalent.
+intros ptx pty Hmaj Hperm.
+assert (Htarget : target (!! config) = middle ptx pty).
+{ assert (HonSEC : PermutationA equiv (on_SEC (support (!! config))) (ptx :: pty :: nil)).
+ { rewrite Hperm. rewrite on_SEC_middle_diameter, on_SEC_dueton; try reflexivity; [].
+ assert (Hnodup : NoDupA equiv (support (!! config))) by apply support_NoDupA.
+ rewrite Hperm in Hnodup. inversion_clear Hnodup. inversion_clear H0. intuition. }
+ destruct (on_SEC (support (!! config))) as [| ? [| ? [| ? ?]]] eqn:Hsec;
+ try (apply PermutationA_length in HonSEC; discriminate); [].
+ apply (PermutationA_2 _) in HonSEC. destruct HonSEC as [[Heq1 Heq2] | [Heq1 Heq2]]; rewrite <- Heq1, <- Heq2.
+ - now apply diameter_target.
+ - rewrite middle_comm. now apply diameter_target. }
+apply (NoDupA_inclA_length_PermutationA _).
+- apply support_NoDupA.
+- assert (Hincl := incl_next).
+ rewrite Hperm in Hincl. fold St in *.
+ rewrite Htarget in Hincl.
+ apply (inclA_cons_InA _) in Hincl; auto.
+- simpl length at 1.
+ rewrite <- size_spec.
+ apply not_bivalent_no_majority_size; trivial.
+ apply never_bivalent.
+Qed.
+
+
+Lemma diameter_next_target_same :
+ clean_diameter_case config ->
+ no_Majority (round gatherR2 da config) ->
+ target (!! (round gatherR2 da config)) = target (!! config).
+Proof using Hssync Hbivalent.
+intros Hcleandiam Hmaj'.
+destruct Hcleandiam as [[Hmaj [pt1 [pt2 Htwocol]]] Hclean].
+apply PermutationA_length in Htwocol.
+unfold target.
+destruct (on_SEC (support (!! config))) as [| ptx [| pty [| ptz [| ptt ?]]]] eqn:Hsec; try discriminate; [].
+assert (Hincl := incl_next).
+assert (Htarget : target (!!config) = middle ptx pty) by (apply diameter_target; auto).
+assert (Hperm := @diameter_clean_support config ptx pty Hbivalent Hmaj Hclean Hsec).
+assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
+ (middle ptx pty :: [ptx; pty])).
+{ apply (NoDupA_inclA_length_PermutationA _).
+ - apply support_NoDupA.
+ - apply (inclA_cons_InA _) with (middle ptx pty).
+ + intuition.
+ + rewrite <- Hperm, <- Htarget. apply Hincl.
+ - simpl length at 1. rewrite <- size_spec. now apply not_bivalent_no_majority_size, never_bivalent. }
+assert (HpermSEC' : PermutationA equiv (on_SEC (support (!! (round gatherR2 da config))))
+ (ptx :: pty :: nil)).
+{ rewrite Hperm'. rewrite on_SEC_middle_diameter.
+ - now rewrite on_SEC_dueton.
+ - assert (Hnodup : NoDupA equiv (middle ptx pty :: [ptx; pty])).
+ { rewrite <- Hperm. apply support_NoDupA. }
+ inversion_clear Hnodup. inversion_clear H0. intuition. }
+assert (Hlen : length (on_SEC (support (!! (round gatherR2 da config)))) = 2) by now rewrite HpermSEC'.
+destruct (on_SEC (support (!! (round gatherR2 da config))))
+ as [| ptx' [| pty' [| ? ?]]] eqn:Hsec'; cbn in Hlen; try discriminate.
+do 2 rewrite SEC_on_SEC, ?Hsec, ?Hsec', SEC_dueton. simpl.
+apply (PermutationA_2 _) in HpermSEC'.
+destruct HpermSEC' as [[Heq1 Heq2] | [Heq1 Heq2]].
+Typeclasses eauto := (dfs).
+- changeR2. rewrite Heq1. rewrite Heq2. trivial.
+- changeR2. rewrite Heq1. rewrite Heq2. apply middle_comm.
+Qed.
+
+Lemma clean_diameter_next_maj_or_diameter : forall ptx pty,
+ no_Majority config ->
+ is_clean (!! config) = true ->
+ on_SEC (support (!! config)) = [ptx; pty] ->
+ (exists pt, MajTower_at pt (round gatherR2 da config))
+ \/ no_Majority (round gatherR2 da config)
+ /\ PermutationA equiv (on_SEC (support (!! (round gatherR2 da config)))) (ptx :: pty :: nil).
+Proof using Hssync Hbivalent.
+intros ptx pty Hmaj Hclean Hsec.
+assert (Hperm := diameter_clean_support Hbivalent Hmaj Hclean Hsec).
+destruct (support (max (!! (round gatherR2 da config)))) as [| pt [| ? ?]] eqn:Hmax'.
+- rewrite support_nil, max_is_empty, <- support_nil in Hmax'.
+ now elim (support_non_nil _ Hmax').
+- left. exists pt.
+ rewrite MajTower_at_equiv. now rewrite Hmax'.
+- right.
+ assert (Hmaj' : no_Majority (round gatherR2 da config)).
+ { eapply make_no_Majority. rewrite Hmax'. reflexivity. }
+ split; trivial; [].
+ assert (Htarget := diameter_target config Hsec).
+ assert (Hperm' := diameter_round_same Hmaj' Hperm).
+ rewrite Hperm'.
+ rewrite on_SEC_middle_diameter.
+ + now rewrite on_SEC_dueton.
+ + assert (Hnodup : NoDupA equiv (on_SEC (support (!! config)))).
+ { apply on_SEC_NoDupA, support_NoDupA. }
+ rewrite Hsec in Hnodup. inversion_clear Hnodup. intuition.
+Qed.
+
+(** *** Lemmas about the triangle cases **)
+
+
+(** **** Lemmas about the equilateral triangle case **)
+
+Lemma SEC_3_to_2: forall config ptx pty ptz bary pt ptdiam,
+ InA equiv pt ([ptx; pty; ptz]) ->
+ InA equiv ptdiam ([ptx; pty; ptz]) ->
+ pt<> ptdiam ->
+ PermutationA equiv (on_SEC (support (!! config))) ([ptx; pty; ptz]) ->
+ PermutationA equiv (on_SEC (support (!! (round gatherR2 da config)))) ([bary; ptdiam]) ->
+ classify_triangle ptx pty ptz = Equilateral ->
+ bary == isobarycenter ([ptx; pty; ptz]) ->
+ ~ InA equiv pt (support (!! (round gatherR2 da config))).
+Proof using .
+clear config Hbivalent Hssync.
+intros config ptx pty ptz bary pt ptdiam hIn_pt hIn_ptdiam hneq_pt_ptdiam Hsec Hsec' Htriangle heq_bary.
+intro abs.
+assert (h_bary:=@same_dist_vertex_notin_sub_circle ptdiam pt bary).
+
+assert (h_radius_pt : radius (SEC ([ptx; pty; ptz])) = dist bary pt).
+{ rewrite InA_Leibniz in hIn_pt.
+ simpl in hIn_pt.
+ decompose [or False] hIn_pt;subst.
+ - generalize (@equilateral_SEC _ _ _ Htriangle).
+ intro h_sec_xyz.
+ rewrite <- heq_bary in h_sec_xyz.
+ rewrite h_sec_xyz.
+ simpl.
+ reflexivity.
+ - assert (hperm:PermutationA equiv ([ptx; pt; ptz]) ([pt; ptx; ptz])) by permut_3_4.
+ rewrite ?hperm in *.
+ generalize hperm; intro hperm'.
+ apply PermutationA_Leibniz in hperm'.
+ rewrite (classify_triangle_compat hperm') in Htriangle.
+ generalize (@equilateral_SEC _ _ _ Htriangle).
+ intro h_sec_xyz.
+ rewrite <- heq_bary in h_sec_xyz.
+ rewrite h_sec_xyz.
+ simpl.
+ reflexivity.
+ - assert (hperm:PermutationA equiv ([ptx; pty; pt]) ([pt; ptx; pty])) by permut_3_4.
+ rewrite ?hperm in *.
+ generalize hperm;intro hperm'.
+ apply PermutationA_Leibniz in hperm'.
+ rewrite (classify_triangle_compat hperm') in Htriangle.
+ generalize (@equilateral_SEC _ _ _ Htriangle).
+ intro h_sec_xyz.
+ rewrite <- heq_bary in h_sec_xyz.
+ rewrite h_sec_xyz.
+ simpl.
+ reflexivity. }
+assert (h_radius_ptdiam : radius (SEC ([ptx; pty; ptz])) = dist bary ptdiam).
+{ rewrite InA_Leibniz in hIn_ptdiam.
+ simpl in hIn_ptdiam.
+ decompose [or False] hIn_ptdiam;subst.
+ - generalize (@equilateral_SEC _ _ _ Htriangle).
+ intro h_sec_xyz.
+ rewrite <- heq_bary in h_sec_xyz.
+ rewrite h_sec_xyz.
+ simpl.
+ reflexivity.
+ - assert (hperm:PermutationA equiv ([ptx; ptdiam; ptz]) ([ptdiam; ptx; ptz])) by permut_3_4.
+ rewrite ?hperm in *.
+ generalize hperm;intro hperm'.
+ apply PermutationA_Leibniz in hperm'.
+ rewrite (classify_triangle_compat hperm') in Htriangle.
+ generalize (@equilateral_SEC _ _ _ Htriangle).
+ intro h_sec_xyz.
+ rewrite <- heq_bary in h_sec_xyz.
+ rewrite h_sec_xyz.
+ simpl.
+ reflexivity.
+ - assert (hperm:PermutationA equiv ([ptx; pty; ptdiam]) ([ptdiam; ptx; pty])) by permut_3_4.
+ rewrite ?hperm in *.
+ generalize hperm;intro hperm'.
+ apply PermutationA_Leibniz in hperm'.
+ rewrite (classify_triangle_compat hperm') in Htriangle.
+ generalize (@equilateral_SEC _ _ _ Htriangle).
+ intro h_sec_xyz.
+ rewrite <- heq_bary in h_sec_xyz.
+ rewrite h_sec_xyz.
+ simpl.
+ reflexivity. }
+assert (dist ptdiam bary = dist pt bary).
+{ setoid_rewrite dist_sym.
+ rewrite <- h_radius_ptdiam , <- h_radius_pt.
+ reflexivity. }
+apply hneq_pt_ptdiam.
+apply h_bary;auto.
+assert (h_diameter_after : SEC (support (!! (round gatherR2 da config)))
+ = {| R2.center := middle bary ptdiam; radius := / 2 * dist bary ptdiam |}).
+{ assert (Hlen := PermutationA_length Hsec').
+ destruct (on_SEC (support (!! (round gatherR2 da config))))
+ as [| x [ | y [|?] ]] eqn:Heq; simpl in Hlen; lia || clear Hlen.
+ apply PermutationA_2 in Hsec'; autoclass.
+ destruct Hsec' as [ [h1 h2] | [h2 h1]].
+ - apply on_SEC_pair_is_diameter.
+ rewrite Heq.
+ hnf in h1, h2.
+ now subst.
+ - rewrite middle_comm.
+ rewrite dist_sym.
+ apply on_SEC_pair_is_diameter.
+ rewrite Heq.
+ hnf in h1, h2.
+ now subst. }
+assert (dist_pt1_mid_is_radius: dist bary (middle bary ptdiam)
+ = radius (SEC (support (!! (round gatherR2 da config))))).
+{ rewrite h_diameter_after. simpl radius. now rewrite R2dist_middle. }
+
+changeR2. rewrite dist_pt1_mid_is_radius.
+rewrite radius_is_max_dist.
+replace (middle bary ptdiam) with (R2.center (SEC (support (!! (round gatherR2 da config))))).
++ rewrite dist_sym.
+ apply max_dist_le.
+ now rewrite InA_Leibniz in abs.
++ changeR2. now rewrite h_diameter_after.
+Qed.
+
+(* Extracting nodupA and ~InA consequences (in terms of <>) *)
+Ltac inv_notin H :=
+ match type of H with
+ | ~ List.In ?x nil => clear H
+ | ~ InA (@equiv _ _) ?x ?l =>
+ let h := fresh H in
+ assert (h:~ List.In x l);
+ [ rewrite <- InA_Leibniz; assumption | inv_notin h ]
+ | ~ List.In ?x ?l =>
+ apply not_in_cons in H;
+ let h := fresh H in
+ let heq := fresh "heq" in
+ destruct H as [heq h];
+ try inv_notin h
+ end.
+
+Ltac inv_nodup H :=
+ lazymatch type of H with
+ | NoDupA (@equiv _ _) nil => clear H
+ | NoDupA (@equiv _ _) (?x::nil) => clear H
+ | NoDupA (@equiv _ _) (?x::?y::?l) =>
+ let x := fresh "x" in
+ let l := fresh "l" in
+ let C := fresh "h_notin" in
+ let D := fresh "h_nodup" in
+ let E := fresh "E" in
+ let F := fresh "F" in
+ inversion H as [|x l C D [E F]];
+ match type of E with
+ | ?x = _ => subst x
+ end;
+ match type of F with
+ | ?x = _ => subst x
+ end;
+ inv_notin C;
+ inv_nodup D
+(* try clear C; try clear D *)
+ | NoDupA (@equiv _ _) (?x :: ?l) => idtac (* nothing to do here *)
+ end.
+
+(** **** Merging results about the different kinds of triangles **)
+
+Lemma triangle_next_maj_or_diameter_or_triangle :
+ triangle_case config ->
+ (* A majority tower *)
+ length (support (max (!! (round gatherR2 da config)))) = 1
+ (* No majority tower and we go from equilateral to unclean diameter case *)
+ \/ no_Majority (round gatherR2 da config)
+ /\ equilateral_case config
+ /\ length (on_SEC (support (!! (round gatherR2 da config)))) = 2
+ /\ is_clean (!! (round gatherR2 da config)) = false
+ /\ inclA equiv (on_SEC (support (!! (round gatherR2 da config)))) ((on_SEC (support (!! config))))
+ (* No majority tower and the SEC remains the same *)
+ \/ no_Majority (round gatherR2 da config)
+ /\ PermutationA equiv (on_SEC (support (!! (round gatherR2 da config))))
+ (on_SEC (support (!! config))).
+Proof using Hssync Hbivalent da n size_G.
+intros [Hmaj [ptx [pty [ptz Hsec]]]].
+destruct (support (max (!! (round gatherR2 da config)))) as [| pt1 [| pt2 l]] eqn:Hmax'.
+- rewrite support_nil, max_is_empty in Hmax'. elim (obs_non_nil _ Hmax').
+- now left.
+- right.
+ get_case (round gatherR2 da config). rename Hmaj0 into Hmaj'.
+ clear Hmax' pt1 pt2 l.
+ assert (Hbivalent' : ~ bivalent (round gatherR2 da config)) by now apply never_bivalent.
+ assert (Hlen' : size (!! (round gatherR2 da config)) >= 3) by now apply not_bivalent_no_majority_size.
+ destruct (classify_triangle ptx pty ptz) eqn:Htriangle.
+ + (* Equilateral case *)
+ assert (Htarget : target (!! config) = isobarycenter ([ptx; pty; ptz])%list) by now apply equilateral_target.
+ assert (Hle := no_Majority_on_SEC_length Hmaj').
+ destruct (on_SEC (support (!! (round gatherR2 da config)))) as [| pt1 [| pt2 [| pt3 l]]] eqn:Hsec';
+ cbn in Hle; try lia.
+ * (* Valid case: SEC is a pair after the round *)
+ destruct (is_clean (!! (round gatherR2 da config))) eqn:Hclean'.
+ -- (* Absurd case: the center of the SEC is not on a diameter *)
+ exfalso.
+ clear Hle.
+ assert (Hcenter := on_SEC_pair_is_diameter _ Hsec').
+ assert (Hperm : PermutationA equiv (support (!! (round gatherR2 da config)))
+ ([middle pt1 pt2; pt1; pt2])).
+ { apply diameter_clean_support;auto. }
+ destruct (is_clean (!! config)) eqn:Hclean.
+ ** assert (Hincl : inclA equiv (support (!! (round gatherR2 da config)))
+ (target (!! config) :: [ptx; pty; ptz])).
+ { rewrite <- Hsec. now apply incl_clean_next. }
+ rewrite Hperm in Hincl.
+ destruct (InA_dec equiv_dec (target(!! config)) (middle pt1 pt2 :: [pt1; pt2])) as [Hin | Hin].
+ --- rewrite Htarget in Hin.
+ assert (hNoDup : NoDupA equiv ([pt1; pt2])).
+ { rewrite <- Hsec'. apply on_SEC_NoDupA, support_NoDupA. }
+ Opaque middle.
+ { inv hNoDup. match goal with | H: ~ InA _ _ _ |- _ => apply H end. left.
+ rewrite 2 InA_cons, InA_singleton in Hin. decompose [or] Hin; clear Hin.
+ - (* Absurd case because distances do not match:
+ - dist corner (center of equilateral triangle) = sqrt(3)/2 * side
+ - dist to middle of a segment = side / 2
+ => these can only be equal if side = 0, that is, all corners coincide. *)
+ rewrite <- H, Htarget in Hincl.
+ assert (~ InA equiv (isobarycenter ([ptx; pty; ptz])) ([pt1; pt2])).
+ { assert (Hnodup := support_NoDupA (!! (round gatherR2 da config))).
+ rewrite Hperm in Hnodup. rewrite H. now inv Hnodup. }
+ eapply inclA_cons_inv in Hincl; autoclass; auto; [].
+ symmetry in H. revert H.
+ now apply middle_isobarycenter_3_neq.
+ - (* if (target (config)) is in (SEC (round config)) then two previously
+ SEC-towers have moved to (target (config)). therefore there are
+ two tower => majority (or contradicting bivalent). *)
+ assert (Hin : List.In pt2 ([ptx; pty; ptz])).
+ { assert (Hin : List.In pt2 (target (!! config) :: [ptx; pty; ptz])).
+ { rewrite <- Hsec.
+ apply InA_Leibniz.
+ eapply incl_clean_next; auto; [].
+ assert (Hin : InA equiv pt2 (on_SEC (support (!! (round gatherR2 da config))))).
+ { rewrite Hsec'. now right; left. }
+ rewrite InA_Leibniz in Hin |- *.
+ now apply on_SEC_In. }
+ inversion Hin; trivial; [].
+ exfalso.
+ rewrite H0 in Htarget.
+ rewrite Htarget in H.
+ intuition. }
+ unfold inclA in Hincl.
+ assert (hmid:InA equiv (middle pt1 pt2) (middle pt1 pt2 :: [pt1; pt2])).
+ { left.
+ reflexivity. }
+ specialize (Hincl (middle pt1 pt2) hmid).
+ clear hmid.
+ rewrite InA_Leibniz in Hincl.
+ lazy beta iota delta [List.In] in Hincl.
+ decompose [or False] Hincl;clear Hincl.
+
+ + rewrite Htarget, H0 in H. symmetry in H.
+ rewrite <- middle_eq. apply H.
+ + assert(ptx == pt2).
+ { rewrite middle_comm in H3.
+ eapply equilateral_isobarycenter_degenerated_gen
+ with (ptopp:=pt2) (mid:=ptx) (white:=pt1); eauto.
+ now left. }
+ subst ptx.
+ symmetry. rewrite <- middle_eq, middle_comm.
+ apply H.
+ + assert(pty = pt2).
+ { rewrite middle_comm in H.
+ eapply equilateral_isobarycenter_degenerated_gen
+ with (ptopp:=pt2) (mid:=pty) (white:=pt1); eauto.
+ now right; left. }
+ subst pty.
+ symmetry. rewrite <- middle_eq, middle_comm.
+ apply H3.
+ + assert(ptz = pt2).
+ { rewrite middle_comm in H3.
+ eapply equilateral_isobarycenter_degenerated_gen
+ with (ptopp:=pt2) (mid:=ptz) (white:=pt1); eauto.
+ now do 2 right; left. }
+ subst ptz.
+ symmetry. rewrite <- middle_eq, middle_comm.
+ apply H.
+ - (* if (target (config)) is in (SEC (round config)) then two previously
+ SEC-towers have moved to (target (config)). therefore there are
+ two towers => majority (or contradicting bivalent). *)
+ assert (hIn:List.In pt1 ([ptx; pty; ptz])).
+ { assert (Hin:List.In pt1 (target (!! config) :: [ptx; pty; ptz])).
+ { rewrite <- Hsec.
+ apply InA_Leibniz.
+ eapply incl_clean_next ;auto;[].
+ assert (Hin:InA equiv pt1 (on_SEC (support (!! (round gatherR2 da config))))).
+ { rewrite Hsec'.
+ left;reflexivity. }
+ rewrite InA_Leibniz in Hin |-*.
+ apply on_SEC_In.
+ assumption. }
+ inversion Hin;trivial;[].
+ exfalso.
+ rewrite H in Htarget.
+ rewrite Htarget in Hin.
+ subst pt1; intuition. }
+ lazy beta iota delta [inclA] in Hincl.
+ assert (hmid:InA equiv (middle pt1 pt2) (middle pt1 pt2 :: [pt1; pt2])).
+ { left.
+ reflexivity. }
+ specialize (Hincl (middle pt1 pt2) hmid).
+ rewrite InA_Leibniz in Hincl.
+ lazy beta iota delta [List.In] in Hincl.
+ decompose [or False] Hincl;clear Hincl.
+ + rewrite Htarget in H.
+ rewrite H in H0.
+ symmetry. rewrite <- middle_eq, middle_comm.
+ apply H0.
+ + assert(ptx = pt1).
+ { eapply equilateral_isobarycenter_degenerated_gen
+ with (ptopp:=pt1) (mid:=ptx) (white:=pt2);eauto.
+ left.
+ reflexivity. }
+ subst ptx.
+ rewrite <- middle_eq.
+ apply H.
+ + assert(pty = pt1).
+ { eapply equilateral_isobarycenter_degenerated_gen
+ with (ptopp:=pt1) (mid:=pty) (white:=pt2);eauto.
+ right;left.
+ reflexivity. }
+ subst pty.
+ rewrite <- middle_eq.
+ apply H3.
+ + assert(ptz = pt1).
+ { eapply equilateral_isobarycenter_degenerated_gen
+ with (ptopp:=pt1) (mid:=ptz) (white:=pt2);eauto.
+ right;right;left.
+ reflexivity. }
+ subst ptz.
+ rewrite <- middle_eq.
+ apply H. }
+ --- (* ([ptx; pty; ptz]) = (middle pt1 pt2 :: [pt1; pt2])
+ contradiction with calssify_triangle = equilateral *)
+ assert (PermutationA equiv ([ptx; pty; ptz]) (middle pt1 pt2 :: [pt1; pt2])).
+ { apply inclA_skip in Hincl;autoclass.
+ - symmetry.
+ apply NoDupA_inclA_length_PermutationA with (1:=setoid_equiv);auto; [].
+ rewrite <- Hperm. apply support_NoDupA; auto. }
+ assert (classify_triangle (middle pt1 pt2) pt1 pt2 = Equilateral).
+ { rewrite PermutationA_Leibniz in H. now rewrite (classify_triangle_compat H) in Htriangle. }
+ functional inversion H0. (*clear H0.*)
+ rewrite -> ?Rdec_bool_true_iff in *.
+ rewrite dist_sym in H1.
+ rewrite R2dist_middle in H1.
+ assert (dist pt1 pt2 = 0%R).
+ { changeR2.
+ lra. }
+ apply dist_defined in H3.
+ assert (hNoDup:NoDupA equiv ([pt1; pt2])).
+ { rewrite <- Hsec'.
+ apply on_SEC_NoDupA.
+ apply support_NoDupA. }
+
+ rewrite H3 in hNoDup.
+ inversion hNoDup.
+ apply H6. left;reflexivity.
+ ** rewrite <- dirty_next_on_SEC_same in Hsec;auto.
+ rewrite Hsec' in Hsec.
+ assert (length ([pt1; pt2]) = length ([ptx; pty; ptz])).
+ { rewrite Hsec.
+ reflexivity. }
+ simpl in H;lia.
+
+ -- (* Valid case: the center of the SEC is not on a diameter *)
+ left. repeat split; trivial; eauto.
+ assert (h_clean_config:is_clean (!! config) = true).
+ { destruct (bool_dec (is_clean (!! config)) true) as [ heq_clean_true | heq_clean_false].
+ - assumption.
+ - exfalso.
+ apply not_true_is_false in heq_clean_false.
+ assert (hdirty:=@dirty_next_SEC_same Hmaj heq_clean_false).
+ setoid_rewrite <- (@dirty_next_on_SEC_same Hmaj heq_clean_false) in Hsec.
+ rewrite Hsec' in Hsec.
+ apply PermutationA_length in Hsec.
+ simpl in Hsec.
+ lia. }
+
+ assert (hincl_round:inclA equiv (support (!! (round gatherR2 da config)))
+ (target (!! config) :: on_SEC (support (!! config)))).
+ { eapply incl_clean_next ;eauto. }
+ rewrite Htarget in hincl_round.
+ rewrite Hsec in hincl_round.
+ assert (h_incl_pt1_pt2 : inclA equiv ([pt1; pt2]) (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])).
+ { transitivity (support (!! (round gatherR2 da config))).
+ - rewrite <- Hsec'.
+ unfold on_SEC.
+ unfold inclA.
+ intros x H1.
+ rewrite filter_InA in H1.
+ destruct H1.
+ assumption.
+ autoclass.
+ - assumption. }
+
+ assert (hnodup: NoDupA equiv ([pt1; pt2])).
+ { rewrite <- Hsec'.
+ apply on_SEC_NoDupA.
+ apply support_NoDupA. }
+
+ assert (hnodupxyz: NoDupA equiv ([ptx; pty; ptz])).
+ { rewrite <- Hsec.
+ apply on_SEC_NoDupA.
+ apply support_NoDupA. }
+ inv_nodup hnodupxyz.
+ inv_nodup hnodup.
+ destruct (pt1 =?= (isobarycenter ([ptx; pty; ptz]))) as [heq_pt1_bary | hneq_pt1_bary].
+ ++ { exfalso.
+ assert(hpermut_config: PermutationA equiv (support (!! (round gatherR2 da config))) ([pt1; pt2])).
+ { rewrite heq_pt1_bary in heq2, h_incl_pt1_pt2.
+ apply inclA_cons_inv in h_incl_pt1_pt2; autoclass.
+ + red in h_incl_pt1_pt2.
+ assert (h_pt2:InA equiv pt2 ([pt2])).
+ { left;reflexivity. }
+ specialize (h_incl_pt1_pt2 pt2 h_pt2).
+ clear h_pt2.
+ inversion h_incl_pt1_pt2 as [pt lpt heq_pt2_ptx [__h heq_lpt]| pt lpt h_in_pt2_lpt [__h heq_lpt]].
+ (* pt2 = ptx *)
+ * unfold equiv, R2_Setoid in heq_pt2_ptx.
+ subst.
+ assert (hpermut:PermutationA equiv (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (pty :: ptz :: isobarycenter ([ptx; pty; ptz]) :: [ptx]))
+ by permut_3_4.
+ rewrite hpermut in hincl_round;clear hpermut.
+ assert (h_ynotin:~ InA equiv pty (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty) (ptz:=ptz) ;eauto.
+ - rewrite Hsec'.
+ reflexivity. }
+ assert (h_znotin:~ InA equiv ptz (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty) (ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ reflexivity. }
+ do 2 (apply inclA_skip in hincl_round; autoclass).
+ apply NoDupA_inclA_length_PermutationA; autoclass.
+ -- apply support_NoDupA.
+ -- now rewrite heq_pt1_bary.
+ -- transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
+ ++ now rewrite Hsec'.
+ ++ lazy beta iota delta [on_SEC].
+ rewrite filter_length.
+ changeR2.
+ lia.
+
+ * { (* InA equiv pt2 [pt2] *)
+ subst pt.
+ subst lpt.
+ inversion h_in_pt2_lpt
+ as [pt lpt heq_pt2_pty [__h heq_lpt] | pt lpt h_in_pt2_lpt' [__h heq_lpt]].
+ (* pt2 = pty *)
+ * unfold equiv, R2_Setoid in heq_pt2_pty.
+ subst.
+ assert (Hperm:PermutationA equiv (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (ptx :: ptz :: isobarycenter ([ptx; pty; ptz]) :: [pty]))
+ by permut_3_4.
+ rewrite Hperm in hincl_round;clear Hperm.
+ assert (h_ynotin:~ InA equiv ptx (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty)(ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ reflexivity. }
+ assert (h_znotin:~ InA equiv ptz (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty)(ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ reflexivity. }
+ apply inclA_skip in hincl_round;autoclass.
+ apply inclA_skip in hincl_round;autoclass.
+ apply NoDupA_inclA_length_PermutationA;autoclass.
+ -- apply support_NoDupA.
+ -- rewrite heq_pt1_bary.
+ assumption.
+ -- changeR2.
+ transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
+ ++ changeR2.
+ rewrite Hsec'.
+ reflexivity.
+ ++ unfold on_SEC.
+ rewrite filter_length.
+ changeR2.
+ lia.
+ * subst pt.
+ subst lpt.
+ { inversion h_in_pt2_lpt'
+ as [pt lpt heq_pt2_pty [__h heq_lpt] | pt lpt h_in_pt2_lpt'' [__h heq_lpt]].
+ (* pt2 = pty *)
+ * unfold equiv, R2_Setoid in heq_pt2_pty.
+ subst.
+ assert (Hperm : PermutationA equiv
+ (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (ptx :: pty :: isobarycenter ([ptx; pty; ptz]) :: [ptz]))
+ by permut_3_4.
+ rewrite Hperm in hincl_round;clear Hperm.
+ assert (h_ynotin:~ InA equiv ptx (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty)(ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ reflexivity. }
+ assert (h_znotin:~ InA equiv pty (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty)(ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ reflexivity. }
+ apply inclA_skip in hincl_round;autoclass.
+ apply inclA_skip in hincl_round;autoclass.
+ apply NoDupA_inclA_length_PermutationA;autoclass.
+ -- apply support_NoDupA.
+ -- now rewrite heq_pt1_bary.
+ --
+ transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
+ ++ rewrite Hsec'.
+ reflexivity.
+ ++ unfold on_SEC.
+ rewrite filter_length.
+ changeR2.
+ lia.
+ * inversion h_in_pt2_lpt''. } }
+ + intro Hin. apply heq2. now inversion Hin. }
+ - rewrite size_spec in Hlen'.
+ rewrite hpermut_config in Hlen'.
+ simpl in Hlen'.
+ lia. }
+ ++ { destruct (equiv_dec pt2 (isobarycenter ([ptx; pty; ptz]))) as [heq_pt2_bary | hneq_pt2_bary].
+ ++ { exfalso.
+ assert(hpermut_config: PermutationA equiv (support (!! (round gatherR2 da config))) ([pt2; pt1])).
+ { assert (hpermut12:PermutationA equiv ([pt1; pt2]) ([pt2; pt1])) by permut_3_4.
+ rewrite hpermut12 in h_incl_pt1_pt2.
+ rewrite heq_pt2_bary in heq2, h_incl_pt1_pt2.
+ apply inclA_cons_inv in h_incl_pt1_pt2;autoclass.
+ + red in h_incl_pt1_pt2.
+ assert (h_pt1:InA equiv pt1 ([pt1])).
+ { left;reflexivity. }
+ specialize (h_incl_pt1_pt2 pt1 h_pt1).
+ clear h_pt1.
+ inversion h_incl_pt1_pt2 as [pt lpt heq_pt1_ptx [__h heq_lpt]
+ | pt lpt h_in_pt1_lpt [__h heq_lpt]].
+ (* pt1 = ptx *)
+ * unfold equiv, R2_Setoid in heq_pt1_ptx.
+ subst ptx.
+ subst pt.
+ assert (Hperm:PermutationA equiv (isobarycenter ([pt1; pty; ptz]) :: [pt1; pty; ptz])
+ (pty :: ptz :: isobarycenter ([pt1; pty; ptz]) :: [pt1]))
+ by permut_3_4.
+ rewrite Hperm in hincl_round;clear Hperm.
+ assert (h_ynotin:~ InA equiv pty (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=pt1)(pty:=pty)(ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ permut_3_4. }
+ assert (h_znotin:~ InA equiv ptz (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=pt1)(pty:=pty)(ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ permut_3_4. }
+ apply inclA_skip in hincl_round;autoclass.
+ apply inclA_skip in hincl_round;autoclass.
+ apply NoDupA_inclA_length_PermutationA;autoclass.
+ -- apply support_NoDupA.
+ -- now rewrite heq_pt2_bary.
+ -- transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
+ ++ now rewrite Hsec'.
+ ++ unfold on_SEC.
+ rewrite filter_length.
+ changeR2.
+ lia.
+
+ * { (* InA equiv pt1 [pt1] *)
+ subst pt.
+ subst lpt.
+ inversion h_in_pt1_lpt as [pt lpt heq_pt1_pty [__h heq_lpt]
+ | pt lpt h_in_pt1_lpt' [__h heq_lpt]].
+ (* pt1 = pty *)
+ * unfold equiv, R2_Setoid in heq_pt1_pty.
+ subst.
+ assert (Hperm : PermutationA equiv
+ (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (ptx :: ptz :: isobarycenter ([ptx; pty; ptz]) :: [pty]))
+ by permut_3_4.
+ rewrite Hperm in hincl_round;clear Hperm.
+ assert (h_xnotin:~ InA equiv ptx (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty)(ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ permut_3_4. }
+ assert (h_znotin:~ InA equiv ptz (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty)(ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ permut_3_4. }
+ apply inclA_skip in hincl_round;autoclass.
+ apply inclA_skip in hincl_round;autoclass.
+ apply NoDupA_inclA_length_PermutationA;autoclass.
+ -- apply support_NoDupA.
+ -- now rewrite heq_pt2_bary.
+ -- transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
+ ++ now rewrite Hsec'.
+ ++ unfold on_SEC.
+ rewrite filter_length.
+ changeR2.
+ lia.
+ * subst pt.
+ subst lpt.
+ { inversion h_in_pt1_lpt'
+ as [pt lpt heq_pt1_ptz [__h heq_lpt] | pt lpt h_in_pt1_lpt'' [__h heq_lpt]].
+ (* pt1 = pty *)
+ * unfold equiv, R2_Setoid in heq_pt1_ptz.
+ subst.
+ assert (hpermut : PermutationA equiv
+ (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])
+ (ptx :: pty :: isobarycenter ([ptx; pty; ptz]) :: [ptz]))
+ by permut_3_4.
+ rewrite hpermut in hincl_round;clear hpermut.
+ assert (h_xnotin:~ InA equiv ptx (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty)(ptz:=ptz);eauto.
+ - rewrite Hsec'.
+ permut_3_4. }
+ assert (h_ynotin:~ InA equiv pty (support (!! (round gatherR2 da config)))).
+ { eapply SEC_3_to_2 with (ptx:=ptx)(pty:=pty)(ptz:=ptz); eauto.
+ - rewrite Hsec'.
+ permut_3_4. }
+
+ do 2 (apply inclA_skip in hincl_round; autoclass).
+ apply NoDupA_inclA_length_PermutationA; autoclass.
+ -- apply support_NoDupA.
+ -- now rewrite heq_pt2_bary.
+ -- transitivity (length (on_SEC (support (!! (round gatherR2 da config))))).
+ ++ rewrite Hsec'.
+ reflexivity.
+ ++ unfold on_SEC.
+ rewrite filter_length.
+ changeR2.
+ lia.
+ * inversion h_in_pt1_lpt''. } }
+ + intro abs.
+ inversion abs.
+ * apply heq2.
+ symmetry.
+ assumption.
+ * rewrite <- InA_nil.
+ eauto. }
+ + rewrite size_spec in Hlen'.
+ rewrite hpermut_config in Hlen'.
+ simpl in Hlen'.
+ lia. }
+
+ ++ rewrite Hsec.
+ intros pt hin.
+ assert (h:=h_incl_pt1_pt2 _ hin).
+ inversion_clear h.
+ ** inversion hin.
+ --- subst.
+ rewrite H1 in H.
+ contradiction.
+ --- subst.
+ inversion H1.
+ +++ rewrite H2 in H.
+ contradiction.
+ +++ inversion H2.
+ ** assumption. }
+ * (* Valid case: SEC is a triangle *)
+ right. split; trivial.
+ rewrite <- Hsec'.
+ (* TODO: the SEC has not changed *)
+ destruct (is_clean (!! config)) eqn:Hclean.
+ -- destruct (moving gatherR2 da config) as [| gmove ?] eqn:Hmoving.
+ ++ apply no_moving_same_config in Hmoving.
+ ** now rewrite Hmoving.
+ ** auto.
+ ++ assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
+ (isobarycenter ([ptx; pty; ptz]) :: [ptx; pty; ptz])).
+ { assert ((!! (round gatherR2 da config))[target (!! config)] > 0).
+ { apply Nat.le_lt_trans with ((!! config)[target (!! config)]); try lia; [].
+ rewrite (increase_move_iff Hssync non_bivalent_same_destination); trivial; [].
+ exists gmove. split.
+ - apply destination_is_target; trivial.
+ rewrite Hmoving. now left.
+ - assert (hmoved_in:List.In gmove (moving gatherR2 da config)).
+ { rewrite Hmoving.
+ now left. }
+ apply moving_spec in hmoved_in.
+ intro Habs. apply hmoved_in. apply no_info; trivial; []. now apply round_simplify_Lights. }
+ apply (NoDupA_inclA_length_PermutationA _).
+ - apply support_NoDupA.
+ - rewrite <- Htarget, <- Hsec. now apply incl_clean_next.
+ - rewrite <- size_spec.
+ destruct (size (!! (round gatherR2 da config))) as [| [| [| [| ?]]]] eqn:Hlen; simpl; try lia.
+ exfalso.
+ assert (l = nil).
+ { destruct l as [| pt4 l]; trivial.
+ cut (4 + length l <= 3); try lia.
+ change (4 + length l) with (length (pt1 :: pt2 :: pt3 :: pt4 :: l)).
+ rewrite <- Hsec', <- Hlen, size_spec.
+ apply (NoDupA_inclA_length setoid_equiv).
+ - apply on_SEC_NoDupA, support_NoDupA.
+ - unfold on_SEC. intro. rewrite (filter_InA _). intuition. }
+ subst.
+ assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
+ ([pt1; pt2; pt3])).
+ { symmetry.
+ apply (NoDupA_inclA_length_PermutationA _).
+ - rewrite <- Hsec'. apply on_SEC_NoDupA, support_NoDupA.
+ - rewrite <- Hsec'. unfold on_SEC. intro. rewrite (filter_InA _). intuition.
+ - rewrite <- size_spec. rewrite Hlen. cbn. lia. }
+ rewrite <- Hsec' in Hperm'.
+ (* Equilateral triangle: since one robot moves and there are still 3 columns afterwards,
+ a column moved to the barycenter, contradiction as the barycenter cannot be on the SEC. *)
+ assert (Hnodup : NoDupA equiv ([ptx; pty; ptz])).
+ { rewrite <- Hsec. apply on_SEC_NoDupA, support_NoDupA. }
+ assert (Hex : exists pta ptb ptc,
+ PermutationA equiv ([pta; ptb; ptc]) ([ptx; pty; ptz])
+ /\ PermutationA equiv (isobarycenter ([ptx; pty; ptz]) :: [pta; ptb])
+ ([pt1; pt2; pt3])).
+ { assert (hincl:=incl_clean_next Hclean).
+ rewrite Hsec in hincl.
+ rewrite Hperm', Hsec' in hincl.
+ assert (hbary : InA equiv (isobarycenter ([ptx; pty; ptz]))
+ (support (!! (round gatherR2 da config)))).
+ { rewrite support_spec.
+ rewrite <- Htarget.
+ assumption. }
+ rewrite Hperm',Hsec' in hbary.
+ apply PermutationA_split in hbary; autoclass.
+ destruct hbary as [l hpermut_l].
+ setoid_rewrite hpermut_l.
+ assert (Hlength := PermutationA_length hpermut_l).
+ destruct l as [| pta [| ptb [| ? ?]]]; simpl in Hlength; lia || clear Hlength.
+ inv_nodup Hnodup.
+ assert (Hnodup' := equilateral_isobarycenter_NoDupA _ Htriangle ltac:(auto)).
+ assert (Hnodup123 : NoDupA equiv ([pt1; pt2; pt3])).
+ { rewrite <- Hsec'. apply on_SEC_NoDupA, support_NoDupA. }
+ inv_nodup Hnodup'.
+ rewrite hpermut_l in Hnodup123. inv_nodup Hnodup123.
+ assert (Hpta : InA equiv pta ([ptx; pty; ptz])).
+ { rewrite hpermut_l, Htarget in hincl. apply (inclA_cons_inv _ h_notin4) in hincl.
+ apply hincl. now constructor. }
+ assert (Hptb : InA equiv ptb ([ptx; pty; ptz])).
+ { rewrite hpermut_l, Htarget in hincl. apply (inclA_cons_inv _ h_notin4) in hincl.
+ apply hincl. now do 2 constructor. }
+ rewrite InA_Leibniz in Hpta, Hptb. simpl in Hpta, Hptb.
+ exists pta, ptb.
+ cut (exists ptc, PermutationA equiv ([pta; ptb; ptc]) ([ptx; pty; ptz])).
+ - intros [ptc Hptc]. exists ptc. now split.
+ - decompose [or False] Hpta; decompose [or False] Hptb;
+ lazymatch goal with
+ | Ha : ?pt = pta, Hb : ?pt = ptb |- _ => congruence
+ | Ha : ?pt = pta, Hb : ?pt' = ptb |- _ =>
+ match goal with
+ | H : pt <> ?ptc, H' : pt' <> ?ptc |- _ => exists ptc
+ | H : ?ptc <> pt, H' : pt' <> ?ptc |- _ => exists ptc
+ | H : pt <> ?ptc, H' : ?ptc <> pt' |- _ => exists ptc
+ | H : ?ptc <> pt, H' : ?ptc <> pt' |- _ => exists ptc
+ end
+ end; subst; permut_3_4. }
+ destruct Hex as [pta [ptb [ptc [Hpermxyz Hperm]]]].
+ pose (better_SEC := {| R2.center := middle pta ptb; radius := /2 * dist pta ptb |}).
+
+ assert (Hbary_strict : (dist (isobarycenter ([ptx; pty; ptz])) (R2.center better_SEC)
+ < radius better_SEC)%R).
+ { rewrite PermutationA_Leibniz in Hpermxyz. rewrite <- Hpermxyz.
+ unfold better_SEC. rewrite 2 norm_dist. cbn [R2.center radius].
+ pose (h:=@Barycenter_spec pta ptb ptc).
+ rewrite isobarycenter_3_pts.
+ Transparent middle. unfold middle. Opaque middle.
+ replace (/ 3 * (pta + ptb + ptc) - 1 / 2 * (pta + ptb))%VS
+ with (/6 * (ptc + ptc - (pta + ptb)))%VS by (destruct pta, ptb, ptc; simpl; f_equal; field).
+ rewrite norm_mul. rewrite Rabs_pos_eq; try lra; [].
+ repeat rewrite <- norm_dist.
+ cut (dist (ptc + ptc) (pta + ptb) < 3 * dist pta ptb)%R. { changeR2. lra. }
+ eapply Rle_lt_trans.
+ - apply (triang_ineq _ (ptc + pta)%VS).
+ - changeR2.
+ setoid_rewrite RealVectorSpace.add_comm at 2 4.
+ do 2 rewrite dist_translation.
+ rewrite <- (classify_triangle_compat Hpermxyz) in Htriangle.
+ rewrite classify_triangle_Equilateral_spec in Htriangle.
+ destruct Htriangle as [Heq1 Heq2].
+ setoid_rewrite dist_sym at 1 2. changeR2. rewrite Heq1, Heq2.
+ assert (Hle' := dist_nonneg ptb ptc).
+ rewrite <- PermutationA_Leibniz in Hpermxyz. rewrite <- Hpermxyz in Hnodup.
+ inv_nodup Hnodup.
+ assert (heq1': (dist ptb ptc <> 0)%R).
+ { red.
+ intro abs.
+ rewrite dist_defined in abs.
+ vm_compute in abs.
+ contradiction. }
+ changeR2.
+ lra. }
+ assert (enclosing_circle better_SEC (isobarycenter ([ptx; pty; ptz]) :: [pta; ptb])).
+ { intros pt hin.
+ simpl in hin.
+ unfold better_SEC. cbn [R2.center radius].
+ decompose [or False] hin; subst pt; clear hin.
+ - now apply Rlt_le.
+ - now rewrite R2dist_middle.
+ - now rewrite middle_comm, R2dist_middle, dist_sym. }
+ assert (better_SEC = (SEC (support (!! (round gatherR2 da config))))).
+ { rewrite PermutationA_Leibniz in Hperm', Hperm.
+ rewrite Hperm', Hsec', <- Hperm.
+ apply SEC_unicity.
+ - assumption.
+ - unfold better_SEC.
+ simpl.
+ apply SEC_min_radius; intuition. }
+ absurd (on_circle better_SEC (isobarycenter ([ptx; pty; ptz])) = true).
+ + rewrite on_circle_true_iff.
+ apply Rlt_not_eq.
+ assumption.
+ + rewrite H1.
+ eapply proj2.
+ rewrite <- filter_InA;autoclass.
+ unfold on_SEC in Hsec'.
+ rewrite Hsec'.
+ rewrite <- Hperm.
+ constructor.
+ reflexivity.
+ }
+ apply (NoDupA_equivlistA_PermutationA _).
+ ** apply on_SEC_NoDupA, support_NoDupA.
+ ** apply on_SEC_NoDupA, support_NoDupA.
+ ** rewrite Hperm', Hsec.
+ rewrite on_SEC_isobarycenter_triangle, <- Hsec, on_SEC_idempotent; try reflexivity.
+ intros [? ?]. subst.
+ assert (Hnodup : NoDupA equiv (on_SEC (support (!! config)))).
+ { apply on_SEC_NoDupA, support_NoDupA. }
+ rewrite Hsec in Hnodup. inversion Hnodup. intuition.
+ -- now apply dirty_next_on_SEC_same.
+ + (* Isosceles case *)
+ assert (Htarget := isosceles_target config Hsec Htriangle).
+ right. split; trivial.
+ destruct (is_clean (!! config)) eqn:Hclean.
+ -- destruct (moving gatherR2 da config) as [| gmove ?] eqn:Hmoving.
+ ++ apply no_moving_same_config in Hmoving.
+ ** now rewrite Hmoving.
+ ** auto using color_bivalent_bivalent.
+ ++ assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
+ ([ptx; pty; ptz])).
+ { assert (forall x, List.In x (gmove :: l) -> get_location (round gatherR2 da config x) == vertex).
+ { rewrite <- Htarget.
+ intros x H3.
+ apply destination_is_target; auto.
+ rewrite Hmoving.
+ assumption. }
+ assert (h_vertex:=isoscele_vertex_is_vertex _ _ _ Htriangle).
+ assert (H_supp: PermutationA equiv (support (!! config)) ([ptx; pty; ptz])).
+ { rewrite is_clean_spec in Hclean.
+ unfold SECT in Hclean.
+ rewrite Hsec in Hclean.
+ apply inclA_cons_InA in Hclean;autoclass;auto.
+ - apply NoDupA_inclA_length_PermutationA;autoclass.
+ + apply support_NoDupA;auto.
+ + transitivity (length (on_SEC (support (!! config)))).
+ -- rewrite Hsec.
+ reflexivity.
+ -- unfold on_SEC.
+ rewrite filter_length.
+ changeR2.
+ lia.
+ - rewrite Htarget.
+ assumption. }
+
+ apply NoDupA_inclA_length_PermutationA; autoclass.
+ - apply support_NoDupA.
+ - transitivity (target (!! config) :: [ptx; pty; ptz]).
+ + rewrite <- H_supp.
+ now apply incl_next.
+ + apply inclA_Leibniz.
+ apply incl_cons.
+ * rewrite Htarget.
+ now apply InA_Leibniz.
+ * now apply inclA_Leibniz.
+ - rewrite size_spec in Hlen'.
+ apply Hlen'. }
+ rewrite Hperm'.
+ rewrite <- Hsec.
+ apply on_SEC_idempotent.
+ -- now apply dirty_next_on_SEC_same.
+
+ + (* Scalene case *)
+ assert (Htarget := scalene_target config Hsec Htriangle).
+ right. split; trivial.
+ (* TODO: the SEC has not changed, same thing? *)
+ destruct (is_clean (!! config)) eqn:Hclean.
+ -- destruct (moving gatherR2 da config) as [| gmove ?] eqn:Hmoving.
+ ++ apply no_moving_same_config in Hmoving.
+ ** now rewrite Hmoving.
+ ** auto using color_bivalent_bivalent.
+ ++
+ remember (opposite_of_max_side ptx pty ptz) as vertex.
+ assert (Hperm' : PermutationA equiv (support (!! (round gatherR2 da config)))
+ ([ptx; pty; ptz])).
+ { assert (forall x, List.In x (gmove :: l) -> get_location (round gatherR2 da config x) == vertex).
+ { rewrite <- Htarget.
+ intros x H3.
+ apply destination_is_target;auto.
+ rewrite Hmoving.
+ assumption. }
+ assert (h_vertex:=scalene_vertex_is_vertex _ _ _ Htriangle).
+ assert (H_supp: PermutationA equiv (support (!! config)) ([ptx; pty; ptz])).
+ { rewrite is_clean_spec in Hclean.
+ unfold SECT in Hclean.
+ rewrite Hsec in Hclean.
+ apply inclA_cons_InA in Hclean;autoclass;auto.
+ - apply NoDupA_inclA_length_PermutationA;autoclass.
+ + apply support_NoDupA;auto.
+ + transitivity (length (on_SEC (support (!! config)))).
+ -- now rewrite Hsec.
+ -- unfold on_SEC.
+ rewrite filter_length.
+ changeR2. lia.
+ - subst. now rewrite Htarget. }
+
+ apply NoDupA_inclA_length_PermutationA; autoclass.
+ - apply support_NoDupA.
+ - transitivity (target (!! config) :: [ptx; pty; ptz]).
+ + rewrite <- H_supp.
+ now apply incl_next.
+ + apply inclA_Leibniz.
+ apply incl_cons.
+ * subst.
+ rewrite Htarget.
+ now apply InA_Leibniz.
+ * now apply inclA_Leibniz.
+ - rewrite size_spec in Hlen'.
+ apply Hlen'. }
+ rewrite Hperm'.
+ rewrite <- Hsec.
+ apply on_SEC_idempotent.
+ -- now apply dirty_next_on_SEC_same.
+Qed.
+
+(** *** Lemmas about the generic case **)
+
+Lemma clean_generic_next_generic_same_SEC :
+ generic_case config ->
+ generic_case (round gatherR2 da config) ->
+ SEC (support (!! (round gatherR2 da config))) = SEC (support (!! config)).
+Proof using Hssync Hbivalent.
+intros Hcase Hcase'.
+destruct (is_clean (!! config)) eqn:Hclean; try (now destruct Hcase; apply dirty_next_SEC_same); [].
+assert (Hincl' := incl_clean_next Hclean).
+destruct Hcase' as [Hmaj' [pt1' [pt2' [pt3' [pt4' [l' Hperm']]]]]].
+(* These positions are different *)
+assert (Hnodup : NoDupA equiv (pt1' :: pt2' :: pt3' :: pt4' :: l')).
+{ rewrite <- Hperm'. apply on_SEC_NoDupA, support_NoDupA. }
+inv_nodup Hnodup.
+inversion_clear Hnodup. inversion_clear H0. inversion_clear H2.
+assert (Hneq12 : pt1' <> pt2') by intuition.
+assert (Hneq13 : pt1' <> pt3') by intuition.
+assert (Hneq14 : pt1' <> pt4') by intuition.
+assert (Hneq23 : pt2' <> pt3') by intuition.
+assert (Hneq24 : pt2' <> pt4') by intuition.
+assert (Hneq34 : pt3' <> pt4') by intuition.
+clear H H0 H1 H3.
+(* There are robots occupying these positions *)
+assert (Hid1 : exists id1, get_location (round gatherR2 da config id1) == pt1').
+{ change eq with (@equiv location _). rewrite <- obs_from_config_In, <- support_spec.
+ unfold on_SEC in Hperm'. eapply proj1. rewrite <- filter_InA, Hperm'; intuition. }
+assert (Hid2 : exists id2, get_location (round gatherR2 da config id2) == pt2').
+{ change eq with (@equiv location _). rewrite <- obs_from_config_In, <- support_spec.
+ unfold on_SEC in Hperm'. eapply proj1. rewrite <- filter_InA, Hperm'; intuition. }
+assert (Hid3 : exists id3, get_location (round gatherR2 da config id3) == pt3').
+{ change eq with (@equiv location _). rewrite <- obs_from_config_In, <- support_spec.
+ unfold on_SEC in Hperm'. eapply proj1. rewrite <- filter_InA, Hperm'; intuition. }
+assert (Hid4 : exists id4, get_location (round gatherR2 da config id4) == pt4').
+{ change eq with (@equiv location _). rewrite <- obs_from_config_In, <- support_spec.
+ unfold on_SEC in Hperm'. eapply proj1. rewrite <- filter_InA, Hperm'; intuition. }
+destruct Hid1 as [id1 Hid1], Hid2 as [id2 Hid2], Hid3 as [id3 Hid3], Hid4 as [id4 Hid4].
+hnf in Hid1, Hid2, Hid3, Hid4.
+destruct Hcase as [Hmaj _].
+rewrite (round_simplify_clean Hmaj Hclean id1) in Hid1.
+rewrite (round_simplify_clean Hmaj Hclean id2) in Hid2.
+rewrite (round_simplify_clean Hmaj Hclean id3) in Hid3.
+rewrite (round_simplify_clean Hmaj Hclean id4) in Hid4.
+(* These robots are different *)
+assert (Hneqid12 : id1 <> id2). { intro. subst id1. rewrite Hid1 in Hid2. contradiction. }
+assert (Hneqid13 : id1 <> id3). { intro. subst id1. rewrite Hid1 in Hid3. contradiction. }
+assert (Hneqid14 : id1 <> id4). { intro. subst id1. rewrite Hid1 in Hid4. contradiction. }
+assert (Hneqid23 : id2 <> id3). { intro. subst id2. rewrite Hid2 in Hid3. contradiction. }
+assert (Hneqid24 : id2 <> id4). { intro. subst id2. rewrite Hid2 in Hid4. contradiction. }
+assert (Hneqid34 : id3 <> id4). { intro. subst id3. rewrite Hid3 in Hid4. contradiction. }
+(* At most one of these robots was activated during the round *)
+assert (Hex : forall id id',
+ List.In id ([id1; id2; id3; id4]) -> List.In id' ([id1; id2; id3; id4]) ->
+ id <> id' -> da.(activate) id = true -> da.(activate) id' = false).
+{ intros id id' Hid Hid' Hneq Hactive. simpl in *.
+ destruct (da.(activate) id') eqn:Hactive'; trivial; exfalso.
+ decompose [or] Hid; decompose [or] Hid'; try subst id; try subst id';
+ (now elim Hneq) || rewrite Hactive in *; changeR2; rewrite Hactive' in *;
+ rewrite ?Hid1, ?Hid2, ?Hid3, ?Hid4 in *; cbn in *; congruence. }
+(* Therefore, at least three were not activated and not on the target *)
+assert (Hperm_id : exists id1' id2' id3' id4',
+ Permutation ([id1; id2; id3; id4]) ([id1'; id2'; id3'; id4'])
+ /\ da.(activate) id2' = false /\ da.(activate) id3' = false /\ da.(activate) id4' = false
+ /\ NoDup ([get_location (config id2'); get_location (config id3'); get_location (config id4')])
+ /\ get_location (config id2') <> target (!!config)
+ /\ get_location (config id3') <> target (!!config)
+ /\ get_location (config id4') <> target (!!config)).
+{ destruct (da.(activate) id1) eqn:Hactive1.
+ * exists id1, id2, id3, id4. split; trivial; [].
+ repeat split; try (now generalize Hactive1; apply Hex; intuition).
+ -- assert (Heq2 : da.(activate) id2 = false) by (generalize Hactive1; apply Hex; intuition).
+ assert (Heq3 : da.(activate) id3 = false) by (generalize Hactive1; apply Hex; intuition).
+ assert (Heq4 : da.(activate) id4 = false) by (generalize Hactive1; apply Hex; intuition).
+ rewrite Heq2, Heq3, Heq4 in *. clear Heq2 Heq3 Heq4. subst.
+ assert (Hnodup : NoDup (target (!! config) :: get_location (config id2)
+ :: get_location (config id3) :: get_location (config id4) :: l')).
+ { rewrite <- NoDupA_Leibniz. rewrite <- Hperm'. apply on_SEC_NoDupA, support_NoDupA. }
+ inversion_clear Hnodup. inversion_clear H0. inversion_clear H2. repeat constructor; cbn in *; intuition.
+ -- intro. apply Hneq12. rewrite (Hex id1 id2) in Hid2; trivial; subst; intuition.
+ -- intro. apply Hneq13. rewrite (Hex id1 id3) in Hid3; trivial; subst; intuition.
+ -- intro. apply Hneq14. rewrite (Hex id1 id4) in Hid4; trivial; subst; intuition.
+ * destruct (da.(activate) id2) eqn:Hactive2.
+ + exists id2, id1, id3, id4. split; [now do 3 econstructor|].
+ repeat split; try now generalize Hactive2; apply Hex; intuition.
+ -- assert (Heq1 : da.(activate) id1 = false) by (generalize Hactive2; apply Hex; intuition).
+ assert (Heq3 : da.(activate) id3 = false) by (generalize Hactive2; apply Hex; intuition).
+ assert (Heq4 : da.(activate) id4 = false) by (generalize Hactive2; apply Hex; intuition).
+ rewrite Heq1, Heq3, Heq4 in *. clear Heq1 Heq3 Heq4. subst.
+ assert (Hnodup : NoDup (get_location (config id1) :: target (!! config)
+ :: get_location (config id3) :: get_location (config id4) :: l')).
+ { rewrite <- NoDupA_Leibniz. rewrite <- Hperm'. apply on_SEC_NoDupA, support_NoDupA. }
+ inversion_clear Hnodup. inversion_clear H0. inversion_clear H2. repeat constructor; cbn in *; intuition.
+ -- intro. apply Hneq12. now subst.
+ -- intro. apply Hneq23. rewrite (Hex id2 id3) in Hid3; trivial; subst; intuition.
+ -- intro. apply Hneq24. rewrite (Hex id2 id4) in Hid4; trivial; subst; intuition.
+ + destruct (da.(activate) id3) eqn:Hactive3.
+ - exists id3, id1, id2, id4. split; [now do 3 econstructor|].
+ repeat split; try now generalize Hactive3; apply Hex; intuition.
+ -- assert (Heq1 : da.(activate) id1 = false) by (generalize Hactive3; apply Hex; intuition).
+ assert (Heq2 : da.(activate) id2 = false) by (generalize Hactive3; apply Hex; intuition).
+ assert (Heq4 : da.(activate) id4 = false) by (generalize Hactive3; apply Hex; intuition).
+ rewrite Heq1, Heq2, Heq4 in *. clear Heq1 Heq2 Heq4. subst.
+ assert (Hnodup : NoDup (get_location (config id1) :: get_location (config id2)
+ :: target (!! config) :: get_location (config id4) :: l')).
+ { rewrite <- NoDupA_Leibniz. rewrite <- Hperm'. apply on_SEC_NoDupA, support_NoDupA. }
+ inversion_clear Hnodup. inversion_clear H0. inversion_clear H2. repeat constructor; cbn in *; intuition.
+ -- intro. apply Hneq13. now subst.
+ -- intro. apply Hneq23. now subst.
+ -- intro. apply Hneq34. rewrite (Hex id3 id4) in Hid4; trivial; subst; intuition.
+ - destruct (da.(activate) id4) eqn:Hactive4.
+ ** exists id4, id1, id2, id3. repeat split; trivial; [now do 4 econstructor| ..]; try (now subst); [].
+ subst. repeat constructor; cbn in *; intuition.
+ ** destruct (get_location (config id1) =?= target (!! config)) as [Heq1 | Heq1].
+ ++ exists id1, id2, id3, id4. rewrite <- Heq1. subst. repeat split; trivial; intuition; [].
+ repeat constructor; cbn in *; intuition.
+ ++ destruct (get_location (config id2) =?= target (!! config)) as [Heq2 | Heq2].
+ -- exists id2, id1, id3, id4. subst.
+ repeat split; trivial; try rewrite <- Heq2;
+ solve [repeat constructor; cbn in *; intuition | now do 3 econstructor].
+ -- destruct (get_location (config id3) =?= target (!! config)) as [Heq3 | Heq3].
+ *** exists id3, id1, id2, id4. subst.
+ repeat split; trivial; try rewrite <- Heq3;
+ solve [repeat constructor; cbn in *; intuition | now do 3 econstructor].
+ *** exists id4, id1, id2, id3. subst.
+ repeat split; trivial;
+ solve [repeat constructor; cbn in *; intuition | now do 4 econstructor]. }
+(* Finally, the old and new SEC are defined by the unchanging locations of these three robots *)
+destruct Hperm_id as [id1' [id2' [id3' [id4' [Hperm_id [Hactive2' [Hactive3' [Hactive4' [Hnodup [? [? ?]]]]]]]]]]].
+apply three_points_same_circle
+ with (get_location (config id2')) (get_location (config id3')) (get_location (config id4')).
++ assumption.
++ eapply proj2. rewrite <- (filter_InA _).
+ assert (Hin : List.In id2' ([id1; id2; id3; id4])) by (rewrite Hperm_id; intuition).
+ simpl in Hin. unfold on_SEC in Hperm'. rewrite Hperm'.
+ decompose [or] Hin; subst id2' || easy; clear Hin; rewrite Hactive2' in *; subst; intuition.
++ eapply proj2. rewrite <- (filter_InA _).
+ assert (Hin : List.In id3' ([id1; id2; id3; id4])) by (rewrite Hperm_id; intuition).
+ simpl in Hin. unfold on_SEC in Hperm'. rewrite Hperm'.
+ decompose [or] Hin; subst id3' || easy; clear Hin; rewrite Hactive3' in *; subst; intuition.
++ eapply proj2. rewrite <- (filter_InA _).
+ assert (Hin : List.In id4' ([id1; id2; id3; id4])) by (rewrite Hperm_id; intuition).
+ simpl in Hin. unfold on_SEC in Hperm'. rewrite Hperm'.
+ decompose [or] Hin; subst id4' || easy; clear Hin; rewrite Hactive4' in *; subst; intuition.
++ assert (Hin : InA equiv (get_location (config id2')) (support (!! config))).
+ { rewrite support_spec. apply pos_in_config. }
+ rewrite is_clean_spec in Hclean. apply Hclean in Hin. inversion_clear Hin; try contradiction; [].
+ unfold on_SEC in H2. now rewrite (filter_InA _) in H2.
++ assert (Hin : InA equiv (get_location (config id3')) (support (!! config))).
+ { rewrite support_spec. apply pos_in_config. }
+ rewrite is_clean_spec in Hclean. apply Hclean in Hin. inversion_clear Hin; try contradiction; [].
+ unfold on_SEC in H2. now rewrite (filter_InA _) in H2.
++ assert (Hin : InA equiv (get_location (config id4')) (support (!! config))).
+ { rewrite support_spec. apply pos_in_config. }
+ rewrite is_clean_spec in Hclean. apply Hclean in Hin. inversion_clear Hin; try contradiction; [].
+ unfold on_SEC in H2. now rewrite (filter_InA _) in H2.
+Qed.
+
+Lemma clean_generic_next_generic_same_target_and_clean :
+ generic_case config ->
+ is_clean (!! config) = true ->
+ generic_case (round gatherR2 da config) ->
+ is_clean (!! (round gatherR2 da config)) = true
+ /\ target (!! (round gatherR2 da config)) = target (!! config).
+Proof using Hssync Hbivalent.
+intros Hcase Hclean Hcase'.
+assert (HSEC := clean_generic_next_generic_same_SEC Hcase Hcase').
+assert (Hincl' := incl_clean_next Hclean).
+rewrite is_clean_spec.
+assert (Htarget : target (!! (round gatherR2 da config)) = target (!! config)).
+{ do 2 (rewrite generic_target; trivial). now rewrite HSEC. }
+split; trivial.
+intros pt Hin. unfold SECT. rewrite Htarget. unfold on_SEC. rewrite HSEC.
+assert (Hpt := Hincl' _ Hin). unfold on_SEC in Hpt. inversion_clear Hpt.
+- now left.
+- right. rewrite (filter_InA _). split; trivial; []. now rewrite (filter_InA _) in H.
+Qed.
+
+(** ** Main result for termination: the measure decreases after a step where a robot moves *)
+
+Theorem non_bivalent_round_lt_config :
+ moving gatherR2 da config <> nil ->
+ lt_config (round gatherR2 da config) config.
+Proof using Hssync Hbivalent.
+ intros Hmove. unfold lt_config.
+ unfold measure. change n with nG in *.
+ assert (Heq : bivalent_obs (!!! (config, (origin,witness))) = false).
+ { apply not_true_is_false. rewrite bivalent_obs_spec; autoclass; lia. }
+ assert (Heq' : bivalent_obs (!!! (round gatherR2 da config, (origin,witness))) = false).
+ { apply not_true_is_false. rewrite bivalent_obs_spec; autoclass; try lia; []. now apply never_bivalent. }
+ rewrite Heq, Heq'. unfold old_measure at 2.
+ assert (strong_obs_fst : forall config st, !! config = fst (!!!(config, st))) by reflexivity.
+ destruct (support (max (fst (!!! (config, (origin, witness)))))) as [| pt [| pt' smax]] eqn:Hmax.
+ - (* No robots *)
+ rewrite support_nil, max_is_empty in Hmax. elim (obs_non_nil _ Hmax).
+ - (* A majority tower *)
+ rewrite <- strong_obs_fst in Hmax. get_case config.
+ apply MajTower_at_forever in Hcase.
+ rewrite MajTower_at_equiv in Hcase.
+ assert (Hcase' : support (max (fst (!!! (round gatherR2 da config, (origin, witness))))) = [pt])
+ by now rewrite <- strong_obs_fst.
+ unfold old_measure. rewrite Hcase', <- 2 strong_obs_fst.
+ right.
+ assert (Hle := multiplicity_le_nG pt (round gatherR2 da config)).
+ cut ((!! config)[pt] < (!! (round gatherR2 da config))[pt]); try lia; [].
+ apply not_nil_In in Hmove. destruct Hmove as [gmove Hmove].
+ assert (Hactive : da.(activate) gmove = true).
+ { apply moving_active in Hmove; trivial; []. now rewrite active_spec in Hmove. }
+ rewrite moving_spec in Hmove.
+ rewrite (increase_move_iff Hssync non_bivalent_same_destination); trivial; [].
+ exists gmove.
+ split.
+ + get_case config.
+ rewrite (round_simplify_Majority Hcase0 gmove).
+ destruct (da.(activate) gmove); try reflexivity; []. now elim Hactive.
+ + intros Habs. apply Hmove. apply no_info; trivial; []. now apply round_simplify_Lights.
+ - (* Computing the SEC *)
+ rewrite <- strong_obs_fst in Hmax. get_case config. clear Hmax pt pt' smax.
+ destruct (is_clean (fst (!!! (config, (origin, witness))))) eqn:Hclean;
+ rewrite <- strong_obs_fst in Hclean.
+ (* Clean case *)
+ + assert (Hle := no_Majority_on_SEC_length Hmaj).
+ destruct (on_SEC (support (fst (!!! (config, (origin, witness))))))
+ as [| pt1 [| pt2 [| pt3 [| pt4 sec]]]] eqn:Hsec;
+ rewrite <- strong_obs_fst in *; rewrite Hsec in *; cbn in Hle; try lia; [| |].
+ * (* Diameter case *)
+ assert (Htarget : target (!! config) = middle pt1 pt2) by now apply diameter_target.
+ assert (Hperm := diameter_clean_support Hbivalent Hmaj Hclean Hsec).
+ destruct (clean_diameter_next_maj_or_diameter Hmaj Hclean Hsec)
+ as [[pt Hmaj'] | [Hmaj' HpermSEC']].
+ -- (* A majority is present after one round *)
+ unfold old_measure.
+ rewrite MajTower_at_equiv in Hmaj'.
+ rewrite Hmaj'.
+ left. lia.
+ -- (* Still in a diameter case after one round *)
+ assert (Hperm' := diameter_round_same Hmaj' Hperm).
+ assert (Hcase : clean_diameter_case config).
+ { repeat split; trivial; setoid_rewrite Hsec; do 2 eexists; reflexivity. }
+ assert (Htarget' := diameter_next_target_same Hcase Hmaj').
+ rewrite no_Majority_equiv in Hmaj'.
+ destruct Hmaj' as [? [? [? Hmaj']]].
+ unfold old_measure. rewrite Hmaj'.
+ assert (Hlen' : length (on_SEC (support (!! (round gatherR2 da config)))) = 2).
+ { now rewrite HpermSEC'. }
+ destruct (on_SEC (support (!! (round gatherR2 da config)))) as [| ? [| ? [| ? ?]]] eqn:Hsec';
+ cbn in Hlen'; lia || clear Hlen'.
+ assert (Hclean' : is_clean (!! (round gatherR2 da config)) = true).
+ { rewrite is_clean_spec. unfold SECT. now rewrite Hsec', HpermSEC', Hperm', Htarget', Htarget. }
+ rewrite Hclean'.
+ right.
+ now apply solve_measure_clean.
+ * (* Triangle cases *)
+ get_case config.
+ assert (HnextSEC := triangle_next_maj_or_diameter_or_triangle Hcase).
+ rewrite Hsec in HnextSEC.
+ destruct HnextSEC as [HnextSEC | [[Hmaj' [Htriangle [Hlen [Hclean' Hincl]]]] | [Hmaj' HpermSEC']]].
+ -- (* There is a majority tower on the next round *)
+ unfold old_measure.
+ destruct (support (max (!! (round gatherR2 da config)))) as [| ? [| ? ?]];
+ cbn in HnextSEC; try discriminate.
+ destruct (classify_triangle pt1 pt2 pt3); left; lia.
+ -- (* Equilateral case with the SEC changing *)
+ unfold old_measure.
+ assert (Hmax' := Hmaj'). rewrite no_Majority_equiv in Hmax'.
+ destruct Hmax' as [? [? [? Hmax']]]. rewrite Hmax'.
+ destruct (on_SEC (support (!! (round gatherR2 da config)))) as [| ? [| ? [| ? ?]]];
+ cbn in Hlen; lia || clear Hlen.
+ rewrite Hclean'.
+ left. lia.
+ -- (* Still the same triangle after one round *)
+ unfold old_measure.
+ assert (Hmax' := Hmaj'). rewrite no_Majority_equiv in Hmax'.
+ destruct Hmax' as [? [? [? Hmax']]]. rewrite Hmax'.
+ assert (Hlen' : length (on_SEC (support (!! (round gatherR2 da config)))) = 3)
+ by now rewrite HpermSEC'.
+ destruct (on_SEC (support (!! (round gatherR2 da config))))
+ as [| ? [| ? [| ? [| ? ?]]]] eqn:Hsec';
+ cbn in Hlen'; lia || clear Hlen'.
+ assert (Htarget' : target (!! (round gatherR2 da config)) = target (!! config)).
+ { apply same_on_SEC_same_target. now rewrite Hsec, Hsec'. }
+ assert (Hclean' : is_clean (!! (round gatherR2 da config)) = true).
+ { assert (Hincl' := incl_clean_next Hclean).
+ rewrite is_clean_spec. unfold SECT.
+ now rewrite Hsec', HpermSEC', <- Hsec, Htarget'. }
+ rewrite Hclean'.
+ right.
+ now apply solve_measure_clean.
+ * (* Generic case *)
+ unfold old_measure.
+ destruct (support (max (!! (round gatherR2 da config)))) as [| pt [| ? ?]] eqn:Hmax';
+ try (now left; lia); [].
+ get_case config.
+ get_case (round gatherR2 da config).
+ destruct (on_SEC (support (!! (round gatherR2 da config))))
+ as [| pt1' [| pt2' [| pt3' [| pt4' ?]]]] eqn:Hsec';
+ try (now destruct (is_clean (!! (round gatherR2 da config))); left; lia); [].
+ (* Still in the generic case after one round *)
+ get_case (round gatherR2 da config).
+ assert (Hgeneric := clean_generic_next_generic_same_target_and_clean Hcase Hclean Hcase0).
+ destruct Hgeneric as [Hclean' Htarget'].
+ rewrite Hclean'.
+ right.
+ now apply solve_measure_clean.
+ (* Dirty case *)
+ + assert (HsameSEC := dirty_next_on_SEC_same Hmaj Hclean).
+ assert (Hle := no_Majority_on_SEC_length Hmaj).
+ unfold old_measure.
+ destruct (support (max (fst (!!! (round gatherR2 da config, (origin, witness))))))
+ as [| ? [| ? ?]] eqn:Hmax'.
+ * (* Absurd: no robot after one round *)
+ rewrite support_nil, max_is_empty in Hmax'. elim (obs_non_nil _ Hmax').
+ * (* A majority tower after one round *)
+ rewrite (strong_obs_fst _ (origin, witness)) in Hle.
+ destruct (on_SEC (support (fst (!!! (config, (origin, witness)))))) as [| ? [| ? [| ? [| ? ?]]]];
+ cbn in Hle; lia || left; lia.
+ * (* Still no majority tower after one round *)
+ repeat rewrite <- strong_obs_fst in *.
+ get_case (round gatherR2 da config). rename Hmaj0 into Hmaj'.
+ assert (Hle' := no_Majority_on_SEC_length Hmaj').
+ assert (Hlen := PermutationA_length HsameSEC).
+ destruct (on_SEC (support (!! config))) as [| ? [| ? [| ? [| ? ?]]]] eqn:Hsec,
+ (on_SEC (support (!! (round gatherR2 da config)))) as [| ? [| ? [| ? [| ? ?]]]] eqn:Hsec';
+ cbn in Hle, Hle', Hlen; try lia; [| |];
+ destruct (is_clean (!! (round gatherR2 da config))) eqn:Hclean';
+ try solve [ left; lia | right; now apply solve_measure_dirty ].
+Qed.
+
+End NonBivalent.
+End SSYNC_Results.
+
+Theorem round_lt_config : forall da config, SSYNC_da da ->
+ changing gatherR2 da config <> nil ->
+ lt_config (round gatherR2 da config) config.
+Proof using .
+intros da config Hssync.
+destruct (bivalent_dec config) as [Hbivalent | Hbivalent].
+* intro Hmove.
+ destruct (color_bivalent_dec config) as [Hcolor | Hcolor].
+ + now apply color_bivalent_round_lt_config.
+ + rewrite changing_eq_moving in Hmove; trivial; [].
+ destruct (not_color_bivalent_next da Hssync Hbivalent) as [pt Hmaj]; trivial; [].
+ unfold lt_config, measure.
+ assert (Hbivalent' : ~ bivalent (round gatherR2 da config)).
+ { apply (Majority_not_bivalent Hmaj). }
+ rewrite <- bivalent_obs_spec in Hbivalent, Hbivalent'.
+ rewrite <- color_bivalent_obs_spec in Hcolor.
+ rewrite not_true_iff_false in Hbivalent', Hcolor.
+ rewrite Hbivalent, Hbivalent', Hcolor.
+ unfold old_measure.
+ rewrite MajTower_at_equiv in Hmaj.
+ assert (Hsupp : PermutationA equiv (support (max (!! (round gatherR2 da config)))) (cons pt nil)).
+ { now rewrite Hmaj. }
+ rewrite obs_fst in Hsupp.
+ changeR2. apply PermutationA_length1 in Hsupp; autoclass; [].
+ destruct Hsupp as [pt' [Hpt' Hsupp]]. rewrite Hsupp.
+ left. lia.
+* rewrite changing_eq_moving.
+ + now apply non_bivalent_round_lt_config.
+ + assumption.
+ + intro Habs. apply Hbivalent. now apply color_bivalent_bivalent.
+Qed.
+
+(* destination is independent from the demonic_action. This replace
+ the same_destination inside previous section. *)
+Corollary same_destination_strong : forall da da' (config : configuration) id1 id2,
+ ~ bivalent config ->
+ SSYNC_da da -> SSYNC_da da' ->
+ List.In id1 (moving gatherR2 da config) ->
+ List.In id2 (moving gatherR2 da' config) ->
+ get_location (round gatherR2 da config id1) == get_location (round gatherR2 da' config id2).
+Proof using Type.
+intros da da' config id1 id2 Hbivalent hss hss' Hmove1 Hmove2. changeR2.
+change (@equiv _ (@robot_choice_Setoid _ RobotChoice)) with (@equiv _ state_Setoid).
+destruct (le_lt_dec 2 (length (support (max (!! config))))) as [Hle |Hlt].
++ assert (no_Majority config). { unfold no_Majority. now rewrite size_spec. }
+ now repeat rewrite destination_is_target.
++ rewrite moving_spec in Hmove1, Hmove2.
+ rewrite (round_simplify_non_bivalent da hss Hbivalent id1) in Hmove1 |- *.
+ rewrite (round_simplify_non_bivalent da' hss' Hbivalent id2) in Hmove2 |- *.
+ destruct (da.(activate) id1), (da'.(activate) id2);
+ try (now elim Hmove1 + elim Hmove2); [].
+ cbn zeta in *.
+ destruct_match; [| destruct_match].
+ - now elim Hmove1.
+ - reflexivity.
+ - simpl in Hlt. lia.
+Qed.
+
+
+(** *** With termination, the rest of the proof is easy **)
+
+Lemma gathered_precise : forall config pt,
+ gathered_at pt config -> forall id, gathered_at (get_location (config id)) config.
+Proof using size_G.
+intros config pt Hgather id g'. transitivity pt.
+- apply Hgather.
+- pattern id. apply no_byz. clear id. intro g. symmetry. apply Hgather.
+Qed.
+
+Corollary not_gathered_generalize : forall config id,
+ ~gathered_at (get_location (config id)) config -> forall pt, ~gathered_at pt config.
+Proof using size_G. 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, get_location (config id) =/= pt.
+Proof using .
+intros config pt Hgather.
+destruct (forallb (fun x => if get_location (config x) =?= pt then true else false) names) eqn:Hall.
+- elim Hgather. rewrite forallb_forall in Hall.
+ intro id'. setoid_rewrite R2dec_bool_true_iff in Hall. repeat rewrite Hall; reflexivity || apply In_names.
+- rewrite <- negb_true_iff, existsb_forallb, existsb_exists in Hall.
+ destruct Hall as [id' [_ Hid']]. revert Hid'. destruct_match; discriminate || now exists id'.
+Qed.
+
+(** Correctness proof: given a non-gathered, non-bivalent configuration, then some robot will change some day. *)
+Theorem OneMustChange : forall config id,
+ ~gathered_at (get_location (config id)) config ->
+ exists gmove, forall da, SSYNC_da da -> List.In gmove (active da) -> List.In gmove (changing gatherR2 da config).
+Proof using .
+intros config id Hgather.
+destruct (bivalent_dec config) as [Hbivalent | Hbivalent].
+* destruct (color_bivalent_dec config) as [Hcolor | Hcolor].
+ + (* Color bivalent case: every activated robot either moves or changes its color *)
+ exists (Good g1). intros da Hssync Hactive.
+ rewrite changing_spec, (round_simplify_color_bivalent da Hssync Hcolor (Good g1)).
+ cbn zeta.
+ set (pt := (get_location (config (Good g1)))).
+ set (obs := !!! (config, config (Good g1))).
+ set (pt' := find_other_loc (fst obs) pt).
+ rewrite active_spec in Hactive. rewrite Hactive.
+ destruct_match_eq Hlight.
+ - assert (Hdiff : pt' =/= pt).
+ { apply find_other_loc_diff.
+ - unfold obs. now rewrite bivalent_obs_spec.
+ - apply pos_in_config. }
+ apply middle_diff in Hdiff. rewrite InA_cons, InA_singleton in Hdiff.
+ rewrite middle_comm. intro Habs. apply Hdiff. right. apply Habs.
+ - unfold obs in *. setoid_rewrite observer_light_get_light in Hlight.
+ intro Habs. rewrite <- Habs in *. discriminate.
+ + (* Bivalent case: Robots not on the blackest tower try to reach it *)
+ destruct (find_max_black_either (!!! (config, (origin, witness))) (loc_g1 config) (loc_others config))
+ as [Hmax | Hmax].
+ - (* g1 is on the blackest tower, so we use the other one *)
+ assert (Hin2 : In (loc_others config) (!! config)). { now apply loc_others_In. }
+ rewrite obs_from_config_In in Hin2. destruct Hin2 as [gmove Hgmove].
+ exists gmove. intros da Hssync Hactive.
+ assert (Htarget : get_location (round gatherR2 da config gmove) == loc_g1 config).
+ { now rewrite not_color_bivalent_target. }
+ apply moving_changing; auto; [].
+ rewrite moving_spec, Htarget, Hgmove.
+ now apply loc_g1_diff_others. (* auto should work here *)
+ - (* Symmetrical case: g1 is not on the blackest tower, so we can use it *)
+ pose (gmove := Good g1).
+ exists gmove. intros da Hssync Hactive.
+ assert (Htarget : get_location (round gatherR2 da config gmove) == loc_others config).
+ { now rewrite not_color_bivalent_target. }
+ apply moving_changing; auto; [].
+ rewrite moving_spec, Htarget.
+ now apply loc_others_diff_g1.
+* destruct (support (max (!! config))) as [| pt [| pt' lmax]] eqn:Hmax.
+ + elim (support_max_non_nil _ Hmax).
+ + rewrite <- MajTower_at_equiv in Hmax.
+ apply not_gathered_generalize with _ _ pt in Hgather.
+ apply not_gathered_exists in Hgather. destruct Hgather as [gmove Hmove].
+ exists gmove. intros da Hda Hactive. rewrite active_spec in Hactive. rewrite changing_spec.
+ rewrite (round_simplify_Majority _ Hda Hmax gmove).
+ destruct_match.
+ - intro Habs. apply Hmove. now rewrite <- Habs.
+ - now elim Hactive.
+ + (* No majority tower *)
+ get_case config.
+ destruct (is_clean (!! config)) eqn:Hclean.
+ - (* clean case *)
+ apply not_gathered_generalize with _ _ (target (!! config)) in Hgather.
+ apply not_gathered_exists in Hgather. destruct Hgather as [gmove Hmove].
+ exists gmove. intros da Hda Hactive. rewrite active_spec in Hactive.
+ rewrite changing_spec, (round_simplify_clean da Hda Hbivalent Hmaj Hclean gmove), Hactive.
+ intro Habs. apply Hmove. rewrite <- Habs. reflexivity.
+ - (* dirty case *)
+ assert (Hclean' := Hclean). unfold is_clean in Hclean'. clear Hmax pt pt' lmax.
+ destruct (inclA_bool _ equiv_dec (support (!! config)) (SECT (!! config))) eqn:Hincl;
+ try discriminate; [].
+ rewrite inclA_bool_false_iff, (not_inclA _ equiv_dec) in Hincl.
+ destruct Hincl as [pt [Hin Hin']].
+ rewrite support_spec, obs_from_config_In in Hin.
+ destruct Hin as [gmove Hmove].
+ exists gmove. intros da Hda Hactive. rewrite active_spec in Hactive. rewrite changing_spec.
+ rewrite (round_simplify_dirty da Hda Hbivalent Hmaj Hclean gmove).
+ destruct (da.(activate) gmove); try (now elim Hactive); [].
+ destruct (mem equiv_dec (get_location (config gmove)) (SECT (!! config))) eqn:Htest.
+ -- rewrite mem_true_iff, Hmove in Htest.
+ contradiction.
+ -- rewrite mem_false_iff, Hmove in Htest.
+ assert (Htarget : InA equiv (target (!! config)) (SECT (!! config))) by now left.
+ intro Habs. rewrite <- Habs, Hmove in *.
+ contradiction.
+Qed.
+
+(** Given a k-fair demon, in any non-gathered, non-bivalent configuration, a robot will be the first to move. *)
+Theorem Fair_FirstChange : forall d, SSYNC (similarity_demon2demon d) -> Fair d ->
+ forall config id, ~gathered_at (get_location (config id)) config -> FirstChange gatherR2 d config.
+Proof using .
+intro d. generalize (similarity_demon2prop d).
+generalize (similarity_demon2demon d). clear d.
+intros d Hprop Hssync [locallyfair Hfair] config id Hgathered.
+destruct (OneMustChange id Hgathered) as [gmove Hmove].
+specialize (locallyfair gmove).
+revert config Hgathered Hmove Hfair.
+induction locallyfair as [d Hactive | d]; intros config Hgathered Hmove Hfair.
++ apply ChangeNow. intro Habs. simpl in Hactive. destruct Hssync.
+ rewrite <- active_spec, <- (demon2demon Hprop) in Hactive.
+ apply Hmove in Hactive; trivial; []. rewrite demon2similarity_hd in Hactive.
+ simpl in Hactive. changeR2. rewrite Habs in Hactive. inv Hactive.
++ destruct (changing gatherR2 (Stream.hd d) config) eqn:Hnil.
+ - apply ChangeLater; try exact Hnil; [].
+ destruct Hprop, Hssync, Hfair.
+ rewrite (no_changing_same_config gatherR2 (Stream.hd d) config Hnil).
+ destruct Hprop, Hssync, Hfair.
+ now apply IHlocallyfair.
+ - apply ChangeNow. rewrite Hnil. discriminate.
+Qed.
+
+Lemma gathered_at_forever : forall da config pt, SSYNC_da da ->
+ gathered_at pt config -> gathered_at pt (round gatherR2 da config).
+Proof using .
+intros da config pt Hssync Hgather. rewrite (round_simplify_Majority).
++ intro g. destruct (da.(activate) (Good g)); reflexivity || apply Hgather.
++ assumption.
++ intros pt' Hdiff.
+ assert (H0 : (!! config)[pt'] = 0%nat).
+ { setoid_rewrite WithMultiplicityLight.obs_from_config_fst_spec.
+ 2:{ try exact (origin,witness). }
+ rewrite config_list_spec.
+ induction names as [| id l].
+ + reflexivity.
+ + cbn -[equiv_dec]. destruct_match.
+ - elim Hdiff. hnf in *. subst pt'. pattern id. apply no_byz. intro g. apply Hgather.
+ - apply IHl. }
+ rewrite H0. specialize (Hgather g1). rewrite <- Hgather. apply pos_in_config.
+Qed.
+
+Lemma gathered_at_OK : forall d config pt, SSYNC (similarity_demon2demon d) ->
+ gathered_at pt config -> Gather pt (execute gatherR2 d config).
+Proof using .
+cofix Hind. intros d config pt Hssync Hgather. constructor.
++ clear Hind. simpl. assumption.
++ rewrite execute_tail. destruct Hssync. apply Hind; now try apply gathered_at_forever.
+Qed.
+
+(** The final theorem. *)
+Theorem Gathering_in_R2 : forall d : similarity_demon,
+ SSYNC (d : demon) -> Fair d -> FullSolGathering gatherR2 d.
+Proof using .
+intro d. generalize (similarity_demon2prop d).
+generalize (similarity_demon2demon d). clear d.
+intros d Hprop Hssync Hfair config.
+revert d Hprop Hssync Hfair. pattern config.
+apply (well_founded_ind wf_lt_config). clear config.
+intros config Hind d' Hprop Hssync Hfair.
+(* Are we already gathered? *)
+destruct (gathered_at_dec config (get_location (config (Good g1)))) as [Hmove | Hmove].
+* (* If so, not much to do *)
+ apply Stream.Now. exists (get_location (config (Good g1))).
+ rewrite <- (demon2demon Hprop) in Hssync |- *. now apply gathered_at_OK.
+* (* If not, we need to make an induction on fairness to find the first robot changing *)
+ rewrite <- (demon2demon Hprop) in Hssync, Hfair.
+ apply (Fair_FirstChange _ Hssync Hfair (Good g1)) in Hmove; trivial; [].
+ rewrite (demon2demon Hprop) in Hfair, Hmove.
+ destruct Hssync as [Hnow Hssync]. cbn in Hnow.
+ induction Hmove as [d config Hmove | d config Heq Hmove Hrec].
+ + (* Base case: we have first change, we can use our well-founded induction hypothesis. *)
+ apply Stream.Later. apply Hind.
+ - rewrite <- (demon2demon Hprop). now apply round_lt_config.
+ - now destruct Hprop.
+ - now rewrite <- (demon2demon Hprop).
+ - now destruct Hfair.
+ + (* Inductive case: we know by induction hypothesis that the wait will end *)
+ changeR2. apply no_changing_same_config in Heq.
+ apply Stream.Later. eapply Hrec.
+ - intros ? Hlt. apply Hind. eapply lt_config_compat; try eassumption; autoclass.
+ - now destruct Hssync.
+ - apply Hssync.
+ - now destruct Hfair.
+Qed.
+
+
+End GatheringInR2.
+
+(* We prefer calling this from another file, see Algorithm_withLight_ASsumptions.v. *)
+(* Print Assumptions Gathering_in_R2. *)
diff --git a/CaseStudies/Gathering/InR2/Algorithm_withLight_Assumptions.v b/CaseStudies/Gathering/InR2/Algorithm_withLight_Assumptions.v
new file mode 100644
index 0000000000000000000000000000000000000000..fb7e777e87409836d2e01111551e21e2689a4ae6
--- /dev/null
+++ b/CaseStudies/Gathering/InR2/Algorithm_withLight_Assumptions.v
@@ -0,0 +1,2 @@
+Require Pactole.CaseStudies.Gathering.InR2.Algorithm_withLight.
+Print Assumptions InR2.Algorithm_withLight.Gathering_in_R2.
diff --git a/CaseStudies/Gathering/InR2/Viglietta.v b/CaseStudies/Gathering/InR2/Viglietta.v
index fac80ea1d715e1461deb24dd767be53ec83f4c52..5189d4e7c220bc3e90bea0ca468ff52f71855a9b 100644
--- a/CaseStudies/Gathering/InR2/Viglietta.v
+++ b/CaseStudies/Gathering/InR2/Viglietta.v
@@ -261,7 +261,7 @@ Qed.
(* A result ensuring that the measure strictly decreases after each round. *)
Lemma round_measure : forall da config, similarity_da_prop da ->
- moving rendezvous da config <> nil ->
+ changing rendezvous da config <> nil ->
(exists pt, gathered_at pt (round rendezvous da config))
\/ measure (round rendezvous da config) < measure config.
Proof using .
@@ -274,8 +274,8 @@ destruct (gathered_at_dec config (get_location (config (Good r0)))) as [| Hgathe
* right. rewrite round_simplify; trivial; [].
assert (Hone_active : activate da (Good r0) = true \/ activate da (Good r1) = true).
{ destruct (activate da (Good r0)) eqn:Hr0, (activate da (Good r1)) eqn:Hr1; auto; [].
- contradiction Hmove. apply incl_nil. cut (active da = nil).
- - intro Hactive. rewrite <- Hactive. apply moving_active.
+ elim Hmove. apply incl_nil. cut (active da = nil).
+ - intro Hactive. rewrite <- Hactive. apply changing_active.
intros id Hid config'. reflexivity.
- unfold active, names. simpl.
assert (Hid : forall id, activate da id = false).
@@ -318,8 +318,8 @@ destruct (gathered_at_dec config (get_location (config (Good r0)))) as [| Hgathe
assert (Hmove2 : round rendezvous da config (Good r1) == config (Good r1)).
{ rewrite (round_simplify da config Hda (Good r1)).
destruct_match; reflexivity || now rewrite Hr1, Hobs2. }
- assert (Hmoving := moving_spec rendezvous da config).
- destruct (moving rendezvous da config) as [| id ?]; trivial; exfalso; [].
+ assert (Hmoving := changing_spec rendezvous da config).
+ destruct (changing rendezvous da config) as [| id ?]; trivial; exfalso; [].
specialize (Hmoving id). apply proj1 in Hmoving. specialize (Hmoving ltac:(now left)).
destruct (id_case id); subst id; contradiction. }
exfalso. apply Hgather'. intro g.
@@ -337,8 +337,8 @@ destruct (gathered_at_dec config (get_location (config (Good r0)))) as [| Hgathe
destruct_match; reflexivity || now rewrite Hr0, Hobs1. }
assert (Hmove2 : round rendezvous da config (Good r1) == config (Good r1)).
{ unfold round. rewrite Hactive2. reflexivity. }
- assert (Hmoving := moving_spec rendezvous da config).
- destruct (moving rendezvous da config) as [| id ?]; trivial; exfalso; [].
+ assert (Hmoving := changing_spec rendezvous da config).
+ destruct (changing rendezvous da config) as [| id ?]; trivial; exfalso; [].
specialize (Hmoving id). apply proj1 in Hmoving. specialize (Hmoving ltac:(now left)).
destruct (id_case id); subst id; contradiction. }
exfalso. apply Hgather'. intro g.
@@ -349,16 +349,11 @@ destruct (gathered_at_dec config (get_location (config (Good r0)))) as [| Hgathe
now destruct_match.
+ (* both robots have color B, hence measure config = 3 *)
destruct (activate da (Good r0)) eqn:Hactive1,
- (activate da (Good r1)) eqn:Hactive2; simpl.
- -- try lia.
- -- try lia.
- -- try lia.
- -- (* in coq8.13 lia also solves this. *)
- destruct Hone_active; discriminate.
+ (activate da (Good r1)) eqn:Hactive2; simpl; lia.
Qed.
(** Fairness entails progress. *)
-Lemma OneMustMove : forall config, ~(exists pt, gathered_at pt config) ->
+Lemma OneMustChange : forall config, ~(exists pt, gathered_at pt config) ->
exists r, forall da, similarity_da_prop da -> activate da r = true ->
round rendezvous da config r =/= config r.
Proof using .
@@ -400,31 +395,31 @@ destruct l1 eqn:Hl1; [| destruct l2 eqn:Hl2].
intros [_ Habs]. simpl in Habs. congruence.
Qed.
-Lemma Fair_FirstMove : forall d, Fair d -> Stream.forever (Stream.instant similarity_da_prop) d ->
- forall config, ~(exists pt, gathered_at pt config) -> FirstMove rendezvous d config.
+Lemma Fair_FirstChange : forall d, Fair d -> Stream.forever (Stream.instant similarity_da_prop) d ->
+ forall config, ~(exists pt, gathered_at pt config) -> FirstChange rendezvous d config.
Proof using .
intros d Hfair Hsim config Hgather.
-destruct (OneMustMove config Hgather) as [idmove Hmove].
+destruct (OneMustChange config Hgather) as [idmove Hmove].
destruct Hfair as [locallyfair Hfair].
specialize (locallyfair idmove).
revert config Hgather Hmove.
induction locallyfair as [d Hnow | d]; intros config Hgather Hmove.
-* apply MoveNow. apply Hmove in Hnow.
- + rewrite <- (moving_spec rendezvous (Stream.hd d) config idmove) in Hnow.
+* apply ChangeNow. apply Hmove in Hnow.
+ + rewrite <- (changing_spec rendezvous (Stream.hd d) config idmove) in Hnow.
intro Habs. rewrite Habs in Hnow. tauto.
+ apply Hsim.
-* destruct (moving rendezvous (Stream.hd d) config) as [| id mov] eqn:Hmoving.
- + apply MoveLater; trivial; [].
+* destruct (changing rendezvous (Stream.hd d) config) as [| id mov] eqn:Hmoving.
+ + apply ChangeLater; trivial; [].
apply IHlocallyfair.
- now destruct Hfair.
- apply Hsim.
- - apply no_moving_same_config in Hmoving. now setoid_rewrite Hmoving.
- - intros da Hda Hactive. apply no_moving_same_config in Hmoving.
+ - apply no_changing_same_config in Hmoving. now setoid_rewrite Hmoving.
+ - intros da Hda Hactive. apply no_changing_same_config in Hmoving.
rewrite (Hmoving idmove).
apply (round_compat (reflexivity rendezvous) (reflexivity da)) in Hmoving; trivial; [].
rewrite (Hmoving idmove).
now apply Hmove.
- + apply MoveNow. rewrite Hmoving. discriminate.
+ + apply ChangeNow. rewrite Hmoving. discriminate.
Qed.
(** Final result: correctness of the Viglietta algorithm *)
@@ -443,7 +438,7 @@ destruct (gathered_at_dec config (get_location (config (Good r0)))) as [Hgather
exists (get_location (config (Good r0))).
now apply gathered_at_over.
* (* otherwise, we wait until one robot moves *)
- induction (Fair_FirstMove _ Hfair Hsim config) as [ | d config Hmove Hfirst IHf].
+ induction (Fair_FirstChange _ Hfair Hsim config) as [ | d config Hmove Hfirst IHf].
+ apply Stream.Later. rewrite (execute_tail rendezvous).
change (WillGather (execute rendezvous (Stream.tl d) (round rendezvous (Stream.hd d) config))).
(* are we gathered at the next step? *)
@@ -463,8 +458,8 @@ destruct (gathered_at_dec config (get_location (config (Good r0)))) as [Hgather
+ apply Stream.Later. apply IHf.
- apply Hfair.
- apply Hsim.
- - apply no_moving_same_config in Hmove. now rewrite Hmove.
- - apply no_moving_same_config in Hmove. now rewrite Hmove, (Hmove (Good r0)).
+ - apply no_changing_same_config in Hmove. now rewrite Hmove.
+ - apply no_changing_same_config in Hmove. now rewrite Hmove, (Hmove (Good r0)).
+ intros [pt Hpt]. apply Hgather. now rewrite (Hpt r0).
Qed.
diff --git a/CaseStudies/Gathering/InR2/Weber/Align_flex_async.v b/CaseStudies/Gathering/InR2/Weber/Align_flex_async.v
index 206e3150d3f2441392e637e4cf6f3a7b9d50d9c0..189b13e6a0efe56baa2ab9ff1676a3f7a9c0707c 100644
--- a/CaseStudies/Gathering/InR2/Weber/Align_flex_async.v
+++ b/CaseStudies/Gathering/InR2/Weber/Align_flex_async.v
@@ -272,8 +272,8 @@ Proof using .
intros s1 s2 Hs. unfold gatherW_pgm.
repeat destruct_match.
+ reflexivity.
-+ rewrite Hs in a. now intuition.
-+ rewrite Hs in n0. now intuition.
++ rewrite Hs in H. now intuition.
++ rewrite Hs in H. now intuition.
+ apply weber_Naligned_unique with (multi_support s1) ; auto.
- rewrite Hs. now apply weber_calc_correct.
- now apply weber_calc_correct.
@@ -301,7 +301,7 @@ pattern s. apply MMultisetFacts.ind.
- now rewrite Hm.
+ intros m x' n' Hin Hn IH. rewrite add_spec, multi_support_add, countA_occ_app by auto.
destruct_match.
- - now rewrite <-e, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
+ - now rewrite <-H, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
- now rewrite countA_occ_alls_out, IH, Nat.add_0_l ; auto.
+ now reflexivity.
Qed.
@@ -392,7 +392,7 @@ change_LHS (update
(choose_update da
(map_config (lift f) config) g (gatherW_pgm obs))).
assert (Hcancel : map_config (lift f_inv) (map_config (lift f) config) == config).
-{ intros id. cbn -[equiv]. destruct (config id) as [[start dest] r]. now rewrite 2 Bijection.retraction_section. }
+{ intros idt. cbn -[equiv]. destruct (config idt) as [[start dest] r]. now rewrite 2 Bijection.retraction_section. }
rewrite Hcancel.
assert (Proper (equiv ==> equiv) (projT1 f)) as f_compat.
{ unfold f ; cbn -[equiv]. intros x y Hxy ; now rewrite Hxy. }
diff --git a/CaseStudies/Gathering/InR2/Weber/Align_flex_ssync.v b/CaseStudies/Gathering/InR2/Weber/Align_flex_ssync.v
index 91f262a6d7e0574c31c24495551c867f21543ab6..031c50f7194922e039d8bdeea14a3d106f89b192 100644
--- a/CaseStudies/Gathering/InR2/Weber/Align_flex_ssync.v
+++ b/CaseStudies/Gathering/InR2/Weber/Align_flex_ssync.v
@@ -220,7 +220,7 @@ pattern s. apply MMultisetFacts.ind.
- now rewrite Hm.
+ intros m x' n' Hin Hn IH. rewrite add_spec, multi_support_add, countA_occ_app by auto.
destruct_match.
- - now rewrite <-e, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
+ - now rewrite <-H, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
- now rewrite countA_occ_alls_out, IH, Nat.add_0_l ; auto.
+ now reflexivity.
Qed.
@@ -229,7 +229,7 @@ Qed.
Typeclasses eauto := (bfs).
Lemma multi_support_config config id :
PermutationA equiv
- (multi_support (obs_from_config config (config id)))
+ (multi_support (@obs_from_config _ _ _ _ multiset_observation config (config id)))
(config_list config).
Proof using .
cbv -[multi_support config_list equiv make_multiset List.map]. rewrite List.map_id.
@@ -240,7 +240,7 @@ Qed.
Corollary multi_support_map f config id :
Proper (equiv ==> equiv) (projT1 f) ->
PermutationA equiv
- (multi_support (obs_from_config (map_config (lift f) config) (lift f (config id))))
+ (multi_support (@obs_from_config _ _ _ _ multiset_observation (map_config (lift f) config) (lift f (config id))))
(List.map (projT1 f) (config_list config)).
Proof using .
Typeclasses eauto := (dfs).
@@ -316,7 +316,7 @@ assert (Halign_loc_glob : aligned (config_list config) <-> aligned (multi_suppor
destruct_match.
(* The robots are aligned. *)
+ unfold gatherW_pgm. destruct_match ; [|intuition].
- cbn -[equiv lift dist mul inverse]. unfold id.
+ cbn -[equiv lift dist mul inverse]. unfold Datatypes.id.
repeat rewrite mul_origin. destruct_match ; apply Hsim.
(* The robots aren't aligned. *)
+ unfold gatherW_pgm. destruct_match ; [intuition|].
@@ -510,15 +510,15 @@ intros Hsim RNcol.
assert (Hweb := round_preserves_weber_calc config Hsim RNcol).
rewrite Forall2_Forall, combine_map, Forall_map, Forall_forall by now repeat rewrite map_length, config_list_length.
intros [x' x] Hin. apply config_list_In_combine in Hin. destruct Hin as [id [Hx Hx']].
-repeat destruct_match ; try lra. rewrite Hx, Hx', Hweb in *.
-assert (H : round gatherW da config id == weber_calc (config_list config)).
+repeat destruct_match ; try lra. rewrite Hx, Hx', Hweb in *. rename H into Hround_id. rename H0 into Hconfig_id.
+assert (Hround : round gatherW da config id == weber_calc (config_list config)).
{
destruct (round_simplify config Hsim) as [r Hround].
rewrite Hround. repeat destruct_match ; auto.
- cbn zeta. rewrite <-e. cbn -[equiv dist mul opp RealVectorSpace.add].
+ cbn zeta. rewrite <-Hconfig_id. cbn -[equiv dist mul opp RealVectorSpace.add].
simplifyR2. now destruct_match.
}
-rewrite <-H in e. intuition.
+rewrite <-Hround in Hround_id. intuition.
Qed.
Lemma Forall2_le_dist_weber config da :
@@ -631,7 +631,7 @@ cut (exists i, config i =/= w).
{
intros [i Hi]. exists i. intros da Hsim Hact.
destruct (round_simplify config Hsim) as [r Hround]. rewrite Hround.
- repeat destruct_match ; try intuition. clear Hact.
+ repeat destruct_match ; try intuition. clear Hact. rename H into Hactiv. rename H0 into Halign.
cbn -[opp mul RealVectorSpace.add dist config_list equiv complement].
rewrite Rmult_1_l, mul_1, good_unpack_good ; unfold id ; fold w.
destruct_match_eq Hdelta.
@@ -653,6 +653,15 @@ foldR2. change location_Setoid with state_Setoid in *. rewrite config_list_InA i
destruct Hin as [r Hr]. exists r. now rewrite <-Hr.
Qed.
+
+Lemma no_moving_same_config : forall r config da,
+ moving r da config = [] -> round r da config == config.
+Proof using Type.
+intros.
+apply no_changing_same_config.
+assumption.
+Qed.
+
(* Fairness entails progress. *)
Lemma fair_first_move (d : demon) config :
Fair d -> Stream.forever (Stream.instant similarity_da_prop) d ->
@@ -665,8 +674,11 @@ specialize (locallyfair id).
revert config Nalign Hmove.
induction locallyfair as [d Hnow | d] ; intros config Nalign Hmove.
* apply MoveNow. apply Hmove in Hnow.
- + rewrite <-(moving_spec gatherW (Stream.hd d) config id) in Hnow.
- intros Habs. now rewrite Habs in Hnow.
+ + assert (get_location (round gatherW (Stream.hd d) config id) =/= get_location (config id)) as Hnow'.
+ { cbn -[complement equiv].
+ assumption. }
+ rewrite <-(moving_spec gatherW (Stream.hd d) config id) in Hnow'.
+ intros Habs. now rewrite Habs in Hnow'.
+ apply Hsim.
* destruct (moving gatherW (Stream.hd d) config) as [| id' mov] eqn:Hmoving.
+ apply MoveLater ; trivial.
diff --git a/CaseStudies/Gathering/InR2/Weber/Align_rigid_ssync.v b/CaseStudies/Gathering/InR2/Weber/Align_rigid_ssync.v
index e45b8d11b41fbb7d98a60ef7e35e33460124c55e..322ed8391cec231a247586faf6183750b9c7384d 100644
--- a/CaseStudies/Gathering/InR2/Weber/Align_rigid_ssync.v
+++ b/CaseStudies/Gathering/InR2/Weber/Align_rigid_ssync.v
@@ -41,10 +41,10 @@ Require Import Pactole.Util.ListComplements.
(* Helping typeclass resolution avoid infinite loops. *)
(* Typeclasses eauto := (bfs). *)
-(* Pactole basic definitions *)
-Require Export Pactole.Setting.
(* Specific to R^2 topology *)
Require Import Pactole.Spaces.R2.
+(* Pactole basic definitions *)
+Require Export Pactole.Setting.
(* Specific to gathering *)
Require Pactole.CaseStudies.Gathering.WithMultiplicity.
Require Import Pactole.CaseStudies.Gathering.Definitions.
@@ -189,8 +189,8 @@ Proof using .
intros s1 s2 Hs. unfold gatherW_pgm.
repeat destruct_match.
+ reflexivity.
-+ rewrite Hs in a. now intuition.
-+ rewrite Hs in n0. now intuition.
++ rewrite Hs in H. now intuition.
++ rewrite Hs in H. now intuition.
+ apply weber_Naligned_unique with (multi_support s1) ; auto.
- rewrite Hs. now apply weber_calc_correct.
- now apply weber_calc_correct.
@@ -218,16 +218,16 @@ pattern s. apply MMultisetFacts.ind.
- now rewrite Hm.
+ intros m x' n' Hin Hn IH. rewrite add_spec, multi_support_add, countA_occ_app by auto.
destruct_match.
- - now rewrite <-e, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
+ - now rewrite <-H, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
- now rewrite countA_occ_alls_out, IH, Nat.add_0_l ; auto.
+ now reflexivity.
Qed.
-Typeclasses eauto := (bfs).
+Typeclasses eauto := (bfs) 3.
(* This is the main result about multi_support. *)
-Lemma multi_support_config config id :
+Lemma multi_support_config (config:configuration) id :
PermutationA equiv
- (multi_support (obs_from_config config (config id)))
+ (multi_support (@obs_from_config _ _ _ _ multiset_observation config (config id)))
(config_list config).
Proof using .
cbv -[multi_support config_list equiv make_multiset List.map]. rewrite List.map_id.
@@ -235,10 +235,11 @@ apply PermutationA_countA_occ with R2_EqDec ; autoclass.
intros x. rewrite multi_support_countA. now apply make_multiset_spec.
Qed.
+Typeclasses eauto := (bfs).
Corollary multi_support_map f config id :
Proper (equiv ==> equiv) (projT1 f) ->
PermutationA equiv
- (multi_support (obs_from_config (map_config (lift f) config) (lift f (config id))))
+ (multi_support (@obs_from_config _ _ _ _ multiset_observation (map_config (lift f) config) (lift f (config id))))
(List.map (projT1 f) (config_list config)).
Proof using .
intros H. destruct f as [f Pf]. cbn -[equiv config_list multi_support].
@@ -461,6 +462,15 @@ foldR2. change location_Setoid with state_Setoid in *. rewrite config_list_InA i
destruct Hin as [r Hr]. exists r. now rewrite <-Hr.
Qed.
+Lemma no_moving_same_config : forall r config da,
+ moving r da config = [] -> round r da config == config.
+Proof using Type.
+intros.
+apply no_changing_same_config.
+assumption.
+Qed.
+
+
(* Fairness entails progress. *)
Lemma fair_first_move (d : demon) config :
Fair d -> Stream.forever (Stream.instant similarity_da_prop) d ->
@@ -473,8 +483,11 @@ specialize (locallyfair id).
revert config Nalign Hmove.
induction locallyfair as [d Hnow | d] ; intros config Nalign Hmove.
* apply MoveNow. apply Hmove in Hnow.
- + rewrite <-(moving_spec gatherW (Stream.hd d) config id) in Hnow.
- intros Habs. now rewrite Habs in Hnow.
+ + assert (get_location (round gatherW (Stream.hd d) config id) =/= get_location (config id)) as Hnow'.
+ { cbn -[complement equiv].
+ assumption. }
+ rewrite <-(moving_spec gatherW (Stream.hd d) config id) in Hnow'.
+ intros Habs. now rewrite Habs in Hnow'.
+ apply Hsim.
* destruct (moving gatherW (Stream.hd d) config) as [| id' mov] eqn:Hmoving.
+ apply MoveLater ; trivial.
diff --git a/CaseStudies/Gathering/InR2/Weber/Gather_flex_async.v b/CaseStudies/Gathering/InR2/Weber/Gather_flex_async.v
index 5cdf0a2e6191918f27ac868fe57e1678e18fcdba..a4a946ba707d32c85d15f484c5d7ec6922d36798 100644
--- a/CaseStudies/Gathering/InR2/Weber/Gather_flex_async.v
+++ b/CaseStudies/Gathering/InR2/Weber/Gather_flex_async.v
@@ -984,7 +984,6 @@ Proof using Type.
+ rewrite add_same,add_other;auto.
+ inversion hinA as [| _a _b hinA' _c];subst.
* rewrite add_other,add_same;auto.
- { now symmetry. }
* inversion hinA'.
- rewrite mem_false_iff in heqmem.
rewrite add_other.
@@ -1505,7 +1504,7 @@ pattern s. apply MMultisetFacts.ind.
- now rewrite Hm.
+ intros m x' n' Hin Hn IH. rewrite add_spec, multi_support_add, countA_occ_app by auto.
destruct_match.
- - now rewrite <-e, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
+ - now rewrite <-H, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
- now rewrite countA_occ_alls_out, IH, Nat.add_0_l ; auto.
+ now reflexivity.
Qed.
@@ -2126,8 +2125,7 @@ Proof using lt_0n.
- intro abs.
rewrite abs in n1.
apply n1.
- apply segment_end.
- - now symmetry. }
+ apply segment_end. }
destruct (segment_dec p b a).
{ left.
right.
@@ -2267,8 +2265,8 @@ Lemma round_simplify da config :
else inactive config id (r id).
Proof using lt_0n delta_g0.
intros Hsim Hvalid. eexists ?[r]. intros id. unfold round.
-destruct_match ; [|reflexivity].
-destruct_match ; [|byz_exfalso].
+destruct_match ; [|reflexivity]. rename H into Hactivate.
+destruct_match ; [|byz_exfalso]. rename H into Hgood.
rewrite (lift_update_swap da config _ g).
pose (f := existT precondition
(change_frame da config g)
@@ -2284,7 +2282,7 @@ change_LHS (update
(frame_choice_bijection (change_frame da config g â»Â¹) (gatherW_pgm obs))
(choose_update da (map_config (lift f) config) g (gatherW_pgm obs))).
assert (Hcancel : map_config (lift f_inv) (map_config (lift f) config) == config).
-{ intros id. cbn -[equiv]. destruct (config id) as [[start dest] r]. now rewrite 2 Bijection.retraction_section. }
+{ intros idt. cbn -[equiv]. destruct (config idt) as [[start dest] r]. now rewrite 2 Bijection.retraction_section. }
rewrite Hcancel. clear Hcancel.
assert (Proper (equiv ==> equiv) (projT1 f)) as f_compat.
{ unfold f ; cbn -[equiv]. intros x y Hxy ; now rewrite Hxy. }
@@ -2405,9 +2403,9 @@ assert (Hseg : forall t, existsb (strict_segment_decb 0%VS (sim t)) (multi_suppo
{
intros t. change obs with (!! (map_config (lift f) config)).
rewrite multi_support_map by auto. setoid_rewrite <-List.map_id at 3.
- rewrite 2 existsb_map. f_equiv. intros ? ? H. cbn -[get_location sim]. foldR2. fold sim.
+ rewrite 2 existsb_map. f_equiv. intros ? ? h. cbn -[get_location sim]. foldR2. fold sim.
rewrite strict_segment_decb_eq_iff.
- now rewrite Hcenter, <-R2strict_segment_similarity, H.
+ now rewrite Hcenter, <-R2strict_segment_similarity, h.
}
assert (Hseg_sim : forall x y z, segment_decb (sim x) (sim y) (sim z) = segment_decb x y z).
@@ -2973,7 +2971,7 @@ case (w1 =?= w2) as [Ew12 | NEw12].
++exists L, w2, w1. split ; [|split ; [|split ; [|split ; [|split ; [|split]]]]] ;
auto using config_stay_impl_config_stg, config_stay_impl_endpoints_stay.
--now setoid_rewrite segment_sym.
- --intuition.
+ (* --intuition. *)
--rewrite (segment_line L) in Hmiddle.
** repeat rewrite (line_middle L ps) in Hmiddle at 1.
repeat rewrite line_P_iP in Hmiddle at 1 by assumption.
@@ -3800,9 +3798,10 @@ apply Nat.le_lteq in Hr1_multR. case Hr1_multR as [Hr1_multR | Hr1_multR].
generalize (Hround id). destruct_match.
++case ifP_bool ; cbn zeta.
--intros _ ->. intuition.
- --intros Hex ->. exfalso. rewrite Hid in Hex.
+
+ -- intros Hex ->. exfalso. rewrite Hid in Hex.
apply (f_equal negb) in Hex. rewrite forallb_existsb, forallb_forall in Hex.
- clear Hid id.
+ clear Hid id H0.
assert (Htowers : forall id, get_location (c id) == r1 \/ get_location (c id) == r2).
{
intros id. specialize (Hex (get_location (c id))). feed Hex.
diff --git a/CaseStudies/Gathering/InR2/Weber/Utils.v b/CaseStudies/Gathering/InR2/Weber/Utils.v
index f505889d72d49b988be4785c17e34b7d9f308120..994c7e816332c2275c1f6090a7bd5c1a23d32168 100644
--- a/CaseStudies/Gathering/InR2/Weber/Utils.v
+++ b/CaseStudies/Gathering/InR2/Weber/Utils.v
@@ -209,7 +209,7 @@ Lemma countA_occ_le {A : Type} `{eq_dec : EqDec A} w ps ps' :
Proof using .
intros HF. induction HF as [| x x' l l' Hxx' Hll' IH] ; [auto|].
cbn -[equiv]. repeat destruct_match ; intuition.
-rewrite H, e in *. intuition.
+rewrite H, H1 in *. intuition.
Qed.
Lemma countA_occ_lt {A : Type} `{eq_dec : EqDec A} w ps ps' :
@@ -225,7 +225,7 @@ intros HF HE. induction HF as [| x x' l l' Hxx' Hll' IH].
rewrite Ex'w in Dxx' |- *. cbn -[equiv].
repeat destruct_match ; intuition. rewrite Nat.lt_succ_r. now apply countA_occ_le.
- destruct Hxx' as [Exx' | Ex'w] ; cbn -[equiv] ; repeat destruct_match ; intuition.
- rewrite Exx', e in *. intuition.
+ rewrite Exx', H in *. intuition.
Qed.
Lemma list_all_eq_or_perm {A : Type} `{Setoid A} `{EqDec A} (x0 : A) l :
diff --git a/CaseStudies/Gathering/WithMultiplicityLight.v b/CaseStudies/Gathering/WithMultiplicityLight.v
new file mode 100644
index 0000000000000000000000000000000000000000..09ea4ea62b35f4a321bf102855c280c0ebaf3811
--- /dev/null
+++ b/CaseStudies/Gathering/WithMultiplicityLight.v
@@ -0,0 +1,1617 @@
+(**************************************************************************)
+(* 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. *)
+(* *)
+(**************************************************************************)
+
+(**************************************************************************)
+(** 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 Utf8.
+Require Import Lia PeanoNat.
+Require Import SetoidList Pactole.Util.SetoidDefs.
+Require Import Pactole.Util.Bijection.
+Require Export Pactole.CaseStudies.Gathering.Definitions.
+Require Export Pactole.Observations.MultisetObservation.
+Require Import Pactole.Observations.PairObservation.
+Close Scope R_scope.
+Close Scope VectorSpace_scope.
+Set Implicit Arguments.
+Typeclasses eauto := (dfs) 5.
+
+Class Lights := {
+ L : Type;
+ #[export] L_Setoid :: Setoid L;
+ #[export] L_EqDec :: EqDec L_Setoid;
+ witness : L;
+ l_list : list L;
+ L_list_NoDupA : NoDupA equiv l_list;
+ L_list_InA : forall li : L, InA equiv li l_list;
+}.
+
+
+(** Gathering Definitions specific to a setting with multiplicities, i.e. a multiset observation. *)
+
+Section MultisetGathering.
+
+(** Here, we restrict the state to only contain the location. *)
+Context `{Loc:Location}.
+(* TODO: add the existence of a similarity here *)
+Context {Lght : Lights}.
+
+Local Instance St : State (location*L) := AddInfo L (OnlyLocation (fun _ => True)).
+Context {VS : RealVectorSpace location}.
+Context {RMS : RealMetricSpace location}.
+Context `{Hnames:Names}.
+Context `{Robot_ch:robot_choice}.
+Context `{U:update_choice}.
+Context `{Ina:inactive_choice}.
+Context {UpdFun : update_function _ _ _}.
+Context {InaFun : inactive_function _}.
+
+
+Definition get_light (x:(location*L)): L := snd x.
+
+Global Instance get_light_compat : Proper (equiv ==> equiv) get_light := snd_compat_pactole.
+
+Lemma no_info : forall x y, get_location x == get_location y -> get_light x == get_light y -> x == y.
+Proof using . now intros. Qed.
+
+(** Auxiliary def: an observation with lights on two locations, the observer's and another one. *)
+Definition find_another_location config pt :=
+ List.hd pt (List.filter (fun x => if x =?= pt then false else true)
+ (List.map get_location (config_list config))).
+
+Local Instance find_another_location_compat : Proper (equiv ==> equiv ==> equiv) find_another_location.
+Proof using Type.
+intros config1 config2 Hconfig pt1 pt2 Hpt. unfold find_another_location.
+apply hd_eqlistA_compat; trivial; [].
+f_equiv.
+- repeat intro. do 2 destruct_match; trivial; exfalso;
+ apply H0 || apply H1; do 2 (etransitivity; try eassumption; eauto).
+- now rewrite Hconfig.
+Qed.
+
+Lemma find_another_location_spec : forall config pt,
+ (* not gathered *)
+ ~gathered_at pt config ->
+(* (exists id1 id2, get_location (config id1) =/= get_location (config id2)) -> *)
+ find_another_location config pt =/= pt.
+Proof using Type.
+intros config pt Hgathered. unfold find_another_location. rewrite config_list_spec, map_map.
+intro Habs. apply Hgathered. intro g. assert (Hg := In_names (Good g)).
+induction names as [| id names]; cbn -[equiv_dec] in *.
++ tauto.
++ destruct Hg.
+ - subst id. revert Habs. now destruct_match.
+ - apply IHnames; trivial; [].
+ revert Habs. now destruct_match.
+Qed.
+
+Lemma find_another_location_map : forall f,
+ Proper (equiv ==> equiv) f -> Util.Preliminary.injective equiv equiv f ->
+ forall Pf config pt,
+ find_another_location (map_config (lift (existT _ f Pf)) config) (f pt)
+ == f (find_another_location config pt).
+Proof using Type.
+intros f Hf Hf_inj Pf config pt. unfold find_another_location.
+rewrite config_list_map, map_map.
+* induction (config_list config) as [| [x li] l]; cbn.
+ + reflexivity.
+ + repeat destruct_match; cbn.
+ - apply IHl.
+ - apply Hf_inj in H. contradiction.
+ - rewrite H0 in *. intuition.
+ - reflexivity.
+(* * apply lift_compat. intros x y Hxy. cbn. now apply Hf. *)
+Qed.
+
+Existing Instance eqlistA_Setoid.
+Existing Instance eqlistA_EqDec.
+
+Record obsLight := {
+ observer_lght: L; (* color of the observing robot *)
+ colors: multiset (location*L);
+ }.
+
+Definition obsLight_equiv (o1 o2: obsLight) :=
+ colors o1 == colors o2 /\ observer_lght o1 == observer_lght o2.
+
+Instance obsLight_is_equiv: Equivalence obsLight_equiv.
+Proof using Type.
+ unfold obsLight_equiv.
+ repeat split;auto; try now intuition; try etransitivity; eauto.
+Qed.
+
+Global Instance obsLight_Setoid : Setoid obsLight := {|
+ equiv := obsLight_equiv;
+ setoid_equiv := obsLight_is_equiv |}.
+
+Global Instance obsLight_is_dec: EqDec obsLight_Setoid.
+Proof.
+ red.
+ intros o1 o2.
+ destruct (MMultisetWMap.eq_dec _ _ _ _ _ (colors o1) (colors o2)).
+ - destruct (observer_lght o1 =?= observer_lght o2).
+ + left.
+ split;auto.
+ + right.
+ intro abs.
+ destruct abs.
+ contradiction.
+ - right.
+ intro abs.
+ destruct abs.
+ contradiction.
+Defined.
+
+#[export] Instance colors_compat2: Proper (equiv ==> equiv) colors.
+Proof using Type.
+ intros ? ? ?.
+ destruct H.
+ assumption.
+Qed.
+
+#[export] Instance colors_compat3: Proper (equiv ==> equiv ==> eq)
+ (fun x => (multiplicity (colors x))).
+Proof using Type.
+ repeat intro.
+ destruct H.
+ rewrite H.
+ apply H0.
+Qed.
+
+
+#[export] Instance observer_lght_compat: Proper (equiv ==> equiv) observer_lght.
+Proof using.
+ repeat intro.
+ now destruct H as [? ?].
+Qed.
+
+(* In order to recover [obs_from_config_ignore_snd], pt1 cannot be [get_location state]. *)
+(* Yes it must be [get_location state] because the observation needs
+ to provide the color of the observing robot AND also which of the
+ two columns it occupies. By convention we chose that fst_lght is
+ the observing column. *)
+Definition obs_from_config2 config (state : location * L) :=
+ let cols := make_multiset (config_list config) in
+ {| colors := cols;
+ observer_lght := get_light state |}.
+
+Local Instance obs_from_config2_compat : Proper (equiv ==> equiv ==> equiv) obs_from_config2.
+Proof using Type.
+ intros config1 config2 Hconfig state1 state2 Hstate.
+ unfold obs_from_config2.
+(* assert (Hstate' := @get_location_compat _ _ _ _ _ Hstate). *)
+ assert (Hconfig' := config_list_compat Hconfig).
+ assert (Hfst := Hconfig').
+ apply (hd_eqlistA_compat _ _ Hstate), fst_compat_pactole in Hfst.
+ red.
+ (* apply (hd_eqlistA_compat _ _ Hstate), fst_compat_pactole in Hfst. *)
+ (* red. *)
+ unfold obsLight_Setoid.
+ cbn -[fst] in Hstate.
+ destruct Hstate as [h1 h2].
+ split; cbn -[equiv config_list];auto.
+ apply make_multiset_compat.
+ now apply eqlistA_PermutationA.
+Qed.
+
+Lemma obs_from_config2_map : forall f:location -> location,
+ Proper (equiv ==> equiv) f -> Preliminary.injective equiv equiv f ->
+ forall config st obs obsf ,
+ obs == obs_from_config2 config st ->
+ obsf == obs_from_config2 (map_config (fun x => (f (fst x), snd x)) config) (f (fst st), snd st) ->
+ observer_lght obsf == observer_lght obs /\
+ colors obsf == map (fun x => (f (fst x), snd x)) (colors obs).
+Proof using Type.
+ intros f Hf Hf_inj config st obs obsf.
+ change (fun x => (f (fst x), snd x)) with (lift (existT _ f I)).
+ change (f (fst st), snd st) with (lift (existT _ f I) st).
+ assert (Proper (equiv (A := location * L) ==> equiv (A := location * L))
+ (lift (existT precondition f I))) as h_proper.
+ { intros ? ? ?.
+ now apply (@lift_compat _ _ St). }
+ unfold obs_from_config2. rewrite config_list_map; trivial; [].
+ cbn -[equiv].
+ intros h_eq_obs h_eq_obsf.
+ split; cbn -[equiv].
+ - now rewrite h_eq_obs, h_eq_obsf.
+ - rewrite h_eq_obsf, h_eq_obs.
+ cbn.
+ intros x.
+ now rewrite make_multiset_map.
+Qed.
+
+Definition Obs2 : Observation.
+Proof.
+refine {|
+ observation := obsLight;
+ obs_from_config := obs_from_config2;
+ obs_from_config_compat := obs_from_config2_compat;
+ obs_is_ok :=
+ fun obs config state =>
+ observer_lght obs = (get_light state)
+ /\ forall x, (colors obs)[x] = countA_occ equiv equiv_dec x (config_list config);
+ obs_from_config_spec := fun _ _ => _
+ |}.
+Proof.
+ split.
+ - reflexivity.
+ - intros x.
+ apply make_multiset_spec.
+Defined.
+
+Local Instance Obs : Observation := pair_observation multiset_observation Obs2.
+Local Declare Scope pactole_scope.
+Local Notation " '!!' config" := (@obs_from_config _ _ St _ multiset_observation config (origin,witness)) (at level 10):pactole_scope.
+Local Notation " '!!!' '(' config ',' st ')'" := (@obs_from_config _ _ St _ Obs config st ) (at level 10):pactole_scope.
+(* Notation "!! config" := (@obs_from_config _ _ _ _ Obs config (origin,witness) ) (at level 10). *)
+Local Open Scope pactole_scope.
+
+Global Instance obs_from_config_compat : Proper (equiv ==> equiv ==> equiv)
+ (@obs_from_config _ _ _ _ Obs) := @obs_from_config_compat _ _ _ _ Obs.
+
+Lemma obs_from_config_fst_ok: forall (st st':(location * L)) (c:configuration),
+ (obs_from_config (Observation:=multiset_observation) c st)
+ = (fst (obs_from_config (Observation:=@Obs) c st')).
+Proof using Type.
+ intros st c.
+ reflexivity.
+Qed.
+
+Lemma cardinal_fst_obs_from_config : forall config state,
+ cardinal (fst (obs_from_config (Observation:=Obs) config state)) = nG + nB.
+Proof using Type. intros. cbn -[make_multiset cardinal nB nG location]. apply cardinal_obs_from_config. Qed.
+
+Lemma obs_from_config_ignore_snd_except_observerlight :
+ forall (ref_st : location * L) config st,
+ let o := obs_from_config config ref_st in
+ let o' := obs_from_config config st in
+ obs_from_config (Observation := Obs) config st == (fst o, snd o').
+ (* The snd part depends on the color of st/ref_st *)
+ (* (fst o, Build_obsLight (fst_lght (snd o)) (snd_lght (snd o)) (snd st)). *)
+Proof using Type. reflexivity. Qed.
+
+Lemma obs_from_config_fst :forall (ref_st : location * L) config obs1 obs2,
+ obs_from_config config ref_st == (obs1, obs2) ->
+ forall st, obs1 == (obs_from_config (Observation:=multiset_observation) config st).
+Proof using Lght VS.
+ intros ref_st config obs1 obs2 h_eq_obs st.
+ specialize (obs_from_config_ignore_snd_except_observerlight st config ref_st) as h.
+ rewrite h in h_eq_obs.
+ assert (fst (obs_from_config (Observation:=Obs) config st) == obs1) as h_fst.
+ { apply h_eq_obs. }
+ rewrite <- h_fst.
+ rewrite (obs_from_config_fst_ok _ (origin,witness)).
+ reflexivity.
+Qed.
+
+Lemma observer_light_get_light: forall config id,
+ observer_lght (snd (obs_from_config config (config id))) = get_light (config id).
+Proof using Type. reflexivity. Qed.
+
+
+Lemma obs_from_ok: forall config st,
+ (obs_from_config config st) ==
+ (obs_from_config (Observation:=multiset_observation) config st,
+ snd (obs_from_config config st)).
+Proof using Type.
+ intros config st.
+ specialize (obs_from_config_ignore_snd_except_observerlight st config st) as h.
+ lazy zeta in h.
+ setoid_rewrite h.
+ reflexivity.
+Qed.
+
+Lemma obs_from_ok2: forall config st,
+ (!!!(config,st)) == (obs_from_config config (origin,witness), snd (!!!(config,st))).
+Proof using Type.
+ intros config st.
+ specialize (@obs_from_config_ignore_snd_except_observerlight st config st) as h.
+ cbv zeta in h.
+ setoid_rewrite h.
+ reflexivity.
+Qed.
+
+Definition map_light f (obs : observation (Observation := Obs2)) : observation (Observation := Obs2) :=
+ {| observer_lght := observer_lght obs;
+ colors := map (fun x => (f (fst x), snd x)) (colors obs) |}.
+
+Instance map_light_compat : forall f, Proper (equiv ==> equiv) f -> Proper (equiv ==> equiv) (map_light f).
+Proof using Type.
+intros f Hf obs1 obs2 Hobs. unfold map_light.
+split; cbn -[equiv]; try apply Hobs; [].
+apply map_compat.
++ intros ? ? Heq. now split; cbn; rewrite Heq.
++ now f_equiv.
+Qed.
+
+Lemma map_light_extensionality_compat : forall f g, Proper (equiv ==> equiv) f ->
+ (forall x, g x == f x) -> forall m , map_light g m == map_light f m.
+Proof using Type.
+intros f g Hf Hfg m. unfold map_light.
+split; cbn -[equiv]; try reflexivity; [].
+apply map_extensionality_compat.
++ intros ? ? Heq. now rewrite Heq.
++ intro x. now split; try apply Hfg.
+Qed.
+
+Lemma map_light_merge : forall f g, Proper (equiv ==> equiv) f -> Proper (equiv ==> equiv) g ->
+ forall obs, map_light f (map_light g obs) == map_light (fun x => f (g x)) obs.
+Proof using Type.
+intros f g Hf Hg obs. split; try reflexivity; [].
+unfold map_light. cbn -[equiv]. apply map_merge.
++ intros ? ? Heq. split; try apply Hf; apply Heq.
++ intros ? ? Heq. split; try apply Hg; apply Heq.
+Qed.
+
+Lemma map_light_id : forall obs, map_light id obs == obs.
+Proof using Type.
+intro obs. unfold map_light. split; try reflexivity; []. cbn -[equiv].
+transitivity (map Datatypes.id (colors obs)); try apply map_id; [].
+apply map_extensionality_compat.
++ now repeat intro.
++ now intros [].
+Qed.
+
+Lemma map_light_colors : forall f,
+ Proper (equiv ==> equiv) f -> Preliminary.injective equiv equiv f ->
+ forall obs pt c, (colors (map_light f obs))[(f pt, c)] = (colors obs)[(pt, c)].
+Proof using Type.
+intros f Hf Hinj [] pt c. cbn. change (f pt, c) with ((fun x => (f (fst x), snd x)) (pt, c)).
+apply map_injective_spec.
++ intros x y Hxy. now rewrite Hxy.
++ intros x y [Heq1 Heq2]. apply Hinj in Heq1. now split.
+Qed.
+
+Definition map_obs f (obs : observation) : observation :=
+ (map (Bijection.section f) (fst obs), map_light f (snd obs)).
+
+Lemma map_obs_compat : forall f : Bijection.bijection location,
+ Proper (equiv ==> equiv) (map_obs f).
+Proof using Type. intros f x y Hxy. unfold map_obs. now rewrite Hxy. Qed.
+
+Lemma map_obs_merge : forall (f g : Bijection.bijection location),
+ Proper (equiv ==> equiv) f -> Proper (equiv ==> equiv) g ->
+ forall obs, map_obs f (map_obs g obs) == map_obs (f ∘ g) obs.
+Proof using Type.
+intros f g Hf Hg obs. unfold map_obs. split; cbn -[equiv].
++ now apply map_merge.
++ now apply map_light_merge.
+Qed.
+
+Lemma map_obs_id : forall obs, map_obs id obs == obs.
+Proof using Type.
+intro obs. unfold map_obs. split; cbn -[equiv].
++ apply map_id.
++ apply map_light_id.
+Qed.
+
+Lemma obs_from_config_map : forall f : Bijection.bijection location,
+ Proper (equiv ==> equiv) f ->
+ Preliminary.injective equiv equiv f ->
+ forall Pf (config:configuration) st,
+ (obs_from_config (map_config (lift (existT precondition f Pf)) config)
+ (lift (existT precondition f Pf) st))
+ == map_obs f (obs_from_config config st).
+Proof using Type.
+intros f Hf Hf_inj Pf config st. split.
+* assert (Hmap := obs_from_config_map Hf I config).
+ do 2 (unfold obs_from_config in *; cbn -[equiv] in *).
+ now rewrite Hmap.
+* do 2 (unfold obs_from_config; cbn -[equiv]).
+ split.
+ - specialize (@obs_from_config2_map f) as h.
+ specialize h with (config:=config) (st:=st).
+ edestruct h;auto.
+ - reflexivity.
+Qed.
+
+
+(** A configuration with two towers containing the same numbers of robots. *)
+Definition bivalent (config : configuration) :=
+ let n := nG + nB in
+ Nat.Even n /\ n >=2 /\ exists pt1 pt2 : location, pt1 =/= pt2
+ /\ (!! config)[pt1] = Nat.div2 n /\ (!! config)[pt2] = Nat.div2 n.
+
+Global Instance bivalent_compat : Proper (equiv ==> iff) bivalent.
+Proof using .
+intros ? ? Heq. split; intros [HnG [Hle [pt1 [pt2 [Hneq [Hpt1 Hpt2]]]]]];
+repeat split; trivial; exists pt1, pt2; split; trivial; [|].
+* assert (Heq' : (!! x) == (!! y)).
+ { apply obs_from_config_compat in Heq.
+ specialize (Heq _ _ (reflexivity (origin, witness))).
+ now apply fst_compat_pactole in Heq. }
+ split; (rewrite <- Hpt1 + rewrite <- Hpt2); now apply multiplicity_compat.
+* assert (Heq' : (!! x) == (!! y)).
+ { apply obs_from_config_compat in Heq.
+ specialize (Heq _ _ (reflexivity (origin, witness))).
+ now apply fst_compat_pactole in Heq. }
+ split; (rewrite <- Hpt1 + rewrite <- Hpt2); now apply multiplicity_compat.
+Qed.
+
+(* A bivalent configuration with the same number of robots of each color in both towers.
+ Is it reasonable to use the observation here (from origin)? *)
+Definition color_bivalent (config : configuration) :=
+ let n := nG + nB in
+ Nat.Even n /\
+ n >=2 /\
+ exists pt1 pt2: location,
+ pt1 =/= pt2 /\
+ (!! config)[pt1] = Nat.div2 n /\
+ (!! config)[pt2] = Nat.div2 n /\
+ (List.Forall
+ (fun col:L =>
+ (colors (snd (!!! (config, (0%VS,witness)))))[(pt1,col)]
+ = (colors (snd (!!! (config, (0%VS,witness)))))[(pt2,col)])
+ l_list).
+
+Global Instance color_bivalent_compat : Proper (equiv ==> iff) color_bivalent.
+Proof using .
+intros ? ? Heq.
+split;intros [HnG [Hle [pt1 [pt2 [Hneq [Hpt1 [Hpt2 Hcolors]]]]]]];
+ repeat split; trivial; exists pt1, pt2; split; trivial; [|].
+- assert (Heq' : (!! x) == (!! y)).
+ { apply obs_from_config_compat in Heq.
+ specialize (Heq _ _ (reflexivity (origin, witness))).
+ now apply fst_compat_pactole in Heq. }
+ repeat split.
+ + rewrite <- Hpt1.
+ try now apply multiplicity_compat.
+ + rewrite <- Hpt2.
+ try now apply multiplicity_compat.
+ + specialize Forall_Permutation_compat as h.
+ unfold Proper, respectful in h.
+ specialize (h _
+ (λ col : L,
+ (colors (snd (!!! (y, (0%VS, witness)))))[(pt1, col)] =
+ (colors (snd (!!! (y, (0%VS, witness)))))[(pt2, col)])
+ (λ col : L,
+ (colors (snd (!!! (x, (0%VS, witness)))))[(pt1, col)] =
+ (colors (snd (!!! (x, (0%VS, witness)))))[(pt2, col)])).
+ rewrite h.
+ apply Hcolors.
+ intros x0 y0 H.
+ split;intros.
+ * rewrite <- H.
+ rewrite Heq.
+ assumption.
+ * rewrite H.
+ rewrite <- Heq.
+ assumption.
+ * reflexivity.
+- assert (Heq' : (!! x) == (!! y)).
+ { apply obs_from_config_compat in Heq.
+ specialize (Heq _ _ (reflexivity (origin, witness))).
+ now apply fst_compat_pactole in Heq. }
+ repeat split.
+ + rewrite <- Hpt1.
+ try now apply multiplicity_compat.
+ + rewrite <- Hpt2.
+ try now apply multiplicity_compat.
+ + specialize Forall_Permutation_compat as h.
+ unfold Proper, respectful in h.
+ specialize (h _
+ (λ col : L,
+ (colors (snd (!!! (y, (0%VS, witness)))))[(pt1, col)] =
+ (colors (snd (!!! (y, (0%VS, witness)))))[(pt2, col)])
+ (λ col : L,
+ (colors (snd (!!! (x, (0%VS, witness)))))[(pt1, col)] =
+ (colors (snd (!!! (x, (0%VS, witness)))))[(pt2, col)])).
+ rewrite <- h.
+ apply Hcolors.
+ intros x0 y0 H.
+ split;intros.
+ * rewrite <- H.
+ rewrite Heq.
+ assumption.
+ * rewrite H.
+ rewrite <- Heq.
+ assumption.
+ * reflexivity.
+Qed.
+
+(* Alternative definitions with explicit locations *)
+Definition bivalent_on config pt1 pt2 :=
+ (forall id, get_location (config id) == pt1 \/ get_location (config id) == pt2)
+ /\ length (occupied config) = 2
+ /\ length (on_loc pt1 config) = length (on_loc pt2 config).
+
+Typeclasses eauto := (dfs) 5.
+
+Global Instance bivalent_on_compat : Proper (equiv ==> equiv ==> equiv ==> iff) bivalent_on.
+Proof using Type.
+intros config1 config2 Hconfig pt1 pt1' Hpt1 pt2 pt2' Hpt2.
+unfold bivalent_on.
+setoid_rewrite Hconfig. setoid_rewrite Hpt1. setoid_rewrite Hpt2.
+reflexivity.
+Qed.
+
+Lemma bivalent_on_bivalent : forall config pt1 pt2,
+ bivalent_on config pt1 pt2 -> bivalent config.
+Proof using Type.
+intros config pt1 pt2 [Hloc [Hoccupied Hsame]].
+rewrite <- 2 (obs_from_config_on_loc _ (origin, witness)) in Hsame.
+assert (Hother : forall pt, pt =/= pt1 -> pt =/= pt2 -> (!! config)[pt] = 0).
+{ intros pt Hpt1 Hpt2. rewrite <- not_In. intro Habs. rewrite obs_from_config_In in Habs.
+ destruct Habs as [id Hid]. destruct (Hloc id).
+ - apply Hpt1. now transitivity (get_location (config id)).
+ - apply Hpt2. now transitivity (get_location (config id)). }
+assert (Hperm : PermutationA equiv (support (!! config)) (cons pt1 (cons pt2 nil))).
+{ apply NoDupA_inclA_length_PermutationA.
+ + autoclass.
+ + apply support_NoDupA.
+ + intros pt Hin. rewrite support_spec, obs_from_config_In in Hin.
+ destruct Hin as [id Hid]. rewrite InA_cons, InA_singleton.
+ destruct (Hloc id); now (left + right); transitivity (get_location (config id)); auto.
+ + now rewrite support_occupied, Hoccupied. }
+assert (Hn : (!! config)[pt1] + (!! config)[pt2] = nG + nB).
+{ erewrite <- cardinal_obs_from_config, (cardinal_fold_support (!! config)).
+ rewrite (@fold_left_symmetry_PermutationA _ _ equiv equiv); autoclass.
+ + cbn. lia.
+ + intros ? ? Heq1 ? ? Heq2. now rewrite Heq1, Heq2.
+ + intros. hnf. lia. }
+assert (Heven : Nat.Even (nG + nB)).
+{ rewrite <- Hn, Hsame (*, <- Even.even_equiv*).
+ replace ((!! config)[pt2] + (!! config)[pt2]) with (2 * (!! config)[pt2]) by lia.
+ now exists (!! config)[pt2]. }
+repeat split.
+* assumption.
+* rewrite <- Hn, <- Hsame. cut ((!! config)[pt1] > 0); try lia; [].
+ change (In pt1 (!! config)). rewrite <- support_spec, Hperm. now left.
+* exists pt1, pt2. repeat split.
+ + assert (Hnodup := support_NoDupA (!! config)).
+ now rewrite Hperm, NoDupA_2 in Hnodup.
+ + apply Nat.Even_double in Heven.
+ rewrite <- Hsame in Hn. unfold Nat.double in *. rewrite <- Hn in Heven at 1. lia.
+ + apply Nat.Even_double in Heven.
+ rewrite Hsame in Hn. unfold Nat.double in *. rewrite <- Hn in Heven at 1. lia.
+Qed.
+
+Definition color_bivalent_on config pt1 pt2 :=
+ bivalent_on config pt1 pt2
+ /\ List.Forall
+ (fun col:L => (colors (snd (!!! (config, (0%VS,witness)))))[(pt1,col)]
+ = (colors (snd (!!! (config, (0%VS,witness)))))[(pt2,col)])
+ l_list.
+
+Global Instance color_bivalent_on_compat : Proper (equiv ==> equiv ==> equiv ==> iff) color_bivalent_on.
+Proof using Type.
+intros ? ? Heq1 ? ? Heq2 ? ? Heq3.
+unfold color_bivalent_on. rewrite 2 Forall_forall.
+setoid_rewrite Heq1. setoid_rewrite Heq2. setoid_rewrite Heq3.
+reflexivity.
+Qed.
+
+(** ** Generic properties **)
+
+(* We need to unfold [obs_is_ok] for rewriting *)
+Lemma obs_from_config_fst_spec : forall (config : configuration) st (pt : location),
+ (fst (!!! (config,st)))[pt] = countA_occ _ equiv_dec pt (List.map fst (config_list config)).
+Proof using Type. intros. now destruct (obs_from_config_spec config (pt, witness)) as [Hok _]. Qed.
+
+Lemma obs_non_nil : 2 <= nG+nB -> forall config st,
+ fst (!!! (config,st)) =/= MMultisetInterface.empty.
+Proof using .
+simpl obs_from_config. intros HnG config st Heq.
+assert (Hlgth:= config_list_length config).
+assert (Hl : config_list config = nil).
+{ apply (map_eq_nil fst). rewrite <- make_multiset_empty. apply Heq. }
+rewrite Hl in Hlgth.
+cbn in *. lia.
+Qed.
+
+Local Instance obs_compat : forall pt,
+ Proper (equiv ==> eq) (fun obs : location * L => if fst obs =?= pt then true else false).
+Proof using Type.
+intros pt [] [] []. cbn in *.
+repeat destruct_match; auto; exfalso; apply H1 || apply H2; etransitivity; try eassumption; eauto.
+Qed.
+
+Definition bivalent_obs (obs : observation) : bool :=
+ let obs_loc := fst obs in
+ let sup := support obs_loc in
+ match sup with
+ (cons pt1 (cons pt2 nil)) => obs_loc[pt1] =? obs_loc[pt2]
+ | _ => false
+ end.
+
+Instance bivalent_obs_compat: Proper (equiv ==> eq) bivalent_obs.
+Proof using Type.
+intros [o1 o1'] [o2 o2'] [Hfst Hsnd]. unfold bivalent_obs. cbn [fst snd] in *.
+assert (Hperm := support_compat Hfst).
+assert (Hlen := PermutationA_length Hperm).
+repeat destruct_match; auto; cbn in Hlen; try discriminate; [].
+rewrite PermutationA_2 in Hperm; [| now autoclass].
+destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]].
++ now rewrite Hfst, Heq1, Heq2.
++ now rewrite Hfst, Heq1, Heq2, Nat.eqb_sym.
+Qed.
+
+Lemma sum2_le_total : forall config st pt1 pt2, pt1 =/= pt2 ->
+ (fst (!!! (config,st)))[pt1] + (fst (!!! (config,st)))[pt2] <= nG + nB.
+Proof using .
+intros config st pt1 pt2 Hpt12.
+rewrite <- (cardinal_fst_obs_from_config config st).
+rewrite <- (add_remove_id pt1 (fst (!!! (config,st))) (reflexivity _)) at 3.
+rewrite cardinal_add.
+rewrite <- (add_remove_id pt2 (fst (!!! (config,st))) (reflexivity _)) at 5.
+rewrite remove_add_comm, cardinal_add; trivial.
+lia.
+Qed.
+
+Lemma sum3_le_total : forall config st pt1 pt2 pt3, pt1 =/= pt2 -> pt2 =/= pt3 -> pt1 =/= pt3 ->
+ (fst (!!! (config,st)))[pt1] + (fst (!!! (config,st)))[pt2] + (fst (!!! (config,st)))[pt3] <= nG + nB.
+Proof using .
+intros config st pt1 pt2 pt3 Hpt12 Hpt23 Hpt13.
+rewrite <- (cardinal_fst_obs_from_config config st).
+rewrite <- (add_remove_id pt1 (fst (!!! (config,st))) (reflexivity _)) at 4.
+rewrite cardinal_add.
+rewrite <- (add_remove_id pt2 (fst (!!! (config,st))) (reflexivity _)) at 6.
+rewrite remove_add_comm, cardinal_add; trivial.
+rewrite <- (add_remove_id pt3 (fst (!!! (config,st))) (reflexivity _)) at 8.
+rewrite remove_add_comm, remove_add_comm, cardinal_add; trivial; [].
+lia.
+Qed.
+
+Lemma bivalent_obs_spec : forall config st,
+ bivalent_obs (obs_from_config config st) = true <-> bivalent config.
+Proof using .
+intros config st. unfold bivalent_obs, bivalent.
+assert (Hequiv := obs_from_config_ignore_snd_except_observerlight (origin, witness) config st).
+destruct (obs_from_config config st) as [obs ?] eqn:Hobs. cbn [fst].
+destruct Hequiv as [Hequiv _]. cbn -[equiv] in Hequiv. setoid_rewrite <- Hequiv.
+destruct (support obs) as [| e1 [| e2 [| e3 ?]]] eqn:Hsupport.
+* split; try discriminate; [].
+ intros [Heven [Hn [pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
+ assert (Hin : InA equiv pt1 (support obs)).
+ { rewrite support_spec. unfold In. rewrite Hpt1. apply Exp_prop.div2_not_R0. lia. }
+ rewrite Hsupport, InA_nil in Hin. tauto.
+* split; intro Hcase; try discriminate; [].
+ destruct Hcase as [Heven [Hle [pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
+ elim Hdiff. transitivity e1.
+ + assert (Hin : InA equiv pt1 (support obs)).
+ { rewrite support_spec. unfold In. rewrite Hpt1. apply Exp_prop.div2_not_R0. lia. }
+ now rewrite Hsupport, InA_singleton in Hin.
+ + assert (Hin : InA equiv pt2 (support obs)).
+ { rewrite support_spec. unfold In. rewrite Hpt2. apply Exp_prop.div2_not_R0. lia. }
+ now rewrite Hsupport, InA_singleton in Hin.
+* (* real case *)
+ rewrite Nat.eqb_eq.
+ assert (Hcard := cardinal_fst_obs_from_config config st).
+ rewrite cardinal_fold_support, Hobs in Hcard. simpl fst in Hcard. rewrite Hsupport in Hcard.
+ cbn in Hcard. rewrite Nat.add_0_r in Hcard.
+ split; intro Hcase.
+ + repeat split.
+ - rewrite Hcase in Hcard. exists obs[e2]. lia.
+ - cut (obs[e1] > 0); [lia |].
+ change (In e1 obs). rewrite <- support_spec, Hsupport. now left.
+ - exists e1, e2. rewrite Hcase in *.
+ assert (Hnodup := support_NoDupA obs). rewrite Hsupport in Hnodup.
+ inv Hnodup. rewrite InA_cons, InA_nil in *. cut (obs[e2] = Nat.div2 (nG+nB)); intuition; [].
+ rewrite <- Hcard.
+ clear. induction obs[e2]; trivial; [].
+ rewrite Nat.add_succ_r. cbn. lia.
+ + destruct Hcase as [Heven [Hle [pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
+ assert (Hperm : PermutationA equiv (pt1 :: pt2 :: nil) (e1 :: e2 :: nil)).
+ { assert (Hin1 : In pt1 obs). { unfold In. rewrite Hpt1. apply Exp_prop.div2_not_R0. lia. }
+ assert (Hin2 : In pt2 obs). { unfold In. rewrite Hpt2. apply Exp_prop.div2_not_R0. lia. }
+ rewrite <- Hsupport.
+ apply NoDupA_inclA_length_PermutationA; autoclass.
+ + repeat constructor.
+ - rewrite InA_cons, InA_nil. intuition.
+ - now rewrite InA_nil.
+ + intros x Hx. rewrite 2 InA_cons, InA_nil in Hx. rewrite support_spec.
+ destruct Hx as [Hx | [Hx | Hx]]; tauto || now rewrite Hx.
+ + now rewrite Hsupport. }
+ apply PermutationA_2 in Hperm; autoclass; [].
+ destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]]; rewrite <- Heq1, <- Heq2; congruence.
+* (* Three inhabited locations, thus too many robots
+ as the two towers should already contain all of them *)
+ split; intro Hcase; try discriminate; []. exfalso.
+ destruct Hcase as [Heven [Hle [pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
+ assert (Hin1 : InA equiv pt1 (support obs)).
+ { rewrite support_spec. unfold In. rewrite Hpt1. apply Exp_prop.div2_not_R0. lia. }
+ assert (Hin2 : InA equiv pt2 (support obs)).
+ { rewrite support_spec. unfold In. rewrite Hpt2. apply Exp_prop.div2_not_R0. lia. }
+ rewrite Hsupport in Hin1, Hin2.
+ destruct (PermutationA_3_swap _ Hdiff Hin1 Hin2) as [pt [supp Hsupp]].
+ rewrite <- Hsupport in *.
+ assert (Hneq : pt1 =/= pt /\ pt2 =/= pt).
+ { assert (Hnodup := support_NoDupA obs). rewrite Hsupp in Hnodup.
+ inv Hnodup. inv H2. repeat rewrite InA_cons in *. intuition. }
+ destruct Hneq as [Hneq1 Hneq2].
+ assert (Hcard := sum3_le_total config (0%VS, witness) Hdiff Hneq2 Hneq1).
+ rewrite <- Hequiv, Hpt1, Hpt2 in Hcard.
+ assert (obs[pt] > 0).
+ { change (In pt obs). rewrite <- support_spec, Hsupp, 3 InA_cons. clear. intuition. }
+ apply Nat.Even_double in Heven.
+ unfold Nat.double in *. lia.
+Qed.
+
+Lemma bivalent_obs_spec_st : forall config,
+ (forall st, bivalent_obs (obs_from_config config st) = true) <-> bivalent config.
+Proof using .
+intros config.
+split.
++ intro Hall.
+ specialize (Hall (origin, witness)).
+ now rewrite bivalent_obs_spec in Hall.
++ intros Hbivalent st.
+ now rewrite bivalent_obs_spec.
+Qed.
+
+Lemma bivalent_obs_size : forall obs,
+ bivalent_obs obs = true ->
+ length (support (elt := location) (fst obs)) = 2.
+Proof using Type.
+intros [obs_loc ?]. unfold bivalent_obs. cbn [fst].
+repeat destruct_match; discriminate || reflexivity.
+Qed.
+
+Corollary bivalent_size : forall config st,
+ bivalent config ->
+ length (support (elt := location) (fst (obs_from_config config st))) = 2.
+Proof using Type. intros config st. rewrite <- bivalent_obs_spec. apply bivalent_obs_size. Qed.
+
+Lemma bivalent_support : forall config, bivalent config ->
+ forall st (pt1 pt2 : location),
+ pt1 =/= pt2 ->
+ In pt1 (fst (Obs.(obs_from_config) config st)) ->
+ In pt2 (fst (obs_from_config config st)) ->
+ PermutationA equiv (support (fst (Obs.(obs_from_config) config st))) (cons pt1 (cons pt2 nil)).
+Proof using Type.
+intros config Hbivalent st pt1 pt2 Hdiff Hpt1 Hpt2.
+symmetry.
+apply NoDupA_inclA_length_PermutationA; autoclass.
++ repeat constructor.
+ - now rewrite InA_singleton.
+ - now rewrite InA_nil.
++ intros x Hin. rewrite InA_cons, InA_singleton in Hin.
+ rewrite support_spec.
+ destruct Hin as [Hin | Hin]; rewrite Hin; assumption.
++ eapply bivalent_size with (st := st) in Hbivalent.
+ now rewrite Hbivalent.
+Qed.
+
+Definition color_bivalent_obs (obs : observation) : bool :=
+ let obs_loc := fst obs in
+ let sup := support obs_loc in
+ match sup with
+ | nil => false
+ | pt1 :: nil => false
+ | pt1 :: pt2 :: nil =>
+ (obs_loc[pt1] =? obs_loc[pt2])
+ && (List.forallb
+ (fun col:L => (colors (snd obs))[(pt1,col)] =? (colors (snd obs))[(pt2,col)])
+ l_list)
+ | pt1 :: pt2 :: _ :: _ => false
+ end.
+
+(* TODO: move to the right file *)
+Lemma PermutationA_2_gen :
+ forall [A : Type] [eqA : relation A],
+ Equivalence eqA ->
+ forall (l:list A) (x' y' : A),
+ PermutationA eqA l (x' :: y' :: nil) ->
+ exists x y, (eqA x x' /\ eqA y y' \/ eqA x y' /\ eqA y x')
+ /\ l = (x :: y :: nil).
+Proof using Type.
+ intros A eqA HequiveqA l x' y' h_permut.
+ specialize (@PermutationA_length _ _ _ _ h_permut) as h_length.
+ destruct l as [ | e1 [ | e2 [ | e3 l3]]]; cbn in h_length; try discriminate.
+ exists e1, e2.
+ split;auto.
+ rewrite (PermutationA_2 HequiveqA e1 e2 x' y') in h_permut.
+ destruct h_permut as [[h1 h2] | [h1 h2]];auto.
+Qed.
+
+(* TODO: improve proofs *)
+Local Lemma bivalent_obs_map: forall o whatever (f : Bijection.bijection _),
+ bivalent_obs o = true -> bivalent_obs ((map f (fst o)),whatever) = true.
+Proof using Type.
+ intros o whatever f H0.
+ assert (Hbivalent := H0).
+
+ unfold bivalent_obs in H0 |- *.
+ destruct o as [o1 o2].
+ cbn [fst] in *.
+ assert (PermutationA equiv (List.map f (support o1)) (support (map f o1))) as h_permut.
+ { rewrite map_injective_support;autoclass.
+ - reflexivity.
+ - apply Bijection.injective. }
+ assert (length (List.map f (support o1)) = length (support (map f o1))) as h_length.
+ { now rewrite h_permut. }
+
+ destruct (support o1) as [ |e1 l1] eqn:heq_supo;try discriminate.
+ destruct l1 as [| e2 l2] eqn:heq_supo2;try discriminate.
+ destruct l2 as [| e3 l3] eqn:heq_supo3;try discriminate.
+ cbn [List.map] in h_length.
+ symmetry in h_permut.
+ destruct (PermutationA_2_gen _ h_permut) as [ a [b [[[heq_a heq_b] | [heq_a heq_b]] h_map]]].
+ - rewrite h_map.
+ rewrite Nat.eqb_eq in H0|-*.
+ rewrite heq_a,heq_b.
+ setoid_rewrite map_injective_spec;auto;autoclass.
+ + apply Bijection.injective.
+ + apply Bijection.injective.
+ - rewrite h_map.
+ rewrite Nat.eqb_eq in H0|-*.
+ rewrite heq_a,heq_b.
+ setoid_rewrite map_injective_spec; autoclass; apply Bijection.injective.
+Qed.
+
+Local Lemma bivalent_obs_map_inv: forall o whatever (f : Bijection.bijection _),
+ bivalent_obs ((map f (fst o)),whatever) = true -> bivalent_obs o = true.
+Proof using Type.
+ intros o whatever f h_bivopsmap.
+ assert (Proper (equiv ==> equiv) (λ x0 : location, Bijection.retraction f (f x0))).
+ { repeat intro.
+ now rewrite H. }
+ assert (Proper (equiv ==> equiv) f) as Hproper.
+ { apply Bijection.section_compat. }
+ assert (Preliminary.injective equiv equiv f) as h_proper_f.
+ { apply Bijection.injective. }
+ assert ( Preliminary.injective equiv equiv (λ x0 : location, Bijection.retraction f (f x0))) as h_proper_finv.
+ { repeat intro.
+ setoid_rewrite Bijection.retraction_section in H0.
+ assumption. }
+
+ unfold bivalent_obs in h_bivopsmap|-*.
+ destruct o as [o1 o2].
+ cbn [fst] in *.
+ assert (PermutationA equiv (List.map f (support o1)) (support (map f o1))) as h_permut.
+ { rewrite map_injective_support;auto;autoclass.
+ reflexivity. }
+ assert (length (List.map f (support o1)) = length (support (map f o1))) as h_length.
+ { now rewrite h_permut. }
+ symmetry in h_permut.
+
+ destruct (support o1) as [ |e1 l1] eqn:heq_supo;
+ destruct (support (map f o1));try now (cbn in * ; discriminate).
+ destruct l1; destruct l0;try now (cbn in * ; discriminate).
+ destruct l2; destruct l3;try now (cbn in * ; discriminate).
+ assert (o1 == (map (Bijection.retraction f) (map f o1))).
+ {
+ rewrite map_merge;auto.
+ 2: apply Bijection.retraction_compat;auto.
+ repeat intro.
+ assert (x == (λ x0 : location, Bijection.retraction f (f x0)) x).
+ { symmetry. apply Bijection.retraction_section. }
+ rewrite H0 at 2.
+ change (Bijection.retraction f (f x)) with ((λ x0 : location, Bijection.retraction f (f x0)) x).
+ rewrite map_injective_spec;auto. }
+ apply Nat.eqb_eq in h_bivopsmap.
+ apply Nat.eqb_eq.
+ destruct (PermutationA_2_gen _ h_permut) as [ a [b [[[heq_a heq_b] | [heq_a heq_b]] h_map]]].
+ - inversion h_map.
+ rewrite H2,H3,heq_a, heq_b in h_bivopsmap.
+ setoid_rewrite map_injective_spec in h_bivopsmap;auto.
+ - inversion h_map.
+ rewrite H2,H3,heq_a, heq_b in h_bivopsmap.
+ setoid_rewrite map_injective_spec in h_bivopsmap;auto.
+Qed.
+
+Corollary bivalent_obs_morph_strong : forall obs (f : Bijection.bijection _) whatever,
+ bivalent_obs ((map f (fst obs)), whatever) = bivalent_obs obs.
+Proof using Type.
+intros obs f whatever.
+destruct (bivalent_obs obs) eqn:Hcase.
++ now apply bivalent_obs_map.
++ rewrite <- Bool.not_true_iff_false in *.
+ intro Habs. eapply Hcase, bivalent_obs_map_inv, Habs.
+Qed.
+
+Corollary bivalent_obs_morph : forall f obs,
+ bivalent_obs (map_obs f obs) = bivalent_obs obs.
+Proof using Type. intros. apply bivalent_obs_morph_strong. Qed.
+
+Lemma permut_forallb_ext:
+ (forall A (l: list A) (f g: A -> bool),
+ (forall a: A, f a = g a) ->
+ forallb f l = forallb g l).
+Proof using Type.
+ intros A l f g H.
+ induction l;auto.
+ cbn.
+ now rewrite H,IHl.
+Qed.
+
+Lemma permut_forallb:
+ (forall A (l1 l2: list A) (f g: A -> bool),
+ (forall a: A, f a = g a) ->
+ PermutationA eq l1 l2 ->
+ forallb f l1 = forallb g l2).
+Proof using Type.
+ intros A l3 l4 f g Hext Hpermut.
+ induction Hpermut.
+ + reflexivity.
+ + rewrite H.
+ cbn.
+ rewrite IHHpermut.
+ rewrite Hext.
+ reflexivity.
+ + cbn.
+ repeat rewrite Hext.
+ repeat rewrite Bool.andb_assoc.
+ rewrite (Bool.andb_comm (g y) (g x)).
+ rewrite permut_forallb_ext with (g:=g);auto.
+ + transitivity (forallb g lâ‚‚);auto.
+ rewrite permut_forallb_ext with (g:=f);auto.
+Qed.
+
+Instance color_bivalent_obs_compat: Proper (equiv ==> eq) color_bivalent_obs.
+Proof using Type.
+ intros [o1 o1'] [o2 o2'] [Hfst Hsnd].
+ unfold color_bivalent_obs.
+ cbn [fst snd] in *.
+ assert (Hperm := support_compat Hfst).
+ assert (Hlen := PermutationA_length Hperm).
+ repeat destruct_match; auto; cbn in Hlen; try discriminate; [].
+ rewrite PermutationA_2 in Hperm; [| now autoclass].
+ assert (Heq : (o1[l] =? o1[l1]) = (o2[l3] =? o2[l5])).
+ { destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]].
+ - now rewrite Hfst, Heq1, Heq2.
+ - now rewrite Hfst, Heq1, Heq2, Nat.eqb_sym. }
+ rewrite Heq.
+ f_equal.
+ cbn.
+ apply permut_forallb.
+ - intros a.
+ destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]];auto.
+ + f_equal.
+ * rewrite (colors_compat2 Hsnd).
+ apply MMultisetWMap.pre_multiplicity_compat;auto; try typeclasses eauto.
+ reflexivity.
+ * rewrite (colors_compat2 Hsnd).
+ apply MMultisetWMap.pre_multiplicity_compat;auto; try typeclasses eauto.
+ reflexivity.
+ + rewrite Nat.eqb_sym at 1.
+ f_equal.
+ * rewrite (colors_compat2 Hsnd).
+ apply MMultisetWMap.pre_multiplicity_compat;auto; try typeclasses eauto.
+ reflexivity.
+ * rewrite (colors_compat2 Hsnd).
+ apply MMultisetWMap.pre_multiplicity_compat;auto; try typeclasses eauto.
+ reflexivity.
+ - reflexivity.
+Qed.
+
+Lemma color_bivalent_obs_bivalent_obs:
+ forall o, color_bivalent_obs o = true -> bivalent_obs o = true.
+Proof using Type.
+ intros o h.
+ unfold color_bivalent_obs, bivalent_obs in *.
+ destruct (support (fst o)) as [ | e1 [ | e2 [ | e3 l3]] ];try now (contradict h;auto).
+ apply andb_prop in h.
+ destruct h as [h1 h2].
+ assumption.
+Qed.
+
+
+(*
+(* In a bivalent configuration, the number of robots on the towers at pt1 and pt2 are the same. *)
+Local Lemma color_bivalent_same_cardinal :
+ forall config, forall pt1 pt2 : location,
+ pt1 =/= pt2 ->
+ (forall pt l, pt =/= pt1 -> pt=/= pt2 -> (!! config)[(pt, l)] = 0) ->
+ (forall l : L, (!!config) [(pt1, l)] = (!!config) [(pt2, l)]) ->
+ cardinal (filter (fun obs => if fst obs =?= pt1 then true else false) (!! config))
+ = cardinal (filter (fun obs => if fst obs =?= pt2 then true else false) (!! config)).
+Proof.
+intros config pt1 pt2 Hdiff Hother Hsame.
+rewrite 2 cardinal_filter_elements; try apply obs_compat; [].
+assert (Hnodup := elements_NoDupA (!! config)).
+assert (Hsame' : forall l n, InA eq_pair (pt1, l, n) (elements (!! config))
+ <-> InA eq_pair (pt2, l, n) (elements (!! config))).
+{ intros. rewrite 2 elements_spec. cbn. now rewrite Hsame. }
+clear Hsame Hother. rename Hsame' into Hsame. generalize 0 as i.
+induction (elements (!! config)) as [l Hrec] using list_len_ind; intro i; trivial; [].
+destruct l as [| [[pt li] n] l]; auto; []. cbn.
+assert (Hcompat : forall pt, Proper (equiv ==> eq)
+ (fun obs : location * L * nat => if fst (fst obs) =?= pt then true else false)).
+{ intros x [[] ?] [[] ?] [[] ?]. cbn in *.
+ do 2 destruct_match; auto; elim c; etransitivity; try eassumption; eauto. }
+assert (Hfold : Proper (PermutationA eq_pair ==> eq ==> eq)
+ (fold_left (fun (acc : nat) (xn : location * L * nat) => snd xn + acc))).
+{ apply fold_left_symmetry_PermutationA.
+ + intros ? ? ? [] [] []. cbn in *. lia.
+ + intros [] [] ?. lia. }
+do 2 destruct_match.
+* (* Absurd case: pt1 == pt2 *)
+ elim Hdiff. etransitivity; try eassumption; eauto.
+* (* Real case: pt == pt1 *)
+ assert (Hin' : InA eq_pair (pt2, li, n) ((pt, li, n) :: l)).
+ { rewrite <- Hsame. left. repeat split; cbn; auto. }
+ inversion_clear Hin'; try (now cbn in *; elim c; symmetry); [].
+ revert_one InA. intro Hin'. apply PermutationA_split in Hin'; autoclass; [].
+ destruct Hin' as [l' Hperm]. cbn.
+ setoid_rewrite (Hfold _ _ (filter_PermutationA_compat (Hcompat pt1) Hperm) (n+i) (n+i) eq_refl).
+ setoid_rewrite (Hfold _ _ (filter_PermutationA_compat (Hcompat pt2) Hperm) i i eq_refl).
+ cbn. setoid_rewrite (equiv_dec_refl pt2). destruct_match; try (now elim Hdiff); [].
+ cbn. apply Hrec.
+ + rewrite Hperm. cbn. lia.
+(* + intros x Hx. apply Hin. rewrite Hperm. now do 2 right. *)
+ + inv Hnodup. revert_all. intro Hgoal. assert (Hperm' := Hperm).
+ apply (PermutationA_subrelation_compat subrelation_pair_elt eq_refl eq_refl) in Hperm'.
+ rewrite Hperm' in Hgoal. now inv Hgoal.
+ + intros. split; intro Hpt.
+ - assert (Hin_l' : InA eq_pair (pt1, l0, n0) ((pt, li, n) :: l)).
+ { rewrite Hperm. now do 2 right. }
+ rewrite Hsame in Hin_l'. rewrite Hperm in Hin_l'.
+ inv Hin_l'.
+ ++ elim c. symmetry. hnf in * |-. cbn in *. auto.
+ ++ inv H0; trivial; [].
+ assert (Hperm' := Hperm).
+ apply (PermutationA_subrelation_compat subrelation_pair_elt eq_refl eq_refl) in Hperm'.
+ rewrite Hperm' in Hnodup. exfalso.
+ inv Hnodup. revert_one not. intro Habs. apply Habs.
+ right. apply InA_pair_elt with (n:=n0). revert_one eq_pair. intros [[? Hl] ?]. cbn in *.
+ revert Hpt. apply InA_eqA; autoclass; []. now repeat split; cbn.
+ - assert (Hin_l' : InA eq_pair (pt2, l0, n0) ((pt, li, n) :: l)).
+ { rewrite Hperm. now do 2 right. }
+ rewrite <- Hsame in Hin_l'. rewrite Hperm in Hin_l'.
+ inv Hin_l'.
+ ++ revert_one eq_pair. intros [[? Hl] ?]. cbn in *.
+ assert (Hperm' := Hperm).
+ apply (PermutationA_subrelation_compat subrelation_pair_elt eq_refl eq_refl) in Hperm'.
+ rewrite Hperm' in Hnodup. exfalso.
+ inv Hnodup. revert_one not. intros _.
+ inv H4. revert_one not. intros Habs. apply Habs.
+ apply InA_pair_elt with (n:=n).
+ revert Hpt. apply InA_eqA; autoclass; []. now repeat split; cbn.
+ ++ inv H0; trivial; [].
+ elim c. symmetry. hnf in * |-. cbn in *. auto.
+* (* Real case: pt == pt2 *)
+ assert (Hin' : InA eq_pair (pt1, li, n) ((pt, li, n) :: l)).
+ { rewrite Hsame. left. repeat split; cbn; auto. }
+ inversion_clear Hin'; try (now cbn in *; elim c; symmetry); [].
+ revert_one InA. intro Hin'. apply PermutationA_split in Hin'; autoclass; [].
+ destruct Hin' as [l' Hperm]. cbn.
+ setoid_rewrite (Hfold _ _ (filter_PermutationA_compat (Hcompat pt1) Hperm) i i eq_refl).
+ setoid_rewrite (Hfold _ _ (filter_PermutationA_compat (Hcompat pt2) Hperm) (n+i) (n+i) eq_refl).
+ cbn. setoid_rewrite (equiv_dec_refl pt1). destruct_match; try (now elim Hdiff); [].
+ cbn. apply Hrec.
+ + rewrite Hperm. cbn. lia.
+(* + intros x Hx. apply Hin. rewrite Hperm. now do 2 right. *)
+ + inv Hnodup. revert_all. intro Hgoal. assert (Hperm' := Hperm).
+ apply (PermutationA_subrelation_compat subrelation_pair_elt eq_refl eq_refl) in Hperm'.
+ rewrite Hperm' in Hgoal. now inv Hgoal.
+ + intros. split; intro Hpt.
+ - assert (Hin_l' : InA eq_pair (pt1, l0, n0) ((pt, li, n) :: l)).
+ { rewrite Hperm. now do 2 right. }
+ rewrite Hsame in Hin_l'. rewrite Hperm in Hin_l'.
+ inv Hin_l'.
+ ++ revert_one eq_pair. intros [[? Hl] ?]. cbn in *.
+ assert (Hperm' := Hperm).
+ apply (PermutationA_subrelation_compat subrelation_pair_elt eq_refl eq_refl) in Hperm'.
+ rewrite Hperm' in Hnodup. exfalso.
+ inv Hnodup. revert_one not. intros _.
+ inv H4. revert_one not. intros Habs. apply Habs.
+ apply InA_pair_elt with (n:=n).
+ revert Hpt. apply InA_eqA; autoclass; []. now repeat split; cbn.
+ ++ inv H0; trivial; [].
+ elim Hdiff. symmetry. hnf in * |-. cbn in *. auto.
+ - assert (Hin_l' : InA eq_pair (pt2, l0, n0) ((pt, li, n) :: l)).
+ { rewrite Hperm. now do 2 right. }
+ rewrite <- Hsame in Hin_l'. rewrite Hperm in Hin_l'.
+ inv Hin_l'.
+ ++ elim c. symmetry. hnf in * |-. cbn in *. auto.
+ ++ inv H0; trivial; [].
+ assert (Hperm' := Hperm).
+ apply (PermutationA_subrelation_compat subrelation_pair_elt eq_refl eq_refl) in Hperm'.
+ rewrite Hperm' in Hnodup. exfalso.
+ inv Hnodup. revert_one not. intro Habs. apply Habs.
+ right. apply InA_pair_elt with (n:=n0). revert_one eq_pair. intros [[? Hl] ?]. cbn in *.
+ revert Hpt. apply InA_eqA; autoclass; []. now repeat split; cbn.
+* (* Real case: pt =/= pt1, pt2 *)
+ apply Hrec.
+ + cbn. lia.
+(* + intros x Hx. apply Hin. now right. *)
+ + now inv Hnodup.
+ + intros. split; intro Hpt.
+ - assert (Hin_l' : InA eq_pair (pt1, l0, n0) ((pt, li, n) :: l)) by now right.
+ rewrite Hsame in Hin_l'. inv Hin_l'; trivial; [].
+ revert_one eq_pair. intros [[? Hl] ?]. cbn in *. now elim c0.
+ - assert (Hin_l' : InA eq_pair (pt2, l0, n0) ((pt, li, n) :: l)) by now right.
+ rewrite <- Hsame in Hin_l'. inv Hin_l'; trivial; [].
+ revert_one eq_pair. intros [[? Hl] ?]. cbn in *. now elim c.
+Qed.
+*)
+Lemma color_bivalent_bivalent : forall config,
+ color_bivalent config -> bivalent config.
+Proof using Type.
+ intros config H.
+ unfold bivalent.
+ unfold color_bivalent in H.
+ decompose [and ex] H.
+ clear H.
+ intuition.
+ exists x, x0.
+ split;auto.
+Qed.
+
+Corollary color_bivalent_even : forall config,
+ color_bivalent config -> Nat.Even (nG + nB).
+Proof using Type.
+intros config Hconfig. apply color_bivalent_bivalent in Hconfig.
+now destruct Hconfig.
+Qed.
+
+(* Lemma bivalent_size :
+ forall config st, bivalent config -> size (fst (!!! (config,st))) = 2.
+Proof using . intros. rewrite size_spec. now apply bivalent_support. Qed. *)
+
+Lemma invalid_strengthen : (*nB = 0 -> *) forall config st,
+ bivalent config ->
+ { pt1 : location &
+ { pt2 : location | (* fixindent *)
+ pt1 =/= pt2 &
+ fst (!!! (config,st)) == add pt1 (Nat.div2 (nG+nB)) (singleton pt2 (Nat.div2 (nG+nB))) } }.
+Proof using .
+intros config st Hconfig.
+(* Because we want a computational goal and the hypothesis is not,
+ we first destruct the support to get the elements and only then
+ prove that they are the same as the one given in [invalid]. *)
+assert (Hlen := bivalent_size st Hconfig).
+destruct (support (fst (!!! (config,st)))) as [| pt1 [| pt2 [| ? ?]]] eqn:Hsupp; try discriminate; [].
+(* Transforming sig2 into sig to have only one goal after instanciating pt1 and pt2 *)
+cut {pt1 : location & {pt2 : location
+ | pt1 =/= pt2 /\ fst (!!! (config,st)) == add pt1 (Nat.div2 (nG+nB)) (singleton pt2 (Nat.div2 (nG+nB)))}}.
+{ intros [? [? [? ?]]]. eauto. }
+exists pt1, pt2.
+destruct Hconfig as [Heven [Hge2 [pt1' [pt2' [Hdiff [Hpt1' Hpt2']]]]]].
+(* Both couples of points are the same *)
+assert (!!! (config, st) == (fst (!!! (config, st)), snd (!!! (config, st)))) as hsurj.
+{ rewrite surjective_pairing at 1.
+ reflexivity. }
+specialize (@obs_from_config_fst st config (fst (!!! (config, st))) (snd (!!! (config, st))) hsurj (origin,witness)) as hfst.
+
+assert (Hcase : pt1' == pt1 /\ pt2' == pt2 \/ pt1' == pt2 /\ pt2' == pt1).
+{ assert (Hin1 : InA equiv pt1' (pt1 :: pt2 :: nil)).
+ { rewrite <- Hsupp, support_spec. unfold In.
+ rewrite hfst.
+ rewrite Hpt1'.
+ destruct (nG+nB) as [| [| nG]] eqn:heqnB ; simpl; try lia.
+ set (d := (Nat.div2 nG)).
+ lia. }
+ assert (Hin2 : InA equiv pt2' (pt1 :: pt2 :: nil)).
+ { rewrite <- Hsupp, support_spec. unfold In.
+ rewrite hfst.
+ rewrite Hpt2'.
+ destruct (nG+nB) as [| [| nG]] eqn:heqnB; simpl; try lia.
+ set (d := (Nat.div2 nG)).
+ lia. }
+ rewrite 2 InA_cons, InA_nil in Hin1, Hin2. clear -Hin1 Hin2 Hdiff.
+ decompose [or] Hin1; decompose [or] Hin2; tauto || elim Hdiff; etransitivity; eauto. }
+split.
++ intro. apply Hdiff.
+ decompose [and or] Hcase; repeat (etransitivity; eauto; symmetry).
++ symmetry. apply cardinal_total_sub_eq.
+ - intro pt. rewrite add_spec, singleton_spec.
+ repeat destruct_match;
+ destruct Hcase as [[Heq1 Heq2] | [Heq1 Heq2]];
+ rewrite Heq1,Heq2 in *;
+ try match goal with H : pt == _ |- _ => rewrite H in *; clear H end;
+ try (now elim Hdiff);
+ rewrite ?hfst, ?hsurj, ?Hpt1', ?Hpt2';
+ lia.
+ - rewrite cardinal_add, cardinal_singleton, (cardinal_obs_from_config config (origin, witness)).
+ now apply even_div2.
+Qed.
+
+Lemma bivalent_same_location: forall config st pt1 pt2 pt3, bivalent config ->
+ In pt1 (fst (!!! (config,st))) -> In pt2 (fst (!!! (config,st))) -> In pt3 (fst (!!! (config,st))) ->
+ pt1 =/= pt3 -> pt2 =/= pt3 -> pt1 == pt2.
+Proof using .
+intros config st pt1 pt2 pt3 Hinvalid Hin1 Hin2 Hin3 Hdiff13 Hdiff23.
+destruct (invalid_strengthen st Hinvalid) as [pta [ptb Hdiff Hobs]].
+rewrite Hobs, add_In, In_singleton in Hin1, Hin2, Hin3.
+destruct Hin1 as [[] | []], Hin2 as [[] | []], Hin3 as [[] | []];
+solve [ etransitivity; eauto
+ | elim Hdiff13; etransitivity; eauto
+ | elim Hdiff23; etransitivity; eauto ].
+Qed.
+Arguments bivalent_same_location config st {pt1} {pt2} pt3 _ _ _ _ _.
+
+Lemma bivalent_other_locs : forall config, bivalent config ->
+ forall pt1 pt2, pt1 =/= pt2 -> In pt1 (!! config) -> In pt2 (!! config) ->
+ forall pt, pt =/= pt1 -> pt =/= pt2 -> (!! config)[pt] = 0.
+Proof using Type.
+intros config Hbivalent pt1 pt2 Hdiff Hpt1 Hpt2 pt Hneq1 Hneq2.
+destruct (Nat.eq_0_gt_0_cases (!!config)[pt]) as [| Hlt]; trivial; [].
+elim Hdiff. apply (bivalent_same_location _ _ pt Hbivalent Hpt1 Hpt2); intuition.
+Qed.
+
+Lemma obs_fst : forall config, !! config == fst (!!!(config, (origin, witness))).
+Proof using Type. reflexivity. Qed.
+
+Lemma fold_obs_fst : forall st config, fst (!!!(config, st)) == !! config.
+Proof using Type. reflexivity. Qed.
+
+Definition bivalent_extended (config : configuration) :=
+ let n := nG + nB in
+ Nat.Even n /\ n >=2 /\ exists pt1 pt2 : location, pt1 =/= pt2
+ /\ (!! config)[pt1] = Nat.div2 n /\ (!! config)[pt2] = Nat.div2 n
+ /\ support (!! config) = cons pt1 (cons pt2 nil)
+ /\ (forall pt, In pt (!! config) -> pt == pt1 \/ pt == pt2)
+ /\ forall pt, pt =/= pt1 -> pt =/= pt2 -> (!! config)[pt] = 0.
+
+Lemma extend_bivalent : forall config,
+ bivalent config <-> bivalent_extended config.
+Proof using Type.
+intro config. split; intro Hbivalent.
+* assert (Hlen := bivalent_size (origin, witness) Hbivalent).
+ rewrite <- obs_fst in Hlen.
+ assert (Hnodup := support_NoDupA (!! config)).
+ destruct Hbivalent as [Heven [Hle [pt1 [pt2 [Hdiff [Hpt1 Hpt2]]]]]].
+ repeat split; trivial; [].
+ destruct (support (!! config)) as [| pt [| pt' [|]]] eqn:Hsupp; try discriminate; [].
+ exists pt, pt'.
+ assert (Hperm : PermutationA equiv (cons pt (cons pt' nil)) (cons pt1 (cons pt2 nil))).
+ { rewrite <- Hsupp.
+ symmetry. apply NoDupA_inclA_length_PermutationA; autoclass.
+ + repeat constructor; rewrite ?InA_cons, InA_nil; intuition.
+ + intros x Hin. rewrite InA_cons, InA_singleton in Hin.
+ rewrite support_spec. unfold In.
+ assert (Nat.div2 (nG + nB) > 0). { apply Exp_prop.div2_not_R0. lia. }
+ destruct Hin as [Heq | Heq]; rewrite Heq; lia.
+ + rewrite Hsupp. reflexivity. }
+ rewrite PermutationA_2 in Hperm.
+ repeat split.
+ + inv Hnodup. now rewrite InA_singleton in *.
+ + now destruct Hperm as [[Heq _] | [Heq _]]; rewrite Heq.
+ + now destruct Hperm as [[_ Heq] | [_ Heq]]; rewrite Heq.
+ + intros x Hin. now rewrite <- support_spec, Hsupp, InA_cons, InA_singleton in Hin.
+ + intros x Hpt Hpt'.
+ destruct (Nat.eq_0_gt_0_cases (!! config)[x]) as [Heq | Hlt]; trivial; [].
+ exfalso. change (In x (!! config)) in Hlt.
+ rewrite <- support_spec, Hsupp, InA_cons, InA_singleton in Hlt. intuition.
+ + autoclass.
+* destruct Hbivalent as [Heven [Hle [pt1 [pt2 [Hdiff [Hpt1 [Hpt2 [Hsupp Hother]]]]]]]].
+ repeat split; eauto.
+Qed.
+
+
+Lemma bivalent_min: forall c,
+ bivalent c ->
+ nG + nB >= 2.
+Proof using Type.
+ intros c h_biv.
+ unfold bivalent in h_biv.
+ now decompose [and] h_biv.
+Qed.
+
+
+Lemma biv_col_size: forall c,
+ color_bivalent c ->
+ size (!! c) = 2.
+Proof using Type.
+ intros c h_bivcol.
+ apply color_bivalent_bivalent in h_bivcol.
+ apply bivalent_size with (st := (origin,witness)) in h_bivcol.
+ rewrite <- h_bivcol.
+ rewrite obs_from_ok2.
+ apply size_spec.
+Qed.
+
+Lemma biv_col_supp: forall c,
+ color_bivalent c ->
+ exists pt1 pt2, support (!! c) = (pt1::pt2::nil).
+Proof using Type.
+ intros c h_bivcol.
+ specialize (biv_col_size h_bivcol) as h_size.
+ rewrite size_spec in h_size.
+ destruct (support (!! c)) as [ | x [ | y [ | z l] ]] eqn:heq_supp; try now (exfalso; cbn in h_size;lia).
+ eauto.
+Qed.
+
+Lemma biv_col_supp2: forall c st,
+ color_bivalent c ->
+ exists pt1 pt2, support (fst (!!! (c,st))) = (pt1::pt2::nil).
+Proof using Type.
+ intros c st h_bivcol.
+ specialize (biv_col_size h_bivcol) as h_size.
+ rewrite size_spec in h_size.
+ destruct (support (!! c)) as [ | x [ | y [ | z l] ]] eqn:heq_supp; try now (exfalso; cbn in h_size;lia).
+ eauto.
+Qed.
+
+Lemma colors_indep:
+ forall c st st',
+ (colors (snd (!!! (c, st))))
+ == (colors (snd (!!! (c, st')))).
+Proof using Type.
+ intros c st st'.
+ destruct (!!! (c, st)) eqn:heq.
+ destruct (!!! (c, st')) eqn:heq'.
+ cbn in *.
+ unfold obs_from_config, Obs in *.
+ cbn in *.
+ inversion heq.
+ inversion heq'.
+ reflexivity.
+Qed.
+
+#[export]
+Instance pair_compat_ours {A B} {SA : Setoid A} {SB : Setoid B}: Proper (equiv ==> equiv ==> equiv) (@pair A B).
+Proof using Type.
+ repeat intro.
+ split;cbn;auto.
+Qed.
+
+(* Remove Hints pair_compat: typeclass_instances. *)
+
+Lemma color_bivalent_correct : forall config st,
+ color_bivalent_obs (obs_from_config config st) = true -> color_bivalent config.
+Proof using .
+ intros config st h_bivobs.
+ specialize (color_bivalent_obs_bivalent_obs _ h_bivobs) as h_biv.
+ rewrite bivalent_obs_spec in h_biv.
+ red in h_biv.
+ destruct h_biv as [heq_n [h_lt_n _]].
+ revert h_bivobs.
+ unfold color_bivalent, color_bivalent_obs.
+ repeat (destruct_match; subst; try discriminate).
+ intros h_and.
+ split;auto.
+ split;auto.
+
+ apply andb_prop in h_and.
+ destruct h_and as [ heq_loc h_forall].
+ apply Nat.eqb_eq in heq_loc.
+ rewrite <- (obs_from_config_fst_ok (origin, witness)) in heq_loc.
+ rewrite forallb_forall in h_forall.
+ setoid_rewrite Nat.eqb_eq in h_forall.
+
+ specialize (obs_from_config_fst_spec config (origin,witness)) as h.
+ specialize (h l) as h_l.
+ specialize (h l1) as h_l1.
+ clear h.
+ assert (h_cardinal := cardinal_fst_obs_from_config config (origin,witness)).
+ rewrite <- obs_fst in h_cardinal.
+ rewrite cardinal_fold_support in h_cardinal.
+ rewrite <- obs_from_config_fst_ok with (st:=(0%VS, witness)) in H.
+ rewrite H in h_cardinal.
+ cbn in h_cardinal.
+ rewrite Nat.add_0_r in h_cardinal.
+ specialize (support_NoDupA (!! config)) as h.
+ rewrite H in h.
+ apply NoDupA_2 in h.
+ exists l, l1.
+ split;auto.
+ rewrite heq_loc in h_cardinal.
+ match type of h_cardinal with
+ ?A + ?A = ?B => replace (A + A) with (2 * A) in h_cardinal
+ end.
+ 2:{ lia. }
+ rewrite <- h_cardinal.
+ rewrite Nat.div2_double.
+ rewrite Forall_forall.
+ repeat split;auto.
+Qed.
+
+
+
+Lemma color_bivalent_complete : forall config st,
+ color_bivalent config -> color_bivalent_obs (obs_from_config config st) = true.
+Proof using .
+ intros c st h_bivcol.
+ specialize (color_bivalent_bivalent h_bivcol) as h_biv.
+ assert ((nG + nB) >= 2) as h_n_le_2.
+ { apply (bivalent_min h_biv). }
+ assert (Nat.div2 (nG + nB) >= 1) as h_div2n_lt_2.
+ { apply Exp_prop.div2_not_R0. lia. }
+ specialize (bivalent_obs_spec c st) as h_biv_obs.
+ destruct h_biv_obs as [h_biv1 h_biv2].
+ specialize (h_biv2 h_biv).
+ clear h_biv1.
+ specialize (invalid_strengthen st h_biv) as h_biv_str.
+ destruct h_biv_str as [pt [pt' h_pt heq_obsmulti1]].
+ specialize obs_from_config_fst_ok with (st:=(@origin _ _ _ VS, @witness Lght)) (st':=st) (c:=c) as heq_obsmulti2.
+
+ unfold color_bivalent in h_bivcol.
+ unfold color_bivalent_obs.
+ destruct h_bivcol as [ h_even [ h_n [ pt1 [pt2 [h_neq [h_mult_pt1 [h_mult_pt2 h_Forall ]]]]]]].
+
+ destruct (!!! (c, st)) eqn:heq_ofc.
+ cbn [snd fst] in *.
+ assert (PermutationA equiv (support o) (support (add pt (Nat.div2 (nG + nB)) (singleton pt' (Nat.div2 (nG + nB)))))) as h_supp.
+ { rewrite heq_obsmulti1.
+ reflexivity. }
+ rewrite support_add in h_supp;auto.
+ destruct (In_dec pt (singleton pt' (Nat.div2 (nG + nB)))).
+ { exfalso.
+ rewrite In_singleton in i.
+ destruct i.
+ contradiction. }
+ rewrite support_singleton in h_supp;auto.
+
+ assert (PermutationA equiv (pt::pt'::nil) (pt1::pt2::nil) ) as h_ptpt'.
+ { rewrite <- h_supp.
+ assert (InA equiv pt1 (support o)).
+ { rewrite support_spec.
+ unfold In.
+ rewrite <- heq_obsmulti2.
+ lia. }
+ assert (InA equiv pt2 (support o)).
+ { rewrite support_spec.
+ unfold In.
+ rewrite <- heq_obsmulti2.
+ lia. }
+ rewrite h_supp in *.
+ repeat rewrite InA_cons in *.
+ rewrite InA_nil in *.
+ symmetry.
+ apply PermutationA_2;autoclass.
+ clear -H H0 h_neq h_pt.
+ intuition.
+ - assert (pt1 == pt2).
+ { transitivity pt;auto. }
+ contradiction.
+ - assert (pt1 == pt2).
+ { transitivity pt';auto. }
+ contradiction. }
+
+ specialize (permA_trans h_supp h_ptpt') as h_trans_permA.
+
+ destruct (PermutationA_2_gen _ h_trans_permA) as [ptx [pty [[[h_ptx h_pty] | [h_ptx h_pty]] h_l]]].
+ - rewrite PermutationA_2 in h_ptpt';[|autoclass].
+ rewrite h_l.
+ apply Bool.andb_true_iff.
+ split.
+ + rewrite h_ptx,h_pty.
+ rewrite heq_obsmulti1.
+ apply Nat.eqb_eq.
+ destruct h_ptpt' as [ [heq_pt heq_pt'] | [heq_pt heq_pt'] ];
+ rewrite <-heq_pt, <-heq_pt', add_same, add_other; (try assumption);
+ try (now symmetry);
+ rewrite singleton_same,singleton_other;auto.
+ + apply forallb_forall.
+ intros a h_in_a_l_list.
+ rewrite Forall_forall in h_Forall.
+ apply Nat.eqb_eq.
+ change (!!! (c, st)) with ( fst (!!! (c, st)), snd (!!! (c, st))) in heq_ofc.
+ change o0 with (snd (o,o0)).
+ apply h_Forall in h_in_a_l_list.
+ rewrite (colors_indep c (0%VS, witness) st) in h_in_a_l_list.
+ rewrite <- heq_ofc.
+ destruct h_ptpt' as [ [heq_pt heq_pt'] | [heq_pt heq_pt'] ];
+ rewrite h_ptx,h_pty;
+ apply h_in_a_l_list.
+ - rewrite PermutationA_2 in h_ptpt';[|autoclass].
+ rewrite h_l.
+ apply Bool.andb_true_iff.
+ split.
+ + rewrite h_ptx,h_pty.
+ rewrite heq_obsmulti1.
+ apply Nat.eqb_eq.
+ destruct h_ptpt' as [ [heq_pt heq_pt'] | [heq_pt heq_pt'] ];
+ rewrite <-heq_pt, <-heq_pt', add_same, add_other; (try assumption);
+ try (now symmetry);
+ rewrite singleton_same,singleton_other;auto.
+ + apply forallb_forall.
+ intros a h_in_a_l_list.
+ rewrite Forall_forall in h_Forall.
+ apply Nat.eqb_eq.
+ change (!!! (c, st)) with ( fst (!!! (c, st)), snd (!!! (c, st))) in heq_ofc.
+ change o0 with (snd (o,o0)).
+ apply h_Forall in h_in_a_l_list.
+ rewrite (colors_indep c (0%VS, witness) st) in h_in_a_l_list.
+ rewrite <- heq_ofc.
+ destruct h_ptpt' as [ [heq_pt heq_pt'] | [heq_pt heq_pt'] ];
+ rewrite h_ptx,h_pty;
+ symmetry;
+ apply h_in_a_l_list.
+Qed.
+
+Corollary color_bivalent_obs_spec : forall config st,
+ color_bivalent_obs (obs_from_config config st) = true <-> color_bivalent config.
+Proof using . intros. split; eauto using color_bivalent_correct, color_bivalent_complete. Qed.
+
+
+Lemma bivalent_dec : forall config, {bivalent config} + {~bivalent config}.
+Proof using .
+intros config.
+destruct (bivalent_obs (!!! (config, (origin, witness)))) eqn:Hcase.
++ left. now rewrite bivalent_obs_spec in Hcase.
++ right. now rewrite <- bivalent_obs_spec, Hcase.
+Qed.
+
+Lemma color_bivalent_dec : forall config, {color_bivalent config} + {~color_bivalent config}.
+Proof using .
+intros config.
+destruct (color_bivalent_obs (!!! (config, (origin, witness)))) eqn:Hcase.
++ left. now rewrite color_bivalent_obs_spec in Hcase.
++ right. now rewrite <- color_bivalent_obs_spec, Hcase.
+Qed.
+
+
+Lemma bivalent_sim : forall (sim : similarity location) Psim obs,
+ bivalent (map_config (lift (existT precondition sim Psim)) obs) <-> bivalent obs.
+Proof using Type.
+intros sim Psim obs.
+rewrite <- 2 bivalent_obs_spec; trivial; [].
+rewrite obs_from_config_map with (st := (origin, witness)).
++ rewrite bivalent_obs_morph. reflexivity.
++ apply Bijection.section_compat.
++ apply injective.
+Qed.
+
+Lemma color_bivalent_obs_morph : forall f obs,
+ color_bivalent_obs (map_obs f obs) = color_bivalent_obs obs.
+Proof using Type.
+intros f [obs_loc obs_light].
+unfold color_bivalent_obs in *. cbn -[equiv support].
+assert (Hperm := map_injective_support (Bijection.section_compat f) (Bijection.injective f) obs_loc).
+assert (Hlen := PermutationA_length Hperm).
+destruct (support (map f obs_loc)) as [| pt1' [| pt2' []]],
+ (support obs_loc) as [| pt1 [| pt2 []]];
+cbn in Hlen; try discriminate || reflexivity; [].
+cbn in Hperm. rewrite PermutationA_2 in Hperm; [| now autoclass].
+destruct Hperm as [[Heq1 Heq2] | [Heq1 Heq2]]; rewrite Heq1, Heq2;
+(rewrite 2 map_injective_spec; try apply Bijection.injective; [| now autoclass | now autoclass]).
++ f_equal. f_equiv.
+ intros ? c ?. subst. rewrite Heq1, Heq2.
+ change (f ?A, c) with ((λ x, (f (fst x), snd x)) (A, c)).
+ setoid_rewrite map_injective_spec.
+ - reflexivity.
+ - intros ? ? H. now rewrite H.
+ - intros [] [] [Heq Heq']. split; cbn in *; trivial; []. apply (Bijection.injective f _ _ Heq).
+ - intros ? ? H. now rewrite H.
+ - intros [] [] [Heq Heq']. split; cbn in *; trivial; []. apply (Bijection.injective f _ _ Heq).
++ rewrite Nat.eqb_sym.
+ f_equal. f_equiv.
+ intros ? c ?. subst. rewrite Heq1, Heq2, Nat.eqb_sym.
+ change (f ?A, c) with ((λ x, (f (fst x), snd x)) (A, c)).
+ setoid_rewrite map_injective_spec.
+ - reflexivity.
+ - intros ? ? H. now rewrite H.
+ - intros [] [] [Heq Heq']. split; cbn in *; trivial; []. apply (Bijection.injective f _ _ Heq).
+ - intros ? ? H. now rewrite H.
+ - intros [] [] [Heq Heq']. split; cbn in *; trivial; []. apply (Bijection.injective f _ _ Heq).
+Qed.
+
+
+Property state_in_config : forall config pt id, In (config id) (colors (snd (Obs.(obs_from_config) config pt))).
+Proof using Type.
+intros config pt id. unfold obs_from_config. simpl. unfold In.
+rewrite make_multiset_spec. rewrite (countA_occ_pos _).
+change (@prod_Setoid (@location Loc) (@L Lght) (@location_Setoid Loc) (@L_Setoid Lght))
+ with (@state_Setoid _ (prod (@location Loc) (@L Lght)) _).
+rewrite (config_list_InA (config id) config). now exists id.
+Qed.
+
+Property obs_from_config_In_gen : forall (config:configuration) (pt:location * L) (l:location * L),
+ In l (colors (snd (Obs.(obs_from_config) config pt))) <-> exists id, (config id) == l.
+Proof using InaFun UpdFun.
+intros config pt l. split; intro Hin.
++ assert (Heq := obs_from_config_spec config pt).
+ unfold obs_is_ok, obs_from_config, multiset_observation in *.
+ unfold In in Hin.
+ cbn in *.
+ destruct Heq as [ ? [? h]].
+ rewrite h in Hin.
+ rewrite (countA_occ_pos _ (prod_EqDec location_EqDec L_EqDec)) in Hin.
+ rewrite config_list_spec in Hin.
+ rewrite (InA_map_iff _ _) in Hin.
+ - firstorder.
+ - repeat intro. cbn in *. now subst.
++ destruct Hin as [id Hid]. rewrite <- Hid.
+ apply state_in_config.
+Qed.
+
+End MultisetGathering.
diff --git a/Core/Configuration.v b/Core/Configuration.v
index 0aae6b8cec081218c2ab6c2d0ba2dc3837aa598c..804cb3461b8e3df3d4574e0d66c8895d499d44d5 100644
--- a/Core/Configuration.v
+++ b/Core/Configuration.v
@@ -141,6 +141,71 @@ intros configâ‚ configâ‚‚. split; intro Hneq.
+ destruct Hneq as [id Hneq]. intro Habs. apply Hneq, Habs.
Qed.
+
+Definition on_loc pt (config : configuration) :=
+ List.filter (fun id => get_location (config id) ==b pt) names.
+
+Global Instance on_loc_compat : Proper (equiv ==> equiv ==> Logic.eq) on_loc.
+Proof using.
+intros pt1 pt2 Hpt config1 config2 Hconfig. unfold on_loc.
+apply filter_extensionality_compat; trivial; [].
+intros x id ?; subst x. unfold equiv_decb.
+repeat destruct_match; trivial; rewrite Hconfig, Hpt in *; contradiction.
+Qed.
+
+Lemma on_loc_spec : forall pt config id, List.In id (on_loc pt config) <-> get_location (config id) == pt.
+Proof using.
+intros pt config id. unfold on_loc, equiv_decb. rewrite filter_In.
+destruct_match; intuition; apply In_names.
+Qed.
+
+Lemma on_loc_NoDup : forall pt config, NoDup (on_loc pt config).
+Proof using. intros pt config. apply NoDup_filter, names_NoDup. Qed.
+
+(** The list of occupied locations inside a configuration *)
+Definition occupied config :=
+ removeA_dups equiv_dec (List.map (fun id => get_location (config id)) names).
+
+Lemma occupied_spec : forall pt config,
+ InA equiv pt (occupied config) <-> exists id, get_location (config id) == pt.
+Proof using.
+intros pt config. unfold occupied.
+rewrite (proj1 (removeA_dups_spec equiv_dec _)), InA_map_iff; autoclass; [].
+split.
++ intros [x [Hx _]]. now exists x.
++ intros [x Hx]. exists x. split; trivial; [].
+ rewrite InA_Leibniz. apply In_names.
+Qed.
+
+Global Instance occupied_compat : Proper (equiv ==> eqlistA equiv) occupied.
+Proof using.
+intros config1 config2 Hconfig. unfold occupied.
+induction names as [| id l]; try reflexivity; [].
+cbn.
+lazymatch goal with |- eqlistA equiv (if ?x then _ else _) (if ?y then _ else _) => assert (Htest : x = y) end.
+{ apply mem_compat.
+ - now rewrite Hconfig.
+ - apply eqlistA_equivlistA; autoclass; [].
+ apply (map_extensionalityA_compat (eqA := equiv) setoid_equiv); try reflexivity; [].
+ intros id1 id2 Hid. now rewrite Hconfig, Hid. }
+rewrite Htest.
+destruct_match.
++ apply IHl.
++ constructor; trivial; []. now rewrite Hconfig.
+Qed.
+
+Lemma occupied_NoDupA : forall config, NoDupA equiv (occupied config).
+Proof using. intro. apply removeA_dups_spec. Qed.
+
+Lemma occupied_config_list : forall config,
+ equivlistA equiv (occupied config) (map get_location (config_list config)).
+Proof using.
+intro.
+etransitivity; [apply removeA_dups_spec |].
+unfold config_list, Gpos, Bpos, names.
+now rewrite 2 map_app, 4 map_map.
+Qed.
+
End Configuration.
(** Injective configurations *)
diff --git a/Core/Formalism.v b/Core/Formalism.v
index 19cce23fd7c789375f88e0815c69a8d298aaa2b9..10159f49916154701b9b9c439ad679e4dc0e385c 100644
--- a/Core/Formalism.v
+++ b/Core/Formalism.v
@@ -19,6 +19,7 @@
Set Implicit Arguments.
Require Import Utf8.
+Require Import SetoidList.
Require Import SetoidDec.
Require Import Pactole.Util.Coqlib.
Require Import Pactole.Util.Bijection.
@@ -215,20 +216,35 @@ unfold idle. induction names as [| id l]; simpl.
- simpl. f_equal. apply IHl.
Qed.
-Lemma idle_spec : forall da id, List.In id (idle da) <-> activate da id = false.
+Lemma active_spec : forall da id, List.In id (active da) <-> activate da id = true.
Proof using .
-intros da id. unfold idle. rewrite List.filter_In.
+intros da id. unfold active. rewrite List.filter_In.
destruct (activate da id); intuition; try discriminate; [].
apply In_names.
Qed.
-Lemma active_spec : forall da id, List.In id (active da) <-> activate da id = true.
+Lemma idle_spec : forall da id, List.In id (idle da) <-> activate da id = false.
Proof using .
-intros da id. unfold active. rewrite List.filter_In.
+intros da id. unfold idle. rewrite List.filter_In.
destruct (activate da id); intuition; try discriminate; [].
apply In_names.
Qed.
+Lemma active_NoDup : forall da, NoDup (active da).
+Proof using. intro. apply NoDup_filter, names_NoDup. Qed.
+
+Lemma idle_NoDup : forall da, NoDup (idle da).
+Proof using. intro. apply NoDup_filter, names_NoDup. Qed.
+
+Lemma active_idle_is_partition : forall da, PermutationA eq names ((active da) ++ (idle da)).
+Proof using.
+intros da. unfold active, idle. induction names as [| id l].
++ reflexivity.
++ cbn. destruct_match; cbn.
+ - constructor; auto.
+ - rewrite <- PermutationA_middle; autoclass. constructor; auto.
+Qed.
+
(** A [demon] is just a stream of [demonic_action]s. *)
Definition demon := Stream.t demonic_action.
@@ -302,16 +318,123 @@ Qed.
(** A third subset of robots: moving ones. *)
Definition moving r da config :=
List.filter
- (fun id => if round r da config id =?= config id then false else true)
+ (fun id => negb (get_location (round r da config id) ==b get_location (config id)))
names.
Global Instance moving_compat : Proper (equiv ==> equiv ==> equiv ==> equiv) moving.
Proof using .
-intros r1 r2 Hr da1 da2 Hda c1 c2 Hc. unfold moving.
+intros r1 r2 Hr da1 da2 Hda c1 c2 Hc. unfold moving, equiv_decb.
+induction names as [| id l]; simpl.
+* reflexivity.
+* destruct (get_location (round r1 da1 c1 id) =?= get_location (c1 id)) as [Heq1 | Heq1],
+ (get_location (round r2 da2 c2 id) =?= get_location (c2 id)) as [Heq2 | Heq2]; cbn.
+ + apply IHl.
+ + elim Heq2. transitivity (get_location (round r1 da1 c1 id)).
+ - symmetry. now apply get_location_compat, round_compat.
+ - rewrite Heq1. apply get_location_compat, Hc.
+ + elim Heq1. transitivity (get_location (round r2 da2 c2 id)).
+ - now apply get_location_compat, round_compat.
+ - rewrite Heq2. symmetry. apply get_location_compat, Hc.
+ + f_equal. apply IHl.
+Qed.
+
+Lemma moving_spec : forall r da config id,
+ List.In id (moving r da config) <-> get_location (round r da config id) =/= get_location (config id).
+Proof using .
+intros r da config id. unfold moving, equiv_decb. rewrite List.filter_In.
+split; intro Hin.
++ destruct Hin as [_ Hin].
+ destruct (get_location (round r da config id) =?= get_location (config id)); intuition.
++ split.
+ - apply In_names.
+ - destruct (get_location (round r da config id) =?= get_location (config id)); intuition.
+Qed.
+
+Lemma moving_NoDup : forall r da config, NoDup (moving r da config).
+Proof using. intros. apply NoDup_filter, names_NoDup. Qed.
+
+Lemma moving_dec : forall r da config id,
+ {List.In id (moving r da config)} + {~List.In id (moving r da config)}.
+Proof using. intros. apply In_dec, names_eq_dec. Qed.
+
+(** A fourth subset of robots: stationary ones. *)
+Definition stationary r da config :=
+ List.filter
+ (fun id => get_location (round r da config id) ==b get_location (config id))
+ names.
+
+Global Instance stationary_compat : Proper (equiv ==> equiv ==> equiv ==> equiv) stationary.
+Proof using .
+intros r1 r2 Hr da1 da2 Hda c1 c2 Hc. unfold stationary, equiv_decb.
induction names as [| id l]; simpl.
* reflexivity.
-* destruct (round r1 da1 c1 id =?= c1 id) as [Heq1 | Heq1],
- (round r2 da2 c2 id =?= c2 id) as [Heq2 | Heq2].
+* destruct (get_location (round r1 da1 c1 id) =?= get_location (c1 id)) as [Heq1 | Heq1],
+ (get_location (round r2 da2 c2 id) =?= get_location (c2 id)) as [Heq2 | Heq2].
+ + f_equal. apply IHl.
+ + elim Heq2. transitivity (get_location (round r1 da1 c1 id)).
+ - symmetry. now apply get_location_compat, round_compat.
+ - rewrite Heq1. apply get_location_compat, Hc.
+ + elim Heq1. transitivity (get_location (round r2 da2 c2 id)).
+ - now apply get_location_compat, round_compat.
+ - rewrite Heq2. symmetry. apply get_location_compat, Hc.
+ + apply IHl.
+Qed.
+
+Lemma stationary_spec : forall r da config id,
+ List.In id (stationary r da config) <-> get_location (round r da config id) == get_location (config id).
+Proof using .
+intros r da config id. unfold stationary, equiv_decb. rewrite List.filter_In.
+split; intro Hin.
++ destruct Hin as [_ Hin].
+ destruct (get_location (round r da config id) =?= get_location (config id)); intuition.
++ split.
+ - apply In_names.
+ - destruct (get_location (round r da config id) =?= get_location (config id)); intuition.
+Qed.
+
+Lemma stationary_NoDup : forall r da config, NoDup (stationary r da config).
+Proof using. intros. apply NoDup_filter, names_NoDup. Qed.
+
+Lemma stationary_dec : forall r da config id,
+ {List.In id (stationary r da config)} + {~List.In id (stationary r da config)}.
+Proof using. intros. apply In_dec, names_eq_dec. Qed.
+
+Lemma stationary_iff_not_moving : forall r da config id,
+ List.In id (stationary r da config) <-> ~ List.In id (moving r da config).
+Proof using.
+intros r da config id. rewrite stationary_spec, moving_spec.
+destruct (get_location (round r da config id) =?= get_location (config id)); intuition.
+Qed.
+
+Corollary moving_or_stationary : forall r da config id,
+ List.In id (moving r da config) \/ List.In id (stationary r da config).
+Proof using.
+intros. rewrite stationary_iff_not_moving, moving_spec.
+destruct (get_location (round r da config id) =?= get_location (config id)); intuition.
+Qed.
+
+Corollary moving_stationary_is_partition : forall r da config,
+ PermutationA eq names ((moving r da config) ++ (stationary r da config)).
+Proof using.
+intros r da config. unfold moving, stationary.
+induction names as [| id l]; try reflexivity; []; cbn.
+repeat destruct_match; try discriminate.
+- constructor; auto.
+- rewrite <- PermutationA_middle; autoclass. constructor; auto.
+Qed.
+
+(** A fifth subset of robots: those which change state. *)
+Definition changing r da config :=
+ List.filter (fun id => negb (round r da config id ==b config id)) names.
+
+Global Instance changing_compat : Proper (equiv ==> equiv ==> equiv ==> equiv) changing.
+Proof using .
+intros r1 r2 Hr da1 da2 Hda c1 c2 Hc. unfold changing.
+induction names as [| id l]; simpl.
+* reflexivity.
+* unfold equiv_decb.
+ destruct (round r1 da1 c1 id =?= c1 id) as [Heq1 | Heq1],
+ (round r2 da2 c2 id =?= c2 id) as [Heq2 | Heq2]; cbn.
+ apply IHl.
+ contradiction Heq2. transitivity (round r1 da1 c1 id).
- symmetry. now apply round_compat.
@@ -322,10 +445,10 @@ induction names as [| id l]; simpl.
+ f_equal. apply IHl.
Qed.
-Lemma moving_spec : forall r da config id,
- List.In id (moving r da config) <-> round r da config id =/= config id.
+Lemma changing_spec : forall r da config id,
+ List.In id (changing r da config) <-> round r da config id =/= config id.
Proof using .
-intros r da config id. unfold moving. rewrite List.filter_In.
+intros r da config id. unfold changing, equiv_decb. rewrite List.filter_In.
split; intro Hin.
+ destruct Hin as [_ Hin].
destruct (round r da config id =?= config id) as [_ | Hneq]; intuition.
@@ -334,14 +457,19 @@ split; intro Hin.
- destruct (round r da config id =?= config id) as [Heq | _]; intuition.
Qed.
-Lemma no_moving_same_config : forall r da config,
- moving r da config = List.nil -> round r da config == config.
+Lemma changing_dec : forall r da config id,
+ {List.In id (changing r da config)} + {~List.In id (changing r da config)}.
+Proof using. intros. apply In_dec, names_eq_dec. Qed.
+
+Lemma no_changing_same_config : forall r da config,
+ changing r da config = List.nil -> round r da config == config.
Proof using .
intros r da config Hmove id.
destruct (round r da config id =?= config id) as [Heq | Heq]; trivial; [].
-apply <- moving_spec in Heq. rewrite Hmove in Heq. inversion Heq.
+apply <- changing_spec in Heq. rewrite Hmove in Heq. inversion Heq.
Qed.
+
(** [execute r d config] returns an (infinite) execution from an initial global
configuration [config], a demon [d] and a robogram [r] running on each good robot. *)
Definition execute (r : robogram) : demon -> configuration -> execution :=
@@ -386,13 +514,29 @@ Proof using . apply Stream.forever_compat, Stream.instant_compat, SSYNC_da_compa
(** All moving robots are active.
This is only true for the SSYNC (and FSYNC) model: in the ASYNC one,
robots can keep moving while others are activated. *)
-Lemma moving_active : forall da, SSYNC_da da ->
- forall r config, List.incl (moving r da config) (active da).
+Lemma moving_changing : forall da, SSYNC_da da ->
+ forall r config, List.incl (moving r da config) (changing r da config).
Proof using .
-intros da HSSYNC r config id. rewrite moving_spec, active_spec.
+intros da HSSYNC r config id. rewrite moving_spec, changing_spec.
+intros Hneq Habs. apply Hneq. now rewrite Habs.
+Qed.
+
+Lemma changing_active : forall da, SSYNC_da da ->
+ forall r config, List.incl (changing r da config) (active da).
+Proof using .
+intros da HSSYNC r config id. rewrite changing_spec, active_spec.
unfold round. destruct_match_eq Hcase; intuition.
Qed.
+Corollary moving_active : forall da, SSYNC_da da ->
+ forall r config, List.incl (moving r da config) (active da).
+Proof using.
+intros da Hssync r config.
+transitivity (changing r da config).
++ now apply moving_changing.
++ now apply changing_active.
+Qed.
+
(** If no robot is active, then the configuration does not change. *)
Lemma no_active_same_config : forall da, SSYNC_da da ->
forall r config, active da = List.nil -> round r da config == config.
@@ -429,6 +573,20 @@ Lemma SSYNC_round_simplify : forall r da config, SSYNC_da da ->
else state.
Proof using . unfold round. repeat intro. destruct_match_eq Hcase; auto. Qed.
+Lemma SSync_inactive_nochange:
+ forall r da c id, SSYNC_da da -> activate da id = false -> round r da c id == c id.
+Proof using.
+ intros r da c id h_ssync h.
+ remember (round r da c) as f.
+ assert ( f == round r da c) as hequivf.
+ { now subst. }
+ setoid_rewrite SSYNC_round_simplify in hequivf.
+ - rewrite hequivf.
+ rewrite h.
+ reflexivity.
+ - assumption.
+Qed.
+
(** *** Fully-synchronous (FSYNC) model **)
(** A fully synchronous demon is a particular case of fair demon: all good robots are activated
@@ -574,6 +732,27 @@ repeat match goal with
end.
Qed.
+(** [FirstChange r d config] gives the number of rounds before one robot changes its state. *)
+Inductive FirstChange r (d : demon) (config : configuration) : Prop :=
+ | ChangeNow : changing r (Stream.hd d) config <> nil -> FirstChange r d config
+ | ChangeLater : changing r (Stream.hd d) config = nil ->
+ FirstChange r (Stream.tl d) (round r (Stream.hd d) config) -> FirstChange r d config.
+
+Global Instance FirstChange_compat : Proper (equiv ==> equiv ==> equiv ==> iff) FirstChange.
+Proof using .
+intros r1 r2 Hr d1 d2 Hd c1 c2 Hc. split; intro Hfirst.
+* revert r2 d2 c2 Hr Hd Hc. induction Hfirst; intros r2 d2 c2 Hr Hd Hc.
+ + apply ChangeNow. now rewrite <- Hr, <- Hd, <- Hc.
+ + apply ChangeLater.
+ - now rewrite <- Hr, <- Hd, <- Hc.
+ - destruct Hd. now apply IHHfirst, round_compat.
+* revert r1 d1 c1 Hr Hd Hc. induction Hfirst; intros r1 d1 c1 Hr Hd Hc.
+ + apply ChangeNow. now rewrite Hr, Hd, Hc.
+ + apply ChangeLater.
+ - now rewrite Hr, Hd, Hc.
+ - destruct Hd. apply IHHfirst; trivial. now apply round_compat; f_equiv.
+Qed.
+
(** [FirstMove r d config] gives the number of rounds before one robot moves. *)
Inductive FirstMove r (d : demon) (config : configuration) : Prop :=
| MoveNow : moving r (Stream.hd d) config <> nil -> FirstMove r d config
@@ -616,9 +795,9 @@ Proof using . now intros da id. Qed.
(** An unfair demon activates at least one activable robot if such a robot exists. *)
Definition unfair_da r da config :=
(* If assuming all robots are activated, a robot can move *)
- moving r (da_with_all_activated da) config <> nil ->
+ changing r (da_with_all_activated da) config <> nil ->
(* then at least a robot moves *)
- moving r da config <> nil.
+ changing r da config <> nil.
Definition unfair r d config :=
Stream.forever2 (Stream.instant2 (unfair_da r)) d (execute r d config).
@@ -628,8 +807,8 @@ Definition unfair_da_cond P r da :=
forall config,
P config ->
(* There exists a way to make some robot move *)
- (exists da', moving r da' config <> nil) ->
- moving r da config <> nil.
+ (exists da', changing r da' config <> nil) ->
+ changing r da config <> nil.
Definition unfair_cond P r d := Stream.forever (Stream.instant (unfair_da_cond P r)) d.
diff --git a/DEV.md b/DEV.md
index 9597e8b9db1f558fefbd28d14538788f8d384d46..e98361944ba8f01bba64aa5e30b29e9237a96627 100644
--- a/DEV.md
+++ b/DEV.md
@@ -1,13 +1,25 @@
-# Contributing
+The fundamental principle is that the MASTER branch must remain
+compilable at all times and should never contain incomplete
+developments.
-The golden rule is that **MASTER SHOULD COMPILE AT ALL TIME** and does not
-contain in-progress developments.
+Development work on the master branch must be avoided. Instead, each
+feature or topic should have its own dedicated branch. Developers
+should create new branches as needed, and all work—including
+collaborative efforts—should occur within these topic-specific
+branches.
-More precisely, development never happens on master: each topic should have
-its own branch (feel free to create one if needed) and work happens there,
-even when several people are involved.
+Before merging changes into master, ensure that your code:
-Once a set of changes (e.g. a new case study) is complete and polished enough
-(comments, adequate identation, no use of generated hypothesis names, etc.),
-you may merge it to master by squashing its commits into meaningful pieces
-(only a few, usually one may be enough) or submit a pull request.
+- Is complete and thoroughly tested
+- Contains clear and comprehensive comments
+- Features proper indentation
+- Uses descriptive hypothesis names rather than auto-generated ones
+- Meets all project quality standards
+
+When your changes are ready (such as a completed case study), you have
+two options:
+
+1. Submit a pull request for review
+2. Merge directly into master after squashing your commits into
+ meaningful, well-organized units (typically one or a few commits
+ that clearly represent the changes)
diff --git a/INSTALL.md b/INSTALL.md
new file mode 100644
index 0000000000000000000000000000000000000000..019e84bebbcb17e3af866b9e7948b969ff03ddaa
--- /dev/null
+++ b/INSTALL.md
@@ -0,0 +1,117 @@
+
+# Requirements
+
+- Coq 8.19 or 8.20 (including the executable `coqc`, `coqdep`, `coq_makefile`)
+- GNU `make`
+
+# Configuration
+
+You should perform once the following command to generate the Makefile:
+
+```bash
+coq_makefile -f _CoqProject -o Makefile
+```
+
+# Compilation
+
+To compile the whole projet including case studies:
+
+``` bash
+make
+```
+
+# Use in your coq development
+
+Suppose you have compiled Pactole in a directory calle `pactole` and
+you want to use it in your own development called `myproject`. You
+should use a `_CoqProject` file containing:
+
+```
+-Q pactole Pactole
+.. # your own project options
+```
+
+and use `coq_makefile -f _CoqProject -o Makefile` to generate your
+makefile. Note that ProofGeneral and other IDE also read the
+`_CoqProject`.
+
+From now on you can use Pactole in your coq files by importing the
+relevant modules, e.g.:
+
+``` coq
+Require Import Pactole.Core.Formalism.
+```
+
+See the file README.md for the directory structure of the library.
+
+# NOTES FOR DEVELOPPERS
+
+Pactole provides fast (and unsafe) compilation target. This is
+explained in this section.
+
+
+## build (slow)
+
+The default makefile target may take more than 10mn to compile due to
+some case studies. You may want to comment them in the _CoqProject
+file before the configure step above if you are not interested in
+these case studies. Another solution is to follow the fast compilation
+recipes below.
+
+Doing this once a week when developing is good practice. This is the
+only way to make a really safe compilation including all
+xxx_Assumption.v. You should always do this once in a while to make
+sure some universe constraints aren't failing and to check if you did
+not miss any remaining axiom.
+
+But during the development process this makes the compilation when
+switching between files too slow. Hence the following less safe
+compilation processes:
+
+## unsafe builds when developing
+
+During development you can benefit from coq's "vos/vok" generation to
+speed up compilation. The only specificity of Pactole concerns
+compilation of the files named xxx_Assumptions.v. This files print the
+sets of assumptions used in the proofs of final lemmas in Case
+studies. Compiling these files for vos/vok target would raise errors.
+We provide adapted targets below.
+
+## build (slow, almost safe, but very parallelisable)
+
+```
+make [-j] vok
+```
+or better when developing
+```
+make [-j] vok-nocheck
+```
+Doing this once a day when developing is good practice.
+
+## build (Very fast, unsafe)
+
+```
+make [-j] vos
+```
+or better when developing
+```
+make [-j] vos-nocheck
+```
+
+This should be your prefered way of compiling when developing. It is
+much faster. It is unsafe but in most situations no bad surprise is to
+be expected.
+
+You should do real compilations from time to time as explained above.
+
+## Proofgeneral
+
+For easy use of this feature (vos) you can use the auto compilation
+feature of proofgeneral. menu:
+
+menu: Coq / Auto Compilation / Compile Before Require
+and then: Coq / Auto Compilation / vos compilation
+
+Now you can transparently script in any buffer, all needed file will
+be compiled quickly. Don't forget to make a big fat "make" from time
+to time.
diff --git a/Models/GraphEquivalence.v b/Models/GraphEquivalence.v
index f3ea75daa9ee61387e8c5b192ed8bd0467e4ed22..27e7b5ef59928d00c5b054fb1f4f973997d4805e 100644
--- a/Models/GraphEquivalence.v
+++ b/Models/GraphEquivalence.v
@@ -329,7 +329,7 @@ try destruct (v1 =?= src target1) as [Hsrc1 | Hsrc1],
+ tauto.
Defined.
-Theorem graph_equivD2C : forall (config : DGF_config) (rbg : robogramV) (da : DGF_da),
+Theorem graph_equiv_D2C : forall (config : DGF_config) (rbg : robogramV) (da : DGF_da),
config_V2G (round rbg da config) == round (rbg_V2G rbg) (da_D2C da) (config_V2G config).
Proof using All.
intros config rbg da id.
@@ -721,14 +721,16 @@ simpl activate. destruct_match_eq Hactive.
simpl get_location in Hlocal_g at 2.
unfold move. simpl fst. symmetry.
do 2 destruct_match.
+ rename H into h.
+ rename H0 into h0.
* (* valid case: the robot chooses an adjacent edge *)
revert Hchoice. destruct_match; intro Hchoice; hnf in Hchoice; rewrite Hchoice;
unfold add_edge; (destruct_match; [| destruct_match]); simpl state_G2V.
+ (* absurd case *)
- assert (H0 : proj_ratio Cchoice = 0%R).
+ assert (hratio_0: proj_ratio Cchoice = 0%R).
{ assert (Hbounds := ratio_bounds Cchoice). cbn in *; lra. }
assert (proj_ratio Cchoice < threshold Clocal_robot_decision)%R.
- { rewrite H0. apply strict_ratio_bounds. }
+ { rewrite hratio_0. apply strict_ratio_bounds. }
lra.
+ (* the robot reaches its destination *)
change (proj_ratio ratio_0) with 0%R in *. rewrite Rplus_0_l in *.
@@ -739,10 +741,10 @@ simpl activate. destruct_match_eq Hactive.
(* the ending point is after the edge threshold *)
symmetry. repeat split; simpl; apply Hlocal_robot_decision.
+ (* the robot will not move so will end up in its starting position *)
- assert (H0 : proj_ratio Cchoice = 0%R).
+ assert (hratio0 : proj_ratio Cchoice = 0%R).
{ assert (Hbounds := ratio_bounds Cchoice). cbn in *; lra. }
assert (proj_ratio Cchoice < threshold Clocal_robot_decision)%R.
- { rewrite H0. apply strict_ratio_bounds. }
+ { rewrite hratio0. apply strict_ratio_bounds. }
symmetry. split; cbn -[equiv]; apply Hlocal_robot_decision.
+ (* absurd case *)
exfalso. change (proj_ratio ratio_0) with 0%R in *. rewrite Rplus_0_l in *.
diff --git a/Models/GraphEquivalence_Assumptions.v b/Models/GraphEquivalence_Assumptions.v
new file mode 100644
index 0000000000000000000000000000000000000000..2b85155129b99a181056d3a5ee09b4780cb84660
--- /dev/null
+++ b/Models/GraphEquivalence_Assumptions.v
@@ -0,0 +1,4 @@
+From Pactole Require GraphEquivalence.
+
+Print Assumptions GraphEquivalence.graph_equiv_D2C.
+Print Assumptions GraphEquivalence.graph_equiv_C2D.
diff --git a/Models/Rigid.v b/Models/Rigid.v
index 6f619d4020bbd13af935f9a3d6354873d2641ae4..7d5235717434b9c4cd23785eb9c0c7affaa6c374 100644
--- a/Models/Rigid.v
+++ b/Models/Rigid.v
@@ -42,11 +42,33 @@ Class RigidSetting := {
rigid_update : forall config frame g target choice,
get_location (update config g frame target choice) == target }.
+(** Rigid moves are a special case of state updates where the updated location of the robot
+ is the one chosen by the robogram. *)
+
End RigidFormalism.
+(* Same notion for cases where the return type (Trobot) of the robogram is info. Here we
+define rigidity as the fact that the final state of the robot is exactly the info computed
+by the robogram. *)
+Section RigidFormalismInfo.
+ Context {info : Type} {Loc : Location} {St : State info} {N : Names} {Obs : Observation}
+ {Tactive Tframe Tinactive : Type} {RC : robot_choice info} {FC : frame_choice Tframe}
+ {UC : update_choice Tactive} {IC : inactive_choice Tinactive}.
+
+ Context {Upd : update_function info _ Tactive}.
+
+ Definition xxx := forall config frame g target choice,
+ (@update info Loc St N info Tframe Tactive RC FC UC Upd config g frame target choice == target).
+
+ Class RigidSettingInfo := {
+ rigid_update_Info : forall config frame g target choice,
+ (update config g frame target choice) == target }.
+
+End RigidFormalismInfo.
+
(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
- *** fill-column: 117 ***
+ *** fill-column: 90 ***
*** End: ***
*)
diff --git a/Observations/MultisetObservation.v b/Observations/MultisetObservation.v
index 00f0a49ac8beadf8d462c1f684c78a122f8c428c..aa6f397025dd08188d9a07d35c5223fb2114c646 100644
--- a/Observations/MultisetObservation.v
+++ b/Observations/MultisetObservation.v
@@ -238,6 +238,33 @@ intros config pt l. split; intro Hin.
+ destruct Hin as [id Hid]. rewrite <- Hid. apply pos_in_config.
Qed.
+Lemma obs_from_config_on_loc : forall config st pt,
+ (obs_from_config config st)[pt] = length (on_loc pt config).
+Proof.
+intros config st pt.
+unfold obs_from_config, on_loc. cbn.
+rewrite config_list_spec, map_map.
+induction names as [| id l]; cbn -[empty add].
++ apply empty_spec.
++ unfold equiv_decb at 1. destruct_match.
+ - revert_one equiv. intro Heq. rewrite Heq, add_same, Nat.add_1_r. cbn. f_equal. apply IHl.
+ - rewrite add_other; intuition.
+Qed.
+
+Lemma In_occupied : forall config st pt,
+ In pt (obs_from_config config st) <-> InA equiv pt (occupied config).
+Proof. intros. now rewrite occupied_spec, obs_from_config_In. Qed.
+
+Lemma support_occupied : forall config st,
+ PermutationA equiv (support (obs_from_config config st)) (occupied config).
+Proof.
+intros. apply NoDupA_equivlistA_PermutationA.
++ autoclass.
++ apply support_NoDupA.
++ apply occupied_NoDupA.
++ intro. now rewrite support_spec, obs_from_config_In, occupied_spec.
+Qed.
+
End MultisetObservation.
Global Notation "s [ x ]" := (multiplicity x s) (at level 2, no associativity, format "s [ x ]").
diff --git a/Observations/MultisetObservationInfo.v b/Observations/MultisetObservationInfo.v
new file mode 100644
index 0000000000000000000000000000000000000000..7529b07c4d5807922081c43a1bd407c1d2028d61
--- /dev/null
+++ b/Observations/MultisetObservationInfo.v
@@ -0,0 +1,260 @@
+(**************************************************************************)
+(* Mechanised Framework for Local Interactions & Distributed Algorithms *)
+(* P. Courtieu, L. Rieg, X. Urbain *)
+(* PACTOLE project *)
+(* *)
+(* This file is distributed under the terms of the CeCILL-C licence. *)
+(* *)
+(**************************************************************************)
+
+Require Import Utf8_core.
+Require Import Arith_base.
+Require Import Lia.
+Require Import SetoidList.
+Require Import SetoidDec.
+Require Import Pactole.Util.FMaps.FMapList.
+Require Import Pactole.Util.MMultiset.MMultisetWMap.
+Require Export Pactole.Util.MMultiset.MMultisetInterface.
+Require Export Pactole.Util.MMultiset.MMultisetFacts.
+Require Export Pactole.Util.MMultiset.MMultisetExtraOps.
+Require Import Pactole.Util.Coqlib.
+Require Import Pactole.Core.Identifiers.
+Require Import Pactole.Core.State.
+Require Import Pactole.Core.Configuration.
+Require Import Pactole.Observations.Definition.
+Close Scope R_scope.
+Set Implicit Arguments.
+
+
+
+Section MultisetConstruction.
+
+Context {loc : Type}.
+Context `{EqDec loc}.
+
+Existing Instance multiplicity_compat.
+Existing Instance FMOps_WMap.
+Existing Instance MakeFMultisetsFacts.
+
+
+(** ** Building multisets from lists **)
+
+Definition make_multiset l := from_elements (List.map (fun x => (x, 1)) l).
+
+Lemma make_multiset_nil : make_multiset nil == empty.
+Proof using . reflexivity. Qed.
+
+Lemma make_multiset_cons : forall x l, make_multiset (x :: l) == add x 1 (make_multiset l).
+Proof using . reflexivity. Qed.
+
+Lemma make_multiset_empty : forall l, make_multiset l == empty <-> l = nil.
+Proof using .
+intro l. unfold make_multiset. rewrite from_elements_empty.
+destruct l; cbn.
+- intuition.
+- split; intro Hl; inv Hl. discriminate.
+Qed.
+
+Lemma make_multiset_app : forall l l',
+ make_multiset (l ++ l') == union (make_multiset l) (make_multiset l').
+Proof using . intros. unfold make_multiset. now rewrite List.map_app, from_elements_append. Qed.
+
+Lemma nequiv_sym : forall x y, ~x == y -> ~y == x.
+Proof using . intuition. Qed.
+
+Instance make_multiset_compat : Proper (PermutationA equiv ==> equiv) make_multiset.
+Proof using .
+intros ? ? ?. unfold make_multiset. eapply from_elements_compat, PermutationA_map; eauto.
+- autoclass.
+- repeat intro. split; hnf; auto.
+Qed.
+
+Lemma make_multiset_PermutationA : forall x l n, (make_multiset l)[x] = n ->
+ exists l', ~InA equiv x l' /\ PermutationA equiv l (alls x n ++ l').
+Proof using .
+intros x l. induction l; intros n Hin.
+exists nil. split. now auto. rewrite make_multiset_nil, empty_spec in Hin. subst n. simpl. reflexivity.
+rewrite make_multiset_cons in Hin. destruct (equiv_dec x a) as [Heq | Heq].
+- setoid_rewrite <- Heq. rewrite <- Heq in Hin. rewrite add_spec in Hin. destruct n.
+ + rewrite equiv_dec_refl in Hin.
+ lia.
+ + rewrite equiv_dec_refl in Hin.
+ rewrite Nat.add_comm in Hin. cbn in Hin. apply eq_add_S, IHl in Hin. destruct Hin as [l' [Hl1 Hl2]].
+ exists l'. split. assumption. simpl. now constructor.
+- rewrite add_other in Hin; auto. apply IHl in Hin. destruct Hin as [l' [Hl1 Hl2]].
+ exists (a :: l'). split. intro Hin; inversion_clear Hin; contradiction.
+ transitivity (a :: alls x n ++ l'); now constructor || apply (PermutationA_middle _).
+Qed.
+
+Lemma make_multiset_alls : forall x n, make_multiset (alls x n) == singleton x n.
+Proof using .
+intros x n. induction n.
++ now rewrite singleton_0, make_multiset_nil.
++ simpl alls. rewrite make_multiset_cons. rewrite IHn. intro y. rewrite singleton_spec.
+ destruct (equiv_dec y x) as [Heq | Heq].
+ - rewrite Heq, add_spec, singleton_spec.
+ destruct (equiv_dec x x) as [_ | Helim]. lia. now elim Helim.
+ - rewrite add_other; auto. rewrite singleton_spec.
+ destruct (equiv_dec y x); trivial; []. contradiction.
+Qed.
+
+Corollary make_multiset_In : forall x l, In x (make_multiset l) <-> InA equiv x l.
+Proof using .
+intros x l. unfold make_multiset. rewrite from_elements_In.
+setoid_rewrite InA_map_iff; autoclass.
++ split; intro Hin.
+ - destruct Hin as [n [[y [[Heq _] Hy]] Hn]]. hnf in *. cbn in *. now rewrite <- Heq.
+ - exists 1. split; try lia; []. now exists x.
++ intros ? ? Heq. now split.
+Qed.
+
+Theorem make_multiset_map : forall f, Proper (equiv ==> equiv) f ->
+ forall l, make_multiset (List.map f l) == map f (make_multiset l).
+Proof using . intros. unfold make_multiset. now rewrite map_from_elements, map_map, map_map. Qed.
+
+Theorem make_multiset_filter : forall f, Proper (equiv ==> Logic.eq) f ->
+ forall l, make_multiset (List.filter f l) == filter f (make_multiset l).
+Proof using .
+intros f Hf l. induction l as [| e l].
++ intro. rewrite (filter_compat Hf), make_multiset_nil; try apply make_multiset_nil; [].
+ now rewrite filter_empty.
++ simpl List.filter. destruct (f e) eqn:Htest.
+ - do 2 rewrite make_multiset_cons. rewrite filter_add, Htest, IHl; trivial; reflexivity || lia.
+ - rewrite make_multiset_cons, filter_add, Htest, IHl; trivial; reflexivity || lia.
+Qed.
+
+Theorem cardinal_make_multiset : forall l, cardinal (make_multiset l) = length l.
+Proof using .
+induction l.
++ now rewrite make_multiset_nil, cardinal_empty.
++ rewrite make_multiset_cons, cardinal_add. simpl. apply f_equal, IHl.
+Qed.
+
+Theorem make_multiset_spec : forall x l, (make_multiset l)[x] = countA_occ _ equiv_dec x l.
+Proof using .
+intros x l. induction l.
++ rewrite make_multiset_nil. now rewrite empty_spec.
++ rewrite make_multiset_cons. simpl countA_occ. destruct (equiv_dec a x) as [Heq | Hneq].
+ - rewrite <- Heq at 1. rewrite add_spec, equiv_dec_refl, Heq, IHl. lia.
+ - apply nequiv_sym in Hneq. rewrite add_other. now apply IHl. assumption.
+Qed.
+
+Lemma make_multiset_remove : forall x l,
+ make_multiset (removeA equiv_dec x l) == remove x (make_multiset l)[x] (make_multiset l).
+Proof using .
+intros x l y. induction l as [| a l].
+* rewrite make_multiset_nil. rewrite empty_spec. now rewrite remove_0, empty_spec.
+* rewrite make_multiset_cons. simpl removeA.
+ destruct (equiv_dec y x) as [Hyx | Hyx], (equiv_dec x a) as [Hxa | Hxa].
+ + rewrite Hyx, Hxa in *. rewrite IHl. setoid_rewrite remove_same. rewrite Hxa, add_same. lia.
+ + rewrite Hyx in *. rewrite make_multiset_cons, add_other; auto.
+ rewrite IHl. do 2 rewrite remove_same. simpl. lia.
+ + rewrite IHl. repeat rewrite remove_other; auto; [].
+ rewrite Hxa in *. rewrite add_other; auto.
+ + rewrite make_multiset_cons. rewrite remove_other; auto. destruct (equiv_dec y a) as [Hya | Hya].
+ - rewrite Hya in *. do 2 rewrite add_same. rewrite IHl. now rewrite remove_other.
+ - repeat rewrite add_other; trivial. rewrite IHl. rewrite remove_other; auto.
+Qed.
+
+Lemma make_multiset_support : forall x l, InA equiv x (support (make_multiset l)) <-> InA equiv x l.
+Proof using .
+intros x l. rewrite support_spec. unfold In.
+rewrite make_multiset_spec. apply countA_occ_pos. autoclass.
+Qed.
+
+End MultisetConstruction.
+
+(** Building an observation from a configuration *)
+
+Section MultisetObservation.
+
+Context {info info' : Type}.
+Context `{SI': EqDec info'}.
+Context (obs_from_info: info -> info'). (* We need a type class *)
+Context `{St : State info}.
+Context { obs_from_info_compat: Proper (equiv ==> equiv) obs_from_info }.
+Context `{Names}.
+Implicit Type config : configuration.
+
+Instance multiset_observation_info : Observation.
+simple refine {|
+ observation := multiset info';
+ obs_from_config config st := make_multiset (List.map obs_from_info (config_list config));
+ obs_is_ok s config st :=
+ forall l, s[l] = countA_occ _ equiv_dec l (List.map obs_from_info (config_list config)) |}
+;
+ try typeclasses eauto. (* try (autoclass; [|]); *)
+Proof.
++ repeat intro.
+ apply @make_multiset_compat.
+ apply eqlistA_PermutationA_subrelation.
+ apply (@map_eqlistA_compat _ _ equiv equiv _ obs_from_info).
+ - typeclasses eauto.
+ - apply config_list_compat. assumption.
++ unfold obs_from_config, obs_is_ok. intros. apply make_multiset_spec.
+Defined.
+
+(* To speed up typeclass resolution. *)
+Notation obs_from_config := (@obs_from_config _ _ _ _ multiset_observation_info).
+
+Lemma obs_from_config_ignore_snd ref_st :
+ forall config st, obs_from_config config st == obs_from_config config ref_st.
+Proof using . reflexivity. Qed.
+
+(* Would need a lift + lift_compat in Observation... *)
+
+Lemma obs_from_config_map : forall (f: location -> location), Proper (equiv ==> equiv) f ->
+ forall Pf config state,
+ forall (liftloc : (location -> location) -> info' -> info'),
+ forall {P:Proper (equiv ==> equiv) (liftloc f)},
+ forall (hcompat:forall st: info, obs_from_info (lift (existT _ f Pf) st) == liftloc f (obs_from_info st)),
+ map (liftloc f) (obs_from_config config state) ==
+ obs_from_config (map_config (lift (existT _ f Pf)) config) ((lift (existT _ f Pf)) state).
+Proof using .
+ intros f h_fcompat Pf config state liftloc P hcompat.
+ unfold obs_from_config, multiset_observation_info.
+ rewrite config_list_map, map_map, <- make_multiset_map, map_map.
++ apply make_multiset_compat, Preliminary.eqlistA_PermutationA_subrelation.
+ assert (Hequiv : (@equiv info _ ==> @equiv info' _)%signature
+ (fun x => liftloc f (obs_from_info x)) (fun x => obs_from_info (lift (existT _ f Pf) x))).
+ { intros pt1 pt2 Heq.
+ rewrite hcompat.
+ now rewrite Heq. }
+ now apply (map_extensionalityA_compat _ Hequiv).
++ assumption.
+Qed.
+
+Theorem cardinal_obs_from_config : forall config pt, cardinal (obs_from_config config pt) = nG + nB.
+Proof using .
+intro. unfold obs_from_config, multiset_observation_info.
+now rewrite cardinal_make_multiset, map_length, config_list_length.
+Qed.
+
+(* Property pos_in_config :
+ forall config pt id, exists i:info',
+ In i (obs_from_config config pt) /\ obs_from_info (config id) == i.
+ *)
+Property obs_from_info_In : forall config pt id, In (obs_from_info (config id)) (obs_from_config config pt).
+Proof using .
+intros config pt id. unfold obs_from_config. simpl. unfold In.
+rewrite make_multiset_spec. rewrite (countA_occ_pos _).
+rewrite InA_map_iff; autoclass; [].
+eexists. split; auto; []. apply config_list_InA. now exists id.
+Qed.
+
+Property obs_from_config_In : forall config pt l,
+ In l (obs_from_config config pt) <-> exists id, obs_from_info (config id) == l.
+Proof using .
+intros config pt l. split; intro Hin.
++ assert (Heq := obs_from_config_spec config pt).
+ unfold obs_is_ok, obs_from_config, multiset_observation_info in *.
+ unfold In in Hin. rewrite Heq, (countA_occ_pos _), config_list_spec in Hin.
+ rewrite map_map, (InA_map_iff _ _) in Hin.
+ - firstorder.
+ - repeat intro. cbn in *. now subst.
++ destruct Hin as [id Hid]. rewrite <- Hid. apply obs_from_info_In.
+Qed.
+
+End MultisetObservation.
+
+Global Notation "s [ x ]" := (multiplicity x s) (at level 2, no associativity, format "s [ x ]").
diff --git a/Observations/PairObservation.v b/Observations/PairObservation.v
new file mode 100644
index 0000000000000000000000000000000000000000..971875a37d7a7970083b587ecc630701f2c943c8
--- /dev/null
+++ b/Observations/PairObservation.v
@@ -0,0 +1,60 @@
+(**************************************************************************)
+(* Mechanised Framework for Local Interactions & Distributed Algorithms *)
+(* P. Courtieu, L. Rieg, X. Urbain *)
+(* PACTOLE project *)
+(* *)
+(* This file is distributed under the terms of the CeCILL-C licence. *)
+(* *)
+(**************************************************************************)
+
+(**************************************************************************)
+(** Mechanised Framework for Local Interactions & Distributed Algorithms
+
+ P. Courtieu, L. Rieg, X. Urbain
+
+ PACTOLE project
+
+ This file is distributed under the terms of the CeCILL-C licence
+ *)
+(**************************************************************************)
+
+Require Import Utf8_core.
+Require Import Lia.
+Require Import SetoidList.
+Require Import SetoidDec.
+Require Import SetoidClass.
+Require Import Pactole.Util.Coqlib.
+Require Import Pactole.Core.Identifiers.
+Require Import Pactole.Core.State.
+Require Import Pactole.Core.Configuration.
+Require Import Pactole.Observations.Definition.
+
+
+(** Pairing two observations into one *)
+
+Section PairObservation.
+
+Context `{Names}.
+Context `{Location}.
+Context `{State}.
+Variables Obs1 Obs2 : Observation.
+
+Implicit Type config : configuration.
+
+Local Instance pair_observation : Observation.
+simple refine {|
+ observation := observation (Observation := Obs1) * observation (Observation := Obs2);
+ observation_Setoid := prod_Setoid _ _;
+
+ obs_from_config config pt := (obs_from_config (Observation := Obs1) config pt,
+ obs_from_config (Observation := Obs2) config pt);
+
+ obs_is_ok s config pt := obs_is_ok (Observation := Obs1) (fst s) config pt
+ /\ obs_is_ok (Observation := Obs2) (snd s) config pt |};
+autoclass; [|].
+Proof.
++ repeat intro. split; cbn; apply obs_from_config_compat; assumption.
++ intros config state. cbn. split; apply obs_from_config_spec.
+Defined.
+
+End PairObservation.
diff --git a/README.md b/README.md
index 11494d903fcb8ad3406dcaae025ced4a083efeb5..9a207db4443a4d7ddd9ed22d150957e8d679d461 100644
--- a/README.md
+++ b/README.md
@@ -1,95 +1,116 @@
-This repository stores the Coq code of the Pactole project,
-dedicated to formal verification of mobile robotic swarm protocols.
+# Content
+
+The Pactole Repository: *A Framework for Formal Verification of Robotic Swarm Protocols*.
+
+This repository houses the Coq implementation of the Pactole project (https://pactole.liris.cnrs.fr/), dedicated to formally verifying distributed protocols for mobile robot swarms. It implements multiple variants of the Look-Compute-Move model, originally introduced by Suzuki and Yamashita [1].
+
+Key Features:
+
+- Provides an abstract, parameterized formal model
+- Includes documented case studies (described below)
+- Supports various model variants
+- Enables rigorous protocol verification
+
+[1] I. Suzuki and M. Yamashita. *Distributed Anonymous Mobile Robots: Formation of Geometric Patterns*. SIAM Journal of Computing, 28(4):1347–1363, 1999.
+
+# Support
+
+Pactole was financially supported by the following projects:
+
+- [Pactole](https://pactole.liris.cnrs.fr/) started as the
+ Digiteo Project #2009-38HD.
+- [SAPPORO](https://sapporo.liris.cnrs.fr/) funded by the French
+ National Research Agency (ANR) under the reference 2019-CE25-0005
+
# Overall Structure
- *Setting.v*: All you need to setup a working framework. A good starting point.
-- *Util/*: Extension the to the Coq standard library that are not specific to Pactole
-- *Core/*: The core the the Pactole framework, implementing the Look/Compute/Move cycle
-- *Spaces/*: Spaces in which robots evolve
-- *Observations/*: Types of robot views of the configuration
-- *Models/*: Additional properties of some models
-- *CasesStudies/*
- - *Convergence/*: Convergence of robots in the 2D Euclidean plane
- - *Gathering/*: Gathering in R or R² for various models
- - *Exploration/*: Exploration of a ring with stop
- - *LifeLine/*: Life line connection in the 2D Euclidean plane
-
-# Fast Compiling when developing
-
-During development you can benefit from coq's "vos/vok" generation to
-speed up compilation. The only specificity of Pactole concerns
-compilation of the files named xxx_Assumptions.v. This files print the
-sets of assumptions used in the proofs of final lemmas in Case
-studies. Compiling these files for vos/vok target would raise errors.
-We provide adapted targets:
-
-## configure
-
-```
-coq_makefile -f _CoqProject -o Makefile
-```
-
-See below for faster compilation.
-
-## build (slow)
-
-```
-make
-```
-
-Be aware this may take more than 10mn to compile due to some case
-studies. You may want to comment them in the _CoqProject file before
-the configure step above if you are not interested in these case
-studies. Another solution is to follow the fast compilation recipes
-below.
-
-Doing this once a week when developing is good practice. This is the
-only way to make a really safe compilation including all
-xxx_Assumption.v. You should always do this once in a while to make
-sure some universe constraints aren't failing and to check if you did
-not miss any remaining axiom.
-
-But during the development process this makes the compilation when
-switching between files too slow. Hence the following less safe
-compilation processes:
-
-
-## build (slow, almost safe, but very parallelisable)
-
-```
-make [-j] vok
-```
-or better when developing
-```
-make [-j] vok-nocheck
-```
-Doing this once a day when developing is good practice.
-
-## build (Very fast, unsafe)
-
-```
-make [-j] vos
-```
-or better when developing
-```
-make [-j] vos-nocheck
-```
-
-This should be your prefered way of compiling when developing. It is
-much faster. It is unsafe but in most situations no bad surprise are
-to be expected.
-
-You should do real compilations from time to time as explained above.
-
-### proofgeneral
-
-For easy use of this feature (vos) you can use the auto compilation
-feature of proofgeneral. menu:
-
-menu: Coq / Auto Compilation / Compile Before Require
-and then: Coq / Auto Compilation / vos compilation
-
-Now you can transparently script in any buffer, all needed file will
-be compiled quickly. Don't forget to make a big fat "make" from time
-to time.
+- *Util/*: Extension to the Coq standard library not specific to Pactole.
+- *Core/*: The core of the Pactole framework, implementing the Look/Compute/Move cycle.
+- *Spaces/*: Spaces where robots evolve.
+- *Observations/*: Types of robot views on the configuration.
+- *Models/*: Additional properties of some models.
+- *CaseStudies/* : Case studies.
+
+# Case Studies
+
+The directory `CaseStudies` contains the following case
+studies. Each case study (say `casestudy.v`) has a companion file
+called `casestudy_Assuptions.v` whose only purpose is to call `Print
+Assumption` on the main theorem(s) of the case study.
+This command is not included in the case study itself to allow for
+fast compilation.
+
+Here is a list of the current case studies:
+
+- [Convergence/](Casestudy/Convergence): convergency results on different protocols.
+ - [Algorithm_noB.v](CaseStudies/Convergence/Algorithm_noB.v):
+ Convergence on the Euclidean plane without Byzantine robots.
+ - [Impossibility_2G_1B.v](CaseStudies/Convergence/Impossibility_2G_1B.v):
+ *Impossibility of convergence on the real line when 1/3 of robots are
+ Byzantine.* Auger, Bouzid, Courtieu, Tixeuil, Urbain. Certified
+ Impossibility Results for Byzantine-Tolerant Mobile Robots. SSS
+ 2013.
+
+- [Gathering/](CaseStudies/Gathering): Gathering in R or R² for
+ various models
+ - [Impossibility.v](CaseStudies/Gathering/Impossibility.v):
+ Impossibility of gathering in SSYNC.
+ - [Definitions.v](CaseStudies/Gathering/Definitions.v):
+ Common definitions about the gathering problem.
+ - [WithMultiplicity.v](CaseStudies/Gathering/WithMultiplicity.v):
+ Common definition on gathering when robots enjoy strong
+ multiplicity detection.
+ - [WithMultiplicityLight.v](CaseStudies/Gathering/WithMultiplicityLight.v):
+ Common definition on gathering when robots enjoy strong
+ multiplicity detection and lights.
+ - [InR/](CaseStudies/Gathering/InR) case studies for the gathering
+ on the Euclidean line
+ - [Impossibility.v](CaseStudies/Gathering/InR/Impossibility.v):
+ *Impossibility of gathering on the line in SSYNC.*
+ Courtieu, Rieg, Tixeuil, Urbain. Impossibility of gathering, a certification. IPL 115.
+ - [Algorithm.v](CaseStudies/Gathering/InR/Algorithm.v): Gathering
+ one the line in SSYNC with strong multiplicity detection, from
+ non bivalent configurations.
+ - [InR2/](CaseStudies/Gathering/InR2) case studies for the gathering
+ on the Euclidean plane
+ - [Peleg.v](CaseStudies/Gathering/InR2/Peleg.v):
+ *Gathering in FSYNC and non rigid moves with weak mutliplicity detection, due to Peleg.*
+ Cohen, Peleg. Convergence Properties of the Gravitational Algorithm in Asynchronous Robot Systems. SIAM Journal of Computing, 34(6):1516–1528, 2005.
+ - [Viglietta.v](CaseStudies/Gathering/InR2/Viglietta.v):
+ Formalization of a protocol for gathering with lights due to Viglietta.
+ Viglietta. *Rendezvous of two robots with visible bits.* ALGOSENSORS 2013.
+ - [FSyncFlexNoMultAlgorithm.v](CaseStudies/Gathering/InR2/FSyncFlexNoMultAlgorithm.v):
+ *Gathering in FSYNC and non rigid moves with no mutliplicity detection.*
+ Balabonski, Delga, Rieg, Tixeuil, Urbain. Synchronous Gathering Without Multiplicity Detection: A Certified Algorithm. Theory Comput. Syst. 63(2): 200-218 (2019)
+ - [Algorithm.v](CaseStudies/Gathering/InR2/Algorithm.v):
+ *SSYNC Gathering in R² with strong multiplicity detection, from
+ non-bivalent configurations.*
+ Courtieu, Rieg, Tixeuil, Urbain. Certified Universal Gathering in R² for Oblivious Mobile Robots. DISC 2016.
+ - [Algorithm_withLight](CaseStudies/Gathering/InR2/Algorithm_withLight.v):
+ *Deterministic Color-optimal Self-stabilizing Semi-synchronous
+ Gathering: a Certified Algorithm*. Bonnet, François, Bramas,
+ Quentin, Courtieu, Pierre, Défago, Xavier, Rieg, Lionel,
+ Tixeuil, Sebastien, Urbain, Xavier.
+- [Exploration/](CaseStudies/Exploration): Exploration of a ring with stop
+ - [ImpossibilityKDividesN.v](CaseStudies/Exploration/ImpossibilityKDividesN.v):
+ *Impossibility of exploration of a ring when the number of robots
+ divides the number of nodes.*
+ Balabonski, Pelle, Rieg, Tixeuil. A Foundational Framework for Certified Impossibility Results with Mobile Robots on Graphs. ICDCN 2018.
+ - [ExplorationDefs.v](CaseStudies/Exploration/ExplorationDefs.v):
+ Common definitions on exploration.
+ - [Tower.v](CaseStudies/Exploration/Tower.v):
+ Exploration with stop on a ring requires forming a tower, in particular one single robot is no enough.
+- [LifeLine/](CaseStudies/LifeLine): Life line connection in the 2D Euclidean plane
+ - [Algorithm.v](CaseStudies/LifeLineAlgorithm.v):
+ *Connection maintenance protocol on R2.*
+ Balabonski, Courtieu, Pelle, Rieg, Tixeuil, Urbain. Computer Aided Formal Design of Swarm Robotics Algorithms. SSS 2021.
+
+# Other Related Ressources
+
+A general description of the Pactole library and its use:
+
+ Courtieu, Rieg, Tixeuil, and Urbain. *Swarms of Mobile Robots: Towards
+ Versatility with Safety.* Leibniz Transactions on Embedded Systems (LITES), 8(2):02:1–
+ 02:36, 2022. [link](https://doi.org/10.4230/LITES.8.2.2)
diff --git a/Spaces/R2.v b/Spaces/R2.v
index 9d1a10424a1a626ffa8de8575fa0b99c8b82f7f7..b4dbb662b68cbacf546cde94d4f40be680da3bd0 100644
--- a/Spaces/R2.v
+++ b/Spaces/R2.v
@@ -32,7 +32,8 @@ Require Export Pactole.Spaces.EuclideanSpace.
Require Import Pactole.Spaces.Similarity.
Set Implicit Arguments.
Open Scope R_scope.
-
+(* Coercion Bijection.section : Bijection.bijection >-> Funclass. *)
+Import ListNotations.
(** ** R² as a Euclidean space over R **)
@@ -186,6 +187,11 @@ destruct (equiv_dec x y); split; discriminate || auto.
intros abs. rewrite e in abs. now contradiction abs.
Qed.
+Lemma R2dec_bool_refl x: R2dec_bool x x = true.
+Proof.
+ unfold R2dec_bool.
+ now rewrite equiv_dec_refl.
+Qed.
(** ** Results not holding in generic Euclidean spaces **)
@@ -1594,23 +1600,17 @@ Qed.
(** ** Barycenter and middle **)
-(* TODO: use instead the generic definition of barycenter from RealVectorSpace.v *)
(* Barycenter is the center of SEC for an equilateral triangle *)
-Definition isobarycenter_3_pts (pt1 pt2 pt3:R2) := mul (Rinv 3) (add pt1 (add pt2 pt3)).
-Lemma isobarycenter_3_pts_compat: forall pt1 pt2 pt3 pt1' pt2' pt3',
- Permutation (pt1 :: pt2 :: pt3 :: nil) (pt1' :: pt2' :: pt3' :: nil) ->
- isobarycenter_3_pts pt1 pt2 pt3 = isobarycenter_3_pts pt1' pt2' pt3'.
-Proof using .
- intros pt1 pt2 pt3 pt1' pt2' pt3' Hperm.
- rewrite <- PermutationA_Leibniz, (PermutationA_3 _) in Hperm.
- decompose [or and] Hperm; clear Hperm; subst;
- reflexivity || unfold isobarycenter_3_pts; f_equal;
- destruct pt1', pt2', pt3'; cbn; f_equal; ring.
+Lemma isobarycenter_3_pts : forall pt1 pt2 pt3 : R2,
+ isobarycenter [pt1; pt2; pt3] = (/3 * (pt1 + pt2 + pt3))%VS.
+Proof.
+intros. unfold isobarycenter. cbn -[add mul].
+rewrite add_origin_l. f_equal. lra.
Qed.
Axiom Barycenter_spec: forall pt1 pt2 pt3 B: R2,
- isobarycenter_3_pts pt1 pt2 pt3 = B ->
+ isobarycenter [pt1; pt2; pt3] = B ->
forall p,
(dist B pt1)² + (dist B pt2)² + (dist B pt3)²
<= (dist p pt1)² + (dist p pt2)² + (dist p pt3)².
@@ -1619,7 +1619,7 @@ Axiom Barycenter_spec: forall pt1 pt2 pt3 B: R2,
Take for instance the coarse distance d(x,y) = 1 <-> x <> y, and pt1, pt2 pt3 different.
Then any one of them is a isobarycenter. *)
Axiom Barycenter_spec_unicity: forall pt1 pt2 pt3 B: R2,
- isobarycenter_3_pts pt1 pt2 pt3 = B <->
+ isobarycenter [pt1; pt2; pt3] = B <->
forall p, p <> B ->
(dist B pt1)² + (dist B pt2)² + (dist B pt3)²
< (dist p pt1)² + (dist p pt2)² + (dist p pt3)².
@@ -1631,23 +1631,14 @@ Definition is_isobarycenter_3_pts pt1 pt2 pt3 B := forall p,
(* TODO? *)
Axiom bary3_spec: forall pt1 pt2 pt3,
- is_isobarycenter_3_pts pt1 pt2 pt3 (isobarycenter_3_pts pt1 pt2 pt3).
+ is_isobarycenter_3_pts pt1 pt2 pt3 (isobarycenter [pt1; pt2; pt3]).
Axiom bary3_unique: forall x y z a b,
- is_isobarycenter_3_pts x y z a -> is_isobarycenter_3_pts x y z b -> equiv a b.
+ is_isobarycenter_3_pts x y z a -> is_isobarycenter_3_pts x y z b -> a == b.
(* the [isobarycenter] is invariant by similarities. *)
Lemma isobarycenter_3_morph: forall (sim : similarity R2) pt1 pt2 pt3,
- isobarycenter_3_pts (sim pt1) (sim pt2) (sim pt3) = sim (isobarycenter_3_pts pt1 pt2 pt3).
-Proof using .
-intros sim pt1 pt2 pt3. eapply bary3_unique.
-+ apply bary3_spec.
-+ intro p. change p with (Similarity.id p). rewrite <- (Similarity.compose_inverse_r sim).
- change ((compose sim (sim â»Â¹)) p) with (sim ((sim â»Â¹) p)).
- repeat rewrite sim.(Similarity.dist_prop), R_sqr.Rsqr_mult. repeat rewrite <- Rmult_plus_distr_l.
- apply Rmult_le_compat_l.
- - apply Rle_0_sqr.
- - apply bary3_spec.
-Qed.
+ isobarycenter [sim pt1; sim pt2; sim pt3] = sim (isobarycenter [pt1; pt2; pt3]).
+Proof using . intros. rewrite <- isobarycenter_sim_morph; auto; discriminate. Qed.
Lemma R2_is_middle_morph : forall x y C (sim : similarity R2),
is_middle x y C -> (is_middle (sim x) (sim y) (sim C)).
@@ -1665,37 +1656,6 @@ apply Rmult_le_compat_l.
- apply Hmid.
Qed.
-(*
-Lemma R2_is_bary3_morph : forall x y z C (sim : similarity R2),
- is_isobarycenter_3_pts x y z C -> (is_isobarycenter_3_pts (sim x) (sim y) (sim z) (sim C)).
-Proof.
-intros x y z C sim Hmid.
-red.
-intros p.
-unfold is_isobarycenter_3_pts in Hmid.
-rewrite <- (@Bijection.section_retraction _ _ (sim.(sim_f)) p).
-setoid_rewrite sim.(dist_prop).
-setoid_rewrite R_sqr.Rsqr_mult.
-repeat setoid_rewrite <- Rmult_plus_distr_l.
-apply Rmult_le_compat_l.
-- apply Rle_0_sqr.
-- apply Hmid.
-Qed.
-
-Lemma R2_bary3_morph : forall x y z (sim : similarity R2),
- (isobarycenter_3_pts (sim x) (sim y) (sim z))%VS = sim ((isobarycenter_3_pts x y z))%VS.
-Proof.
-intros x y z sim.
-generalize (@bary3_spec x y z).
-intro.
-generalize (@bary3_spec (sim x) (sim y) (sim z)).
-intro.
-assert (is_isobarycenter_3_pts (sim x) (sim y) (sim z) (sim (isobarycenter_3_pts x y z))).
-{ apply R2_is_bary3_morph. auto. }
-now apply bary3_unique with (sim x) (sim y) (sim z).
-Qed.
-*)
-
Lemma R2dist_middle : forall pt1 pt2,
dist pt1 (middle pt1 pt2) = /2 * dist pt1 pt2.
Proof using .
@@ -1729,7 +1689,7 @@ Proof using .
Qed.
Lemma middle_diff: forall ptx pty,
- ptx <> pty -> ~InA equiv (middle ptx pty) (ptx :: pty :: nil).
+ ptx =/= pty -> ~InA equiv (middle ptx pty) (ptx :: pty :: nil).
Proof using .
intros ptx pty Hdiff Hin.
inversion_clear Hin; subst.
@@ -1836,26 +1796,27 @@ destruct (equiv_dec pt1 pt2) as [Heq | Hneq].
now rewrite norm_defined.
Qed.
-Lemma middle_isobarycenter_3_neq: forall pt1 pt2 ptopp,
+Lemma middle_isobarycenter_3_neq_aux: forall pt1 pt2 ptopp,
classify_triangle pt1 pt2 ptopp = Equilateral ->
- middle pt1 pt2 = isobarycenter_3_pts pt1 pt2 ptopp ->
- pt1 = pt2.
-Proof using .
-intros pt1 pt2 ptopp Htriangle h_middle_eq_bary.
-unfold isobarycenter_3_pts,middle in h_middle_eq_bary;
- functional inversion Htriangle; rewrite -> ?Rdec_bool_true_iff in *;
- (* I prefer hdist1 hdist2 later :) *)
- repeat progress match goal with
- | HH: dist ?p ?p' = dist ?p'' ?p''' |- _ =>
- let hdist := fresh "hdist" in
- assert (hdist:Rsqr (dist p p') = Rsqr (dist p'' p'''))
- ; [ setoid_rewrite HH; try reflexivity;clear HH | clear HH ]
- end.
+ middle pt1 pt2 == isobarycenter [pt1; pt2; ptopp] ->
+ pt1 == pt2.
+Proof using .
+intros pt1 pt2 ptopp Htriangle Heq.
+unfold middle, isobarycenter in *. cbn -[add mul] in Heq.
+replace (1 + 1 + 1) with 3 in * by lra. rewrite add_origin_l in Heq.
+functional inversion Htriangle; rewrite -> ?Rdec_bool_true_iff in *;
+(* I prefer hdist1 hdist2 later :) *)
+repeat progress match goal with
+ | HH: dist ?p ?p' = dist ?p'' ?p''' |- _ =>
+ let hdist := fresh "hdist" in
+ assert (hdist:Rsqr (dist p p') = Rsqr (dist p'' p'''))
+ ; [ setoid_rewrite HH; try reflexivity;clear HH | clear HH ]
+ end.
rename hdist into hdist2, hdist0 into hdist1.
destruct pt1 as [xA yA], pt2 as [xB yB], ptopp as [xC yC]; cbn in *.
setoid_rewrite Rsqr_sqrt in hdist2; try now (apply Rplus_le_le_0_compat; apply Rle_0_sqr).
setoid_rewrite Rsqr_sqrt in hdist1; try now (apply Rplus_le_le_0_compat; apply Rle_0_sqr).
-inversion h_middle_eq_bary as [[heqx heqy]].
+inversion Heq as [[heqx heqy]].
assert (hand:xA=xB /\ yA = yB).
{ clear -hdist1 hdist2 heqx heqy.
assert (heqxC:(xC = / 2 * (xA + xB))%R) by lra.
@@ -1880,6 +1841,44 @@ assert (hand:xA=xB /\ yA = yB).
destruct hand. now subst.
Qed.
+Lemma middle_isobarycenter_3_neq : forall pt1 pt2 ptx pty ptz,
+ inclA equiv [pt1; pt2] [ptx; pty; ptz] ->
+ classify_triangle ptx pty ptz = Equilateral ->
+ middle pt1 pt2 == isobarycenter [ptx; pty; ptz] ->
+ pt1 == pt2.
+Proof using .
+intros pt1 pt2 ptx pty ptz Hincl Htriangle.
+assert (Hpt1 : pt1 == ptx \/ pt1 == pty \/ pt1 == ptz).
+{ specialize (Hincl _ ltac:(now left)).
+ now rewrite 2 InA_cons, InA_singleton in Hincl. }
+assert (Hpt2 : pt2 == ptx \/ pt2 == pty \/ pt2 == ptz).
+{ specialize (Hincl _ ltac:(now right; left)).
+ now rewrite 2 InA_cons, InA_singleton in Hincl. }
+destruct Hpt1 as [Hpt1 | [Hpt1 | Hpt1]], Hpt2 as [Hpt2 | [Hpt2 | Hpt2]];
+rewrite Hpt1, Hpt2; try reflexivity.
++ now apply middle_isobarycenter_3_neq_aux.
++ assert (Hperm : Permutation [ptx; ptz; pty] [ptx; pty; ptz]) by permut_3_4.
+ rewrite <- Hperm.
+ apply middle_isobarycenter_3_neq_aux.
+ rewrite <- Htriangle. now apply classify_triangle_compat.
++ assert (Hperm : Permutation [pty; ptx; ptz] [ptx; pty; ptz]) by permut_3_4.
+ rewrite <- Hperm.
+ apply middle_isobarycenter_3_neq_aux.
+ rewrite <- Htriangle. now apply classify_triangle_compat.
++ assert (Hperm : Permutation [pty; ptz; ptx] [ptx; pty; ptz]) by permut_3_4.
+ rewrite <- Hperm.
+ apply middle_isobarycenter_3_neq_aux.
+ rewrite <- Htriangle. now apply classify_triangle_compat.
++ assert (Hperm : Permutation [ptz; ptx; pty] [ptx; pty; ptz]) by permut_3_4.
+ rewrite <- Hperm.
+ apply middle_isobarycenter_3_neq_aux.
+ rewrite <- Htriangle. now apply classify_triangle_compat.
++ assert (Hperm : Permutation [ptz; pty; ptx] [ptx; pty; ptz]) by permut_3_4.
+ rewrite <- Hperm.
+ apply middle_isobarycenter_3_neq_aux.
+ rewrite <- Htriangle. now apply classify_triangle_compat.
+Qed.
+
(** Some results about equilateral triangles. *)
Section Equilateral_results.
Variables pt1 pt2 pt3 : R2.
@@ -1922,13 +1921,13 @@ Section Equilateral_results.
Qed.
(* The radius of the circumscribed circle to an equilateral triangle of side length a is (sqrt 3 / 3) * a. *)
- Lemma equilateral_isobarycenter_dist : dist (isobarycenter_3_pts pt1 pt2 pt3) pt1 = sqrt 3 / 3 * dist pt1 pt2.
+ Lemma equilateral_isobarycenter_dist : dist (isobarycenter [pt1; pt2; pt3]) pt1 = sqrt 3 / 3 * dist pt1 pt2.
Proof using Htriangle.
- unfold isobarycenter_3_pts. rewrite norm_dist.
- replace ((/ 3 * (pt1 + (pt2 + pt3)) - pt1))%VS with (2 / 3 * (middle pt2 pt3 - pt1))%VS
- by (unfold middle; destruct pt1, pt2, pt3; simpl; f_equal; lra).
- rewrite norm_mul, <- norm_dist, dist_sym.
- rewrite equilateral_altitude. rewrite Rabs_pos_eq; lra.
+ rewrite norm_dist. rewrite isobarycenter_3_pts.
+ transitivity (norm (2 / 3 * (middle pt2 pt3 - pt1))).
+ + unfold middle. destruct pt1, pt2, pt3. simpl. f_equal. lra.
+ + rewrite norm_mul, <- norm_dist, dist_sym.
+ rewrite equilateral_altitude. rewrite Rabs_pos_eq; lra.
Qed.
End Equilateral_results.
@@ -2059,6 +2058,15 @@ Qed.
Record circle := {center : R2; radius : R}.
+Instance circle_Setoid : Setoid circle.
+Proof.
+exists (fun c1 c2 => center c1 == center c2 /\ radius c1 = radius c2).
+split.
++ abstract (intros []; now split).
++ abstract (intros [] [] []; now split; symmetry).
++ abstract (intros [] [] [] [] []; now split; etransitivity; eauto).
+Defined.
+
Definition enclosing_circle (c : circle) l := forall x, In x l -> dist x (center c) <= (radius c).
Definition on_circle (c : circle) x := Rdec_bool (dist x (center c)) (radius c).
@@ -2069,7 +2077,7 @@ do 2 rewrite <- Forall_forall. apply Forall_Permutation_compat; trivial.
intros ? ? ?. now subst.
Qed.
-Global Instance on_circle_compat : Proper (eq ==> equiv ==> eq) on_circle.
+Global Instance on_circle_compat2 : Proper (eq ==> equiv ==> eq) on_circle.
Proof using . repeat intro. cbn in *. now subst. Qed.
Lemma on_circle_true_iff : forall c pt, on_circle c pt = true <-> dist pt (center c) = radius c.
@@ -2630,7 +2638,7 @@ intros sim l. symmetry. apply SEC_unicity.
apply Rmult_le_reg_l with (/ (Similarity.zoom sim))%R; trivial.
do 2 (apply Rmult_le_compat_l; try lra; []).
apply SEC_spec1. now apply in_map.
- - change eq with equiv. apply Similarity.compose_inverse_l.
+ - change eq with (@equiv R2 _). apply Similarity.compose_inverse_l.
Qed.
(** *** Results about [on_SEC] **)
@@ -2990,13 +2998,6 @@ apply (NoDupA_equivlistA_PermutationA _).
- now apply on_SEC_add_same, middle_strictly_in_SEC_diameter.
Qed.
-Lemma filter_idempotent {A} : forall f (l : list A), filter f (filter f l) = filter f l.
-Proof using .
-intros f l. induction l as [| e l].
-- reflexivity.
-- cbn. destruct (f e) eqn:Hfe; cbn; try rewrite Hfe; now (f_equal + idtac).
-Qed.
-
Lemma on_SEC_is_max_dist : forall l pt pt', In pt l -> In pt' (on_SEC l) ->
dist pt (center (SEC l)) <= dist pt' (center (SEC l)).
Proof using .
@@ -3054,32 +3055,35 @@ Qed.
(** ** Results about isobarycenters, SEC and triangles **)
Lemma isobarycenter_3_pts_inside_SEC : forall pt1 pt2 pt3,
- dist (isobarycenter_3_pts pt1 pt2 pt3) (center (SEC (pt1 :: pt2 :: pt3 :: nil)))
- <= radius (SEC (pt1 :: pt2 :: pt3 :: nil)).
+ dist (isobarycenter [pt1; pt2; pt3]) (center (SEC [pt1; pt2; pt3]))
+ <= radius (SEC [pt1; pt2; pt3]).
Proof using .
-intros pt1 pt2 pt3. unfold isobarycenter_3_pts. do 2 rewrite mul_distr_add.
-remember (center (SEC (pt1 :: pt2 :: pt3 :: nil))) as c.
+intros pt1 pt2 pt3.
+rewrite isobarycenter_3_pts.
+remember (center (SEC [pt1; pt2; pt3])) as c.
transitivity (dist (/3 * pt1)%VS (/3 * c)%VS + dist (/3 * pt2)%VS (/3 * c)%VS + dist (/3 * pt3)%VS (/3 * c)%VS).
-+ replace c with (/3 * c + (/3 * c + /3 * c))%VS at 1.
- - etransitivity. apply dist_subadditive. rewrite Rplus_assoc.
- apply Rplus_le_compat; try reflexivity. apply dist_subadditive.
- - clear Heqc. destruct c. compute. f_equal; field.
++ replace c with (/3 * c + /3 * c + /3 * c)%VS at 1.
+ - rewrite 2 mul_distr_add.
+ etransitivity; [now apply dist_subadditive |].
+ apply Rplus_le_compat; try reflexivity; [].
+ apply dist_subadditive.
+ - clear Heqc. destruct c. compute. f_equal; lra.
+ repeat rewrite dist_homothecy; try lra; [].
rewrite (Rabs_pos_eq (/3) ltac:(lra)).
- remember (radius (SEC (pt1 :: pt2 :: pt3 :: nil))) as r.
- replace r with (/3 * r + /3 * r + /3 * r) by field.
+ remember (radius (SEC [pt1; pt2; pt3])) as r.
+ replace r with (/3 * r + /3 * r + /3 * r) by lra.
repeat apply Rplus_le_compat; (apply Rmult_le_compat; try lra || apply dist_nonneg; []);
subst; apply SEC_spec1; intuition.
Qed.
Lemma triangle_isobarycenter_inside_aux : forall pt1 pt2,
- pt1 <> pt2 -> on_circle (SEC (pt1 :: pt1 :: pt2 :: nil)) (isobarycenter_3_pts pt1 pt1 pt2) = false.
+ pt1 <> pt2 -> on_circle (SEC (pt1 :: pt1 :: pt2 :: nil)) (isobarycenter [pt1; pt1; pt2]) = false.
Proof using .
intros pt1 pt2 Hneq.
rewrite SEC_add_same.
-- rewrite SEC_dueton. apply Bool.not_true_iff_false. rewrite on_circle_true_iff. simpl.
+- rewrite SEC_dueton. apply Bool.not_true_iff_false. rewrite on_circle_true_iff. cbn [center radius].
rewrite square_dist_equiv; try (now assert (Hle := dist_nonneg pt1 pt2); lra); [].
- unfold isobarycenter_3_pts, middle. rewrite square_dist_simpl, R_sqr.Rsqr_mult, square_dist_simpl.
+ rewrite isobarycenter_3_pts. unfold middle. rewrite square_dist_simpl, R_sqr.Rsqr_mult, square_dist_simpl.
intro Habs. apply Hneq. destruct pt1, pt2; simpl in Habs. unfold Rsqr in Habs. field_simplify in Habs.
pose (x := (r² + r1² - 2 * r * r1) + (r0² + r2² - 2 * r0 * r2)).
assert (Heq0 : x = 0). { unfold x. unfold Rsqr in *. field_simplify in Habs. field_simplify. lra. }
@@ -3090,7 +3094,7 @@ rewrite SEC_add_same.
Qed.
Lemma triangle_isobarycenter_inside : forall pt1 pt2 pt3,
- ~(pt1 = pt2 /\ pt1 = pt3) -> on_circle (SEC (pt1 :: pt2 :: pt3 :: nil)) (isobarycenter_3_pts pt1 pt2 pt3) = false.
+ ~(pt1 = pt2 /\ pt1 = pt3) -> on_circle (SEC [pt1; pt2; pt3]) (isobarycenter [pt1; pt2; pt3]) = false.
Proof using .
intros pt1 pt2 pt3 Hneq.
(* if there are only two different points, we use triangle_isobarycenter_inside_aux. *)
@@ -3099,11 +3103,11 @@ destruct (equiv_dec pt1 pt2) as [Heq12 | Heq12];
* assert (Hneq12 : pt1 <> pt3) by now intro; subst; auto. rewrite <- Heq12.
now apply triangle_isobarycenter_inside_aux.
* rewrite <- Heq13.
- assert (Hperm : Permutation (pt1 :: pt2 :: pt1 :: nil) (pt1 :: pt1 :: pt2 :: nil)) by do 2 constructor.
- rewrite Hperm. rewrite (isobarycenter_3_pts_compat Hperm). apply triangle_isobarycenter_inside_aux. auto.
+ assert (Hperm : Permutation [pt1; pt2; pt1] [pt1; pt1; pt2]) by do 2 constructor.
+ rewrite Hperm. apply triangle_isobarycenter_inside_aux. auto.
* rewrite <- Heq23.
assert (Hperm : Permutation (pt1 :: pt2 :: pt2 :: nil) (pt2 :: pt2 :: pt1 :: nil)) by now do 3 econstructor.
- rewrite Hperm. rewrite (isobarycenter_3_pts_compat Hperm). apply triangle_isobarycenter_inside_aux. auto.
+ rewrite Hperm. apply triangle_isobarycenter_inside_aux. auto.
* (* All three points are different, we consider the size of on_SEC *)
assert (Hnodup : NoDup (pt1 :: pt2 :: pt3 :: nil)) by (repeat constructor; simpl in *; intuition).
destruct (on_SEC (pt1 :: pt2 :: pt3 :: nil)) as [| pt1' [| pt2' [| pt3' [| ? ?]]]] eqn:Hsec.
@@ -3138,14 +3142,13 @@ destruct (equiv_dec pt1 pt2) as [Heq12 | Heq12];
- exists pt2. now do 3 econstructor.
- exists pt1. now do 4 econstructor. }
destruct Hpt3' as [pt3' Hperm].
- rewrite <- (isobarycenter_3_pts_compat Hperm).
- rewrite norm_dist. unfold isobarycenter_3_pts, middle.
- destruct (equiv_dec pt3' (1/2 * (pt1' + pt2')))%VS as [Heq | Heq].
- - assert (Hzero : (/3 * (pt1' + (pt2' + pt3')) - 1/2 * (pt1' + pt2') = origin)%VS).
+ rewrite <- Hperm, norm_dist. rewrite isobarycenter_3_pts. unfold middle.
+ destruct (pt3' =?= (1/2 * (pt1' + pt2')))%VS as [Heq | Heq].
+ - assert (Hzero : (/3 * (pt1' + pt2' + pt3') - 1/2 * (pt1' + pt2') = origin)%VS).
{ rewrite Heq. destruct pt1', pt2'. unfold origin. simpl. f_equal; field. }
rewrite Hzero. rewrite norm_origin. apply not_eq_sym. erewrite <- Rmult_0_r.
intro Habs. rewrite <- dist_defined in Hdiff'. apply Rmult_eq_reg_l in Habs; lra.
- - replace ((/ 3 * (pt1' + (pt2' + pt3')) - 1 / 2 * (pt1' + pt2')))%VS
+ - replace ((/ 3 * (pt1' + pt2' + pt3') - 1 / 2 * (pt1' + pt2')))%VS
with (/3 *(pt3' - 1 / 2 * (pt1' + pt2')))%VS.
-- rewrite norm_mul. rewrite Rabs_pos_eq; try lra; [].
rewrite <- norm_dist.
@@ -3181,14 +3184,14 @@ destruct (equiv_dec pt1 pt2) as [Heq12 | Heq12];
assert (Hpt3 : dist pt3 c = r).
{ unfold c, r. rewrite <- on_circle_true_iff. eapply proj2. rewrite <- filter_In.
unfold on_SEC in Hperm. rewrite Hperm. now right; right; left. }
- (* Modifyng goal to have the right shape for the equality case of the triangular inequality. *)
+ (* Modifying goal to have the right shape for the equality case of the triangular inequality. *)
replace c with (/3 * (c + c + c))%VS by (destruct c; simpl; f_equal; field).
- unfold isobarycenter_3_pts. rewrite dist_homothecy, Rabs_pos_eq; try lra; [].
+ rewrite isobarycenter_3_pts. rewrite dist_homothecy, Rabs_pos_eq; try lra; [].
replace r with (/3 * (r + r + r)) by field.
intro Habs. apply Rmult_eq_reg_l in Habs; try lra; [].
(* We use the triangular equality to get colinearity results. *)
destruct (triang_ineq_eq3 (c + c + c) (pt1 + c + c) (pt1 + pt2 + c) (pt1 + pt2 + pt3))%VS as [Hcol1 Hcol2].
- - rewrite add_assoc, dist_sym in Habs. rewrite Habs.
+ - rewrite dist_sym in Habs. rewrite Habs.
repeat rewrite dist_translation. setoid_rewrite add_comm.
repeat rewrite dist_translation. setoid_rewrite dist_sym.
now rewrite Hpt1, Hpt2, Hpt3.
@@ -3223,48 +3226,47 @@ destruct (equiv_dec pt1 pt2) as [Heq12 | Heq12];
Qed.
Lemma isobarycenter_3_pts_strictly_inside_SEC : forall pt1 pt2 pt3, ~(pt1 = pt2 /\ pt1 = pt3) ->
- dist (isobarycenter_3_pts pt1 pt2 pt3) (center (SEC (pt1 :: pt2 :: pt3 :: nil)))
- < radius (SEC (pt1 :: pt2 :: pt3 :: nil)).
+ dist (isobarycenter [pt1; pt2; pt3]) (center (SEC [pt1; pt2; pt3]))
+ < radius (SEC [pt1; pt2; pt3]).
Proof using .
intros pt1 pt2 pt3 Hdiff.
assert (Hle := isobarycenter_3_pts_inside_SEC pt1 pt2 pt3).
destruct Hle as [? | Heq]; trivial.
-assert (Hcircle : on_circle (SEC (pt1 :: pt2 :: pt3 :: nil)) (isobarycenter_3_pts pt1 pt2 pt3) = false).
+assert (Hcircle : on_circle (SEC (pt1 :: pt2 :: pt3 :: nil)) (isobarycenter [pt1; pt2; pt3]) = false).
{ destruct (equiv_dec pt1 pt2).
- - assert (Hperm : PermutationA equiv (pt1 :: pt2 :: pt3 :: nil) (pt1 :: pt3 :: pt2 :: nil)).
+ - assert (Hperm : PermutationA equiv [pt1; pt2; pt3] [pt1; pt3; pt2]).
{ now repeat constructor. }
- rewrite Hperm. rewrite PermutationA_Leibniz in Hperm. rewrite (isobarycenter_3_pts_compat Hperm).
- apply triangle_isobarycenter_inside. intro. intuition.
+ rewrite Hperm. apply triangle_isobarycenter_inside. intro. intuition.
- now apply triangle_isobarycenter_inside. }
unfold on_circle in Hcircle. rewrite Rdec_bool_false_iff in Hcircle. contradiction.
Qed.
Lemma on_SEC_isobarycenter_triangle : forall pt1 pt2 pt3, ~(pt1 = pt2 /\ pt1 = pt3) ->
- equivlistA equiv (on_SEC (isobarycenter_3_pts pt1 pt2 pt3 :: pt1 :: pt2 :: pt3 :: nil))
- (on_SEC (pt1 :: pt2 :: pt3 :: nil)).
+ equivlistA equiv (on_SEC (isobarycenter [pt1; pt2; pt3] :: [pt1; pt2; pt3]))
+ (on_SEC [pt1; pt2; pt3]).
Proof using . intros. now apply on_SEC_add_same, isobarycenter_3_pts_strictly_inside_SEC. Qed.
Axiom equilateral_SEC : forall pt1 pt2 pt3,
classify_triangle pt1 pt2 pt3 = Equilateral ->
SEC (pt1 :: pt2 :: pt3 :: nil) =
- {| center := isobarycenter_3_pts pt1 pt2 pt3;
- radius := dist (isobarycenter_3_pts pt1 pt2 pt3) pt1 |}.
+ {| center := isobarycenter [pt1; pt2; pt3];
+ radius := dist (isobarycenter [pt1; pt2; pt3]) pt1 |}.
Lemma equilateral_isobarycenter_not_eq : forall pt1 pt2 pt3,
- classify_triangle pt1 pt2 pt3 = Equilateral -> ~pt1 == pt2 -> ~isobarycenter_3_pts pt1 pt2 pt3 == pt1.
+ classify_triangle pt1 pt2 pt3 = Equilateral -> pt1 =/= pt2 -> isobarycenter [pt1; pt2; pt3] =/= pt1.
Proof using .
intros pt1 pt2 pt3 Htriangle Hneq.
-assert (Hcenter : center (SEC (pt1 :: pt2 :: pt3 :: nil)) = isobarycenter_3_pts pt1 pt2 pt3).
+assert (Hcenter : center (SEC (pt1 :: pt2 :: pt3 :: nil)) = isobarycenter [pt1; pt2; pt3]).
{ apply equilateral_SEC in Htriangle. now rewrite Htriangle. }
-assert (Hradius : radius (SEC (pt1 :: pt2 :: pt3 :: nil)) = dist (isobarycenter_3_pts pt1 pt2 pt3) pt1).
+assert (Hradius : radius (SEC (pt1 :: pt2 :: pt3 :: nil)) = dist (isobarycenter [pt1; pt2; pt3]) pt1).
{ apply equilateral_SEC in Htriangle. now rewrite Htriangle. }
-rewrite <- dist_defined. rewrite <- Hradius, <- center_on_circle.
+red. rewrite <- dist_defined. rewrite <- Hradius, <- center_on_circle.
rewrite Hcenter. now rewrite triangle_isobarycenter_inside.
Qed.
Lemma equilateral_NoDupA : forall ptx pty ptz,
classify_triangle ptx pty ptz = Equilateral -> ptx <> pty ->
- NoDupA equiv (ptx :: pty :: ptz :: nil).
+ NoDupA equiv [ptx; pty; ptz].
Proof using .
intros ptx pty ptz Htriangle Hdiff.
functional induction (classify_triangle ptx pty ptz) as [Heq1 Heq2 | | | |]; try discriminate.
@@ -3280,7 +3282,7 @@ Qed.
Lemma equilateral_isobarycenter_NoDupA : forall ptx pty ptz,
classify_triangle ptx pty ptz = Equilateral -> ptx <> pty ->
- NoDupA equiv (isobarycenter_3_pts ptx pty ptz :: ptx :: pty :: ptz :: nil).
+ NoDupA equiv (isobarycenter [ptx; pty; ptz] :: [ptx; pty; ptz]).
Proof using .
intros ptx pty ptz Htriangle Hdiff.
constructor.
@@ -3289,13 +3291,13 @@ constructor.
| H : InA _ _ _ |- _ => inversion_clear H
end.
+ now apply (equilateral_isobarycenter_not_eq Htriangle).
- + assert (Hperm : Permutation (ptx :: pty :: ptz :: nil) (pty :: ptx :: ptz :: nil)) by constructor.
- rewrite (isobarycenter_3_pts_compat Hperm) in H0. rewrite (classify_triangle_compat Hperm) in Htriangle.
+ + assert (Hperm : Permutation [ptx; pty; ptz] [pty; ptx; ptz]) by constructor.
+ rewrite Hperm in H0. rewrite (classify_triangle_compat Hperm) in Htriangle.
apply (equilateral_isobarycenter_not_eq Htriangle); trivial; [].
intuition.
- + assert (Hperm : Permutation (ptx :: pty :: ptz :: nil) (ptz :: ptx :: pty :: nil)).
+ + assert (Hperm : Permutation [ptx; pty; ptz] [ptz; ptx; pty]).
{ now etransitivity; repeat constructor. }
- rewrite (isobarycenter_3_pts_compat Hperm) in H. rewrite (classify_triangle_compat Hperm) in Htriangle.
+ rewrite Hperm in H. rewrite (classify_triangle_compat Hperm) in Htriangle.
apply (equilateral_isobarycenter_not_eq Htriangle); trivial; [].
functional induction (classify_triangle ptz ptx pty) as [Heq1 Heq2 | | | |]; try discriminate.
rewrite Rdec_bool_true_iff in *.
@@ -3304,70 +3306,18 @@ constructor.
- now apply equilateral_NoDupA.
Qed.
-(** Tactic solving permutations proofs for up to 4 elements.
- Some cases with 4 elements are not yet treated. *)
-Ltac permut_3_4 :=
- try match goal with
- | |- @Permutation _ _ _ => apply PermutationA_Leibniz
- end;
- match goal with
- | |- @PermutationA _ _ ?l ?l => reflexivity
- | |- @PermutationA _ _ (?a::?l) (?a::?l2) =>
- constructor 2;[reflexivity | permut_3_4 ]
- | |- @PermutationA _ _ (?a::?b::?l) (?b::?a::?l2) =>
- transitivity (b::a::l); [constructor 3|constructor 2; [reflexivity|constructor 2; [reflexivity|permut_3_4]]]
- | |- @PermutationA _ _ (?a::?b::?c::nil) (?c::?a::?b::nil) =>
- apply PermutationA_app_comm with (lâ‚:=a::b::nil)(lâ‚‚:=c::nil);try autoclass
- | |- @PermutationA _ _ (?a::?b::?c::nil) (?b::?c::?a::nil) =>
- apply PermutationA_app_comm with (lâ‚:=a::nil)(lâ‚‚:=b::c::nil);try autoclass
- | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?d::?a::?b::?c::nil) =>
- apply PermutationA_app_comm with (lâ‚:=a::nil)(lâ‚‚:=b::c::d::nil);try autoclass
- | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?c::?d::?a::?b::nil) =>
- apply PermutationA_app_comm with (lâ‚:=a::b::nil)(lâ‚‚:=c::d::nil);try autoclass
- | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?d::?a::?b::?c::nil) =>
- apply PermutationA_app_comm with (lâ‚:=a::b::c::nil)(lâ‚‚:=d::nil);try autoclass
- | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?a::?d::?b::?c::nil) =>
- constructor 2;
- apply PermutationA_app_comm with (lâ‚:=b::c::nil)(lâ‚‚:=d::nil);try autoclass
- | |- @PermutationA _ _ (?a::?b::?c::nil) (?c::?b::?a::nil) =>
- transitivity (b::c::a::nil);
- [ apply PermutationA_app_comm with (lâ‚:=a::nil)(lâ‚‚:=b::c::nil);try autoclass
- | constructor 3;reflexivity
- ]
- | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?b::?d::?a::?c::nil) =>
- transitivity (b::c::d::a::nil);
- [ apply PermutationA_app_comm with (lâ‚:=a::nil)(lâ‚‚:=b::c::d::nil);try autoclass
- | constructor 2;
- [reflexivity
- | apply PermutationA_app_comm with (lâ‚:=c::nil)(lâ‚‚:=d::a::nil);try autoclass ]
- ]
- | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?b::?c::?a::?d::nil) =>
- transitivity (a::d::b::c::nil);
- [ constructor 2;
- [reflexivity
- | apply PermutationA_app_comm with (lâ‚:=b::c::nil)(lâ‚‚:=d::nil);try autoclass ]
- | apply PermutationA_app_comm with (lâ‚:=a::d::nil)(lâ‚‚:=b::c::nil);try autoclass ]
- | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?d::?c::?b::?a::nil) =>
- transitivity (c::d::b::a::nil);
- [ transitivity (c::d::a::b::nil);
- [ apply PermutationA_app_comm with (lâ‚:=a::b::nil)(lâ‚‚:=c::d::nil);try autoclass
- | do 2 constructor 2; constructor 3 ]
- | constructor 3;reflexivity ]
- end.
-
(* In a equilateral triangle x y z with isobarycenter b, if the middle of [b,y]
is equal to x then the triangle is degenerated. *)
Lemma equilateral_isobarycenter_degenerated: forall ptx pty ptopp white,
classify_triangle ptx pty ptopp = Equilateral ->
- white = isobarycenter_3_pts ptx pty ptopp ->
+ white = isobarycenter [ptx; pty; ptopp] ->
ptx = middle ptopp white ->
ptx = ptopp.
Proof using .
intros ptx pty ptopp white hequil hwhite hmid.
assert (h_dist:=R2dist_middle white ptopp).
assert (h_dist_bary:=@equilateral_SEC ptx pty ptopp hequil).
- assert (h_permut:Permutation (ptopp :: pty :: ptx :: nil) (ptx :: pty :: ptopp :: nil) ).
- { permut_3_4. }
+ assert (h_permut : Permutation [ptopp; pty; ptx] [ptx; pty; ptopp]) by permut_3_4.
assert (hequil': classify_triangle ptopp pty ptx = Equilateral).
{ rewrite <- hequil.
eapply classify_triangle_compat.
@@ -3376,10 +3326,10 @@ Proof using .
rewrite h_permut in h_dist_bary'.
rewrite h_dist_bary' in h_dist_bary.
injection h_dist_bary.
- intros h_disteq h_baryeq_snd h_baryeq_fst.
- unfold isobarycenter_3_pts in h_disteq. simpl in h_disteq.
- rewrite h_baryeq_fst, h_baryeq_snd in h_disteq.
- setoid_rewrite <- hwhite in h_disteq.
+ intros h_disteq.
+ change (dist (isobarycenter [ptx; pty; ptopp]) ptopp
+ = dist (isobarycenter [ptx; pty; ptopp]) ptx) in h_disteq.
+ rewrite <- hwhite in h_disteq.
rewrite h_disteq in h_dist.
rewrite middle_comm in h_dist.
assert (dist white (middle ptopp white) = 0%R).
@@ -3398,10 +3348,10 @@ Qed.
Lemma equilateral_isobarycenter_degenerated_gen: forall ptx pty ptz ptopp white mid,
classify_triangle ptx pty ptz = Equilateral ->
- white = isobarycenter_3_pts ptx pty ptz ->
- In ptopp (ptx :: pty :: ptz :: nil) ->
+ white = isobarycenter [ptx; pty; ptz] ->
+ In ptopp [ptx; pty; ptz] ->
mid = middle ptopp white ->
- In mid (ptx :: pty :: ptz :: nil) ->
+ In mid [ptx; pty; ptz] ->
mid = ptopp.
Proof using .
intros ptx pty ptz ptopp white mid hequil hwhite hptopp hmid h.
@@ -3414,7 +3364,7 @@ Proof using .
+ subst pty.
apply (@equilateral_isobarycenter_degenerated mid ptz ptopp white); auto.
* erewrite classify_triangle_compat; eauto; permut_3_4.
- * erewrite isobarycenter_3_pts_compat; eauto; permut_3_4.
+ * rewrite hwhite. change eq with (@equiv R2 _). apply isobarycenter_compat. permut_3_4.
+ subst ptz.
apply (@equilateral_isobarycenter_degenerated mid pty ptopp white); auto.
- subst pty.
@@ -3423,24 +3373,24 @@ Proof using .
+ subst ptx.
apply (@equilateral_isobarycenter_degenerated mid ptz ptopp white); auto.
* erewrite classify_triangle_compat; eauto; permut_3_4.
- * erewrite isobarycenter_3_pts_compat; eauto; permut_3_4.
+ * rewrite hwhite. change eq with (@equiv R2 _). apply isobarycenter_compat. permut_3_4.
+ assumption.
+ subst ptz.
eapply equilateral_isobarycenter_degenerated with (pty:=ptx); eauto.
* erewrite classify_triangle_compat; eauto; permut_3_4.
- * subst white.
- erewrite isobarycenter_3_pts_compat; eauto; permut_3_4.
+ * subst white. rewrite hmid at 1. f_equal.
+ change eq with (@equiv R2 _). apply isobarycenter_compat. permut_3_4.
- subst ptz.
simpl in hptopp.
decompose [or] hptopp;clear hptopp;try contradiction.
+ subst ptx.
apply (@equilateral_isobarycenter_degenerated mid pty ptopp white); auto.
* erewrite classify_triangle_compat; eauto; permut_3_4.
- * erewrite isobarycenter_3_pts_compat; eauto; permut_3_4.
+ * rewrite hwhite. change eq with (@equiv R2 _). apply isobarycenter_compat. permut_3_4.
+ subst pty.
eapply equilateral_isobarycenter_degenerated with (pty:=ptx); eauto.
* erewrite classify_triangle_compat; eauto; permut_3_4.
- * subst white.
- erewrite isobarycenter_3_pts_compat; eauto; permut_3_4.
+ * subst white. rewrite hmid at 1. f_equal.
+ change eq with (@equiv R2 _). apply isobarycenter_compat. permut_3_4.
+ assumption.
Qed.
diff --git a/Util/Bijection.v b/Util/Bijection.v
index a7ed108b9a9e59b441049fe638bcd1a1ea30d343..c0a8672c465f0bae90aa288fa8cfe8253ad0f085 100644
--- a/Util/Bijection.v
+++ b/Util/Bijection.v
@@ -26,7 +26,7 @@ Context {T : Type}.
Context {HeqT : Setoid T}.
Record bijection := {
- section :> T → T;
+ #[export] section :> T → T;
retraction : T → T;
section_compat : Proper (equiv ==> equiv) section;
Inversion : ∀ x y, section x == y ↔ retraction y == x}.
diff --git a/Util/FMaps/FMapInterface.v b/Util/FMaps/FMapInterface.v
index e8495defc32392b02ca0557398c4c563dd287674..a730867b7ff6dfe06010774357ac7e2ea3e36b1c 100644
--- a/Util/FMaps/FMapInterface.v
+++ b/Util/FMaps/FMapInterface.v
@@ -11,7 +11,7 @@ Generalizable All Variables.
finite maps. *)
Definition Cmp {elt : Type} (cmp : elt -> elt -> bool) e1 e2 := cmp e1 e2 = true.
-
+
(** * [FMaps] : the interface of maps
We define the class [FMap] of structures that implement finite
diff --git a/Util/ListComplements.v b/Util/ListComplements.v
index 9bd172c449c1f2352a37909b38a0659a24fa3f95..91ad6a8e16b1ffcb1f8f56b13ccf3a8d866a0fe6 100644
--- a/Util/ListComplements.v
+++ b/Util/ListComplements.v
@@ -125,8 +125,6 @@ Qed.
Lemma length_0 : forall l : list A, length l = 0 -> l = nil.
Proof using . intros [|] H; reflexivity || discriminate H. Qed.
-(* Require Import Omega. *)
-
Lemma InA_nth : forall d x (l : list A), InA eqA x l ->
exists n y, (n < length l)%nat /\ eqA x y /\ nth n l d = y.
Proof using .
@@ -204,6 +202,9 @@ intros d [| x l] Hl.
- now left.
Qed.
+Lemma hd_eqlistA_compat : Proper (eqA ==> eqlistA eqA ==> eqA) (@hd A).
+Proof using . intros x y Hxy l1 l2 Hl. now inv Hl; cbn. Qed.
+
Lemma last_In : forall l (d : A), l <> List.nil -> List.In (List.last l d) l.
Proof using .
induction l as [| x l]; intros d Hl.
@@ -245,6 +246,20 @@ Proof using . intros d l. destruct l; simpl; trivial; []. now rewrite app_last.
Corollary hd_rev_last : forall (d : A) l, hd d (rev l) = last l d.
Proof using . intros d l. rewrite <- (rev_involutive l) at 2. now rewrite last_rev_hd. Qed.
+Lemma list_len_ind : forall P : list A -> Prop,
+ (forall l, (forall l', length l' < length l -> P l') -> P l) ->
+ forall l, P l.
+Proof using .
+intros P Hrec l.
+cut (forall l', length l' <= length l -> P l').
+{ intro Hl. now apply Hl. }
+induction (length l).
++ intros [] Hlen.
+ - apply Hrec. intros. cbn in *. lia.
+ - cbn in *. lia.
++ intros. apply Hrec. intros. apply IHn. lia.
+Qed.
+
Lemma eqlistA_Leibniz : forall l1 l2 : list A, eqlistA eq l1 l2 <-> l1 = l2.
Proof using .
intro l1. induction l1 as [| e1 l1]; intro l2.
@@ -386,14 +401,17 @@ intros f Hf l y. induction l.
Qed.
Theorem map_injective_NoDupA : forall f, Proper (eqA ==> eqB) f -> injective eqA eqB f ->
- forall l, NoDupA eqA l -> NoDupA eqB (map f l).
+ forall l, NoDupA eqB (map f l) <-> NoDupA eqA l.
Proof using HeqA HeqB.
-intros f Hf Hinj l Hnodup. induction Hnodup.
-+ constructor.
-+ simpl. constructor.
- - rewrite InA_map_iff; trivial. intros [y [Heq Hin]].
- apply Hinj in Heq. rewrite Heq in Hin. contradiction.
- - assumption.
+intros f Hf Hinj l. induction l as [| e l]; cbn.
++ split; constructor.
++ split; intro Hnodup; inv Hnodup; constructor; try now intuition.
+ - revert_all. intros Hnot_in Hin. apply Hnot_in.
+ rewrite InA_map_iff; auto.
+ exists e. split; trivial. now apply Hf.
+ - revert_all. intros Hnot_in Hin. apply Hnot_in.
+ rewrite InA_map_iff in Hin; auto. destruct Hin as [? [Heq Hin]].
+ apply Hinj in Heq. now rewrite <- Heq.
Qed.
Lemma map_NoDupA_inv : forall f, Proper (eqA ==> eqB) f ->
@@ -446,6 +464,56 @@ intros f Hf l l' perm. induction perm; simpl.
now transitivity (map f lâ‚‚).
Qed.
+
+Lemma InA_map:
+ forall f : A -> B,
+ Proper (eqA ==> eqB) f ->
+ forall (l : list A)
+ (x : A), InA eqA x l -> InA eqB (f x) (List.map f l).
+Proof using.
+ intros f hProper l.
+ induction l.
+ - intros x hInA.
+ apply InA_nil in hInA.
+ contradiction.
+ - intros x hInA.
+ inversion hInA;subst.
+ + constructor 1.
+ apply hProper.
+ assumption.
+ + cbn.
+ constructor 2.
+ now apply IHl.
+Qed.
+
+Lemma InA_map_not: forall f : A -> B,
+ Proper (eqA ==> eqB) f ->
+ forall (l : list A)
+ (x : A), ~InA eqB (f x) (List.map f l) -> ~InA eqA x l.
+Proof using HeqB.
+ intros f hProper l.
+ induction l.
+ - intros x hnotInB.
+ intro abs.
+ apply InA_nil in abs.
+ contradiction.
+ - intros x hnotInB.
+ intro abs.
+ inversion abs;subst.
+ + apply hnotInB.
+ rewrite H0.
+ cbn.
+ now constructor 1.
+ + cbn in *.
+ eapply IHl.
+ 2: eassumption.
+ intro abs2.
+ apply hnotInB.
+ constructor 2.
+ assumption.
+Qed.
+
+
(** *** Function [alls x n] creating a list of size [n] containing only [x] **)
Fixpoint alls (x : A) n :=
@@ -642,7 +710,7 @@ Proof using . intros HF2. induction HF2 ; cbn ; lia. Qed.
Global Instance InA_perm_compat : Proper (eqA ==> PermutationA eqA ==> iff) (InA eqA).
Proof using HeqA. intros x y Hxy l1 l2 Hl. now apply InA_compat; try apply PermutationA_equivlistA. Qed.
-Lemma Permutation_PermutationA_weak : forall l1 l2, Permutation l1 l2 -> PermutationA eqA l1 l2.
+Global Instance Permutation_PermutationA_subrelation : subrelation (@Permutation A) (PermutationA eqA).
Proof using HeqA. intros ? ? Heq. induction Heq; try now constructor. now transitivity l'. Qed.
Global Instance PermutationA_compat :
@@ -826,7 +894,7 @@ Proof using HeqA.
Qed.
Theorem PermutationA_cons_inv :
- forall l l' (a : A), PermutationA eqA (a::l) (a::l') -> PermutationA eqA l l'.
+ forall l l' (a : A), PermutationA eqA (a :: l) (a :: l') -> PermutationA eqA l l'.
Proof using HeqA. intros; exact (PermutationA_app_inv nil l nil l' a H). Qed.
Global Instance PermutationA_length : Proper (PermutationA eqA ==> Logic.eq) (@length A).
@@ -979,6 +1047,108 @@ Proof using Type.
Qed.
+Lemma PermutationA_3_swap : forall l e1 e2 e3 pt1 pt2,
+ complement eqA pt1 pt2 ->
+ InA eqA pt1 (e1 :: e2 :: e3 :: l) ->
+ InA eqA pt2 (e1 :: e2 :: e3 :: l) ->
+ exists pt l', PermutationA eqA (e1 :: e2 :: e3 :: l) (pt1 :: pt2 :: pt :: l').
+Proof using HeqA.
+intros l e1 e2 e3 pt1 pt2 Hdiff Hin1 Hin2.
+pose (l' := e1 :: e2 :: e3 :: l).
+(* assert (Hneq : e1 =/= e2 /\ e1 =/= e3 /\ e2 =/= e3).
+{ assert (Hnodup := support_NoDupA obs). rewrite Hsupport in Hnodup.
+ inv Hnodup. inv H2. repeat rewrite InA_cons in *. intuition. }
+destruct Hneq as [Hneq12 [Hneq13 Hneq23]]. *)
+repeat rewrite InA_cons in *.
+destruct Hin1 as [Heq1 | [Heq2 | [Heq3 | Heq4]]],
+ Hin2 as [Heq1' | [Heq2' | [Heq3' | Heq4']]];
+try now elim Hdiff; etransitivity; try eassumption; []; eauto.
++ (* pt1 == e1, pt2 == e2 *)
+ exists e3, l. now rewrite Heq1, Heq2'.
++ (* pt1 == e1, pt2 == e3 *)
+ exists e2, l. rewrite Heq1, Heq3'.
+ now apply permA_skip, permA_swap.
++ (* pt1 == e1, pt2 other *)
+ apply PermutationA_split in Heq4'; autoclass; []. destruct Heq4' as [l'' Hperm].
+ exists e2, (e3 :: l'').
+ rewrite Heq1, Hperm. apply permA_skip; [reflexivity |].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
++ (* pt1 == e2, pt2 == e1 *)
+ exists e3, l. rewrite Heq1', Heq2.
+ now apply permA_swap.
++ (* pt1 == e2, pt2 == e3 *)
+ exists e1, l. rewrite Heq2, Heq3'.
+ etransitivity; [apply permA_swap | apply permA_skip; [reflexivity |]].
+ apply permA_swap.
++ (* pt1 == e2, pt2 other *)
+ apply PermutationA_split in Heq4'; autoclass; []. destruct Heq4' as [l'' Hperm].
+ exists e1, (e3 :: l'').
+ rewrite Hperm, Heq2.
+ etransitivity; [apply permA_swap | apply permA_skip; [reflexivity |]].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
++ (* pt1 == e3, pt2 == e1 *)
+ exists e2, l. rewrite Heq1', Heq3.
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ now apply permA_swap.
++ (* pt1 == e3, pt2 == e2 *)
+ exists e1, l. rewrite Heq3, Heq2'.
+ etransitivity; [apply permA_swap |].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
++ apply PermutationA_split in Heq4'; autoclass; []. destruct Heq4' as [l'' Hperm].
+ exists e1, (e2 :: l'').
+ rewrite Hperm, Heq3.
+ transitivity (e1 :: pt2 :: e2 :: e3 :: l'').
+ - apply permA_skip; [reflexivity |]; [].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
+ - etransitivity; [apply permA_swap |].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
++ (* pt1 other, pt2 == e1 *)
+ apply PermutationA_split in Heq4; autoclass; []. destruct Heq4 as [l'' Hperm].
+ exists e2, (e3 :: l'').
+ rewrite Hperm, Heq1'.
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
++ (* pt1 other, pt2 == e2 *)
+ apply PermutationA_split in Heq4; autoclass; []. destruct Heq4 as [l'' Hperm].
+ exists e1, (e3 :: l'').
+ rewrite Hperm, Heq2'.
+ etransitivity; [apply permA_swap |].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
++ (* pt1 other, pt2 == e3 *)
+ apply PermutationA_split in Heq4; autoclass; []. destruct Heq4 as [l'' Hperm].
+ exists e1, (e2 :: l'').
+ rewrite Hperm, Heq3'.
+ transitivity (e1 :: pt1 :: e2 :: e3 :: l'').
+ - apply permA_skip; [reflexivity |]; [].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
+ - etransitivity; [apply permA_swap | apply permA_skip; [reflexivity |]].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
++ (* pt1 other, pt2 == e3 *)
+ apply PermutationA_split in Heq4; autoclass; []. destruct Heq4 as [l'' Hperm].
+ rewrite Hperm, InA_cons in Heq4'. destruct Heq4' as [? | Heq4']; [now elim Hdiff |].
+ apply PermutationA_split in Heq4'; autoclass; []. destruct Heq4' as [l''' Hperm'].
+ exists e1, (e2 :: e3 :: l''').
+ rewrite Hperm, Hperm'.
+ transitivity (pt1 :: e1 :: e2 :: e3 :: pt2 :: l''').
+ - etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
+ - apply permA_skip; [reflexivity |]; [].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ etransitivity; [apply permA_skip; [reflexivity |] | apply permA_swap].
+ apply permA_swap.
+Qed.
End List_results.
@@ -1121,6 +1291,57 @@ Proof using . intros f pt n. induction n. reflexivity. simpl. now rewrite IHn. Q
Global Hint Immediate eqlistA_Leibniz_equiv PermutationA_Leibniz_equiv : core.
+(** Tactic solving permutations proofs for up to 4 elements.
+ Some cases with 4 elements are not yet treated. *)
+Ltac permut_3_4 :=
+ try match goal with
+ | |- @Permutation _ _ _ => apply PermutationA_Leibniz
+ end;
+ match goal with
+ | |- @PermutationA _ _ ?l ?l => reflexivity
+ | |- @PermutationA _ _ (?a::?l) (?a::?l2) =>
+ constructor 2;[reflexivity | permut_3_4 ]
+ | |- @PermutationA _ _ (?a::?b::?l) (?b::?a::?l2) =>
+ transitivity (b::a::l); [constructor 3|constructor 2; [reflexivity|constructor 2; [reflexivity|permut_3_4]]]
+ | |- @PermutationA _ _ (?a::?b::?c::nil) (?c::?a::?b::nil) =>
+ apply PermutationA_app_comm with (lâ‚:=a::b::nil)(lâ‚‚:=c::nil);try autoclass
+ | |- @PermutationA _ _ (?a::?b::?c::nil) (?b::?c::?a::nil) =>
+ apply PermutationA_app_comm with (lâ‚:=a::nil)(lâ‚‚:=b::c::nil);try autoclass
+ | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?d::?a::?b::?c::nil) =>
+ apply PermutationA_app_comm with (lâ‚:=a::nil)(lâ‚‚:=b::c::d::nil);try autoclass
+ | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?c::?d::?a::?b::nil) =>
+ apply PermutationA_app_comm with (lâ‚:=a::b::nil)(lâ‚‚:=c::d::nil);try autoclass
+ | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?d::?a::?b::?c::nil) =>
+ apply PermutationA_app_comm with (lâ‚:=a::b::c::nil)(lâ‚‚:=d::nil);try autoclass
+ | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?a::?d::?b::?c::nil) =>
+ constructor 2;
+ apply PermutationA_app_comm with (lâ‚:=b::c::nil)(lâ‚‚:=d::nil);try autoclass
+ | |- @PermutationA _ _ (?a::?b::?c::nil) (?c::?b::?a::nil) =>
+ transitivity (b::c::a::nil);
+ [ apply PermutationA_app_comm with (lâ‚:=a::nil)(lâ‚‚:=b::c::nil);try autoclass
+ | constructor 3;reflexivity
+ ]
+ | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?b::?d::?a::?c::nil) =>
+ transitivity (b::c::d::a::nil);
+ [ apply PermutationA_app_comm with (lâ‚:=a::nil)(lâ‚‚:=b::c::d::nil);try autoclass
+ | constructor 2;
+ [reflexivity
+ | apply PermutationA_app_comm with (lâ‚:=c::nil)(lâ‚‚:=d::a::nil);try autoclass ]
+ ]
+ | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?b::?c::?a::?d::nil) =>
+ transitivity (a::d::b::c::nil);
+ [ constructor 2;
+ [reflexivity
+ | apply PermutationA_app_comm with (lâ‚:=b::c::nil)(lâ‚‚:=d::nil);try autoclass ]
+ | apply PermutationA_app_comm with (lâ‚:=a::d::nil)(lâ‚‚:=b::c::nil);try autoclass ]
+ | |- @PermutationA _ _ (?a::?b::?c::?d::nil) (?d::?c::?b::?a::nil) =>
+ transitivity (c::d::b::a::nil);
+ [ transitivity (c::d::a::b::nil);
+ [ apply PermutationA_app_comm with (lâ‚:=a::b::nil)(lâ‚‚:=c::d::nil);try autoclass
+ | do 2 constructor 2; constructor 3 ]
+ | constructor 3;reflexivity ]
+ end.
+
(** *** Results about [NoDupA] **)
@@ -1135,13 +1356,13 @@ intro l. split; intro Hl; induction l; inversion_clear Hl; constructor;
(now rewrite <- InA_Leibniz in *) || now apply IHl.
Qed.
-Lemma NoDupA_2 : forall x y, ~eqA x y -> NoDupA eqA (x :: y :: nil).
+Lemma NoDupA_2 : forall x y, NoDupA eqA (x :: y :: nil) <-> ~eqA x y.
Proof using .
-intros x y Hdiff. constructor.
- intro Habs. inversion_clear Habs.
- now contradiction Hdiff.
- inversion H.
- apply NoDupA_singleton.
+intros x y. split; intro Hdiff.
++ inv Hdiff. rewrite InA_cons, InA_nil in *. intuition.
++ constructor.
+ - rewrite InA_cons, InA_nil. intuition.
+ - apply NoDupA_singleton.
Qed.
Lemma NoDupA_3 : forall x y z, ~eqA x y -> ~eqA y z -> ~eqA x z -> NoDupA eqA (x :: y :: z :: nil).
@@ -1268,6 +1489,9 @@ intros f g Hfg l1. induction l1 as [| x l1]; intros l2 Hl; simpl.
simpl. destruct (g y); try constructor; auto.
Qed.
+Lemma filter_false : forall (l : list A), filter (fun _ => false) l = nil.
+Proof using. induction l; auto. Qed.
+
Lemma filter_twice : forall f (l : list A), filter f (filter f l) = filter f l.
Proof using .
intros f l. induction l as [| e l]; simpl; auto.
@@ -1443,15 +1667,15 @@ intro l1. induction l1 as [| a l1]; intros l2 Hnodup Hincl.
apply inclA_cons_inv in Hincl; trivial. simpl. apply le_n_S. now apply IHl1.
Qed.
-Lemma NoDupA_inclA_length_PermutationA : forall l1 l2, NoDupA eqA l1 -> NoDupA eqA l2 ->
+Lemma NoDupA_inclA_length_PermutationA : forall l1 l2, NoDupA eqA l1 ->
inclA eqA l1 l2 -> length l2 <= length l1 -> PermutationA eqA l1 l2.
Proof using HeqA.
-intro l1. induction l1 as [| x l1]; intros l2 Hnodup1 Hnodup2 Hincl Hlen.
+intro l1. induction l1 as [| x l1]; intros l2 Hnodup1 Hincl Hlen.
+ destruct l2; try reflexivity. cbn in *. lia.
+ assert (Hin : InA eqA x l2). { apply Hincl. now left. }
apply (PermutationA_split _) in Hin. destruct Hin as [l2' Heql2].
rewrite Heql2 in *. constructor; try reflexivity.
- inversion_clear Hnodup1. inversion_clear Hnodup2.
+ inversion_clear Hnodup1.
apply inclA_cons_inv in Hincl; trivial. apply IHl1; auto. cbn in *. lia.
Qed.
@@ -1583,6 +1807,18 @@ Corollary PermutationA_count_split : forall x l,
PermutationA eqA l (alls x (countA_occ x l) ++ removeA eq_dec x l).
Proof using HeqA. intros. now rewrite <- countA_occ_spec. Qed.
+Lemma count_filter_length: forall x l,
+ countA_occ x l = length (List.filter (fun a => if eq_dec a x then true else false) l).
+Proof using.
+ induction l;auto.
+ cbn.
+ destruct (eq_dec a x);cbn.
+ - rewrite IHl.
+ reflexivity.
+ - rewrite IHl.
+ reflexivity.
+Qed.
+
Lemma countA_occ_removeA_same x l :
countA_occ x (removeA eq_dec x l) = 0.
Proof using HeqA.
@@ -1599,9 +1835,9 @@ Proof using HeqA.
intros Hxy. induction l as [|z l IH].
+ reflexivity.
+ cbn. repeat destruct_match.
- - rewrite <-e in e0. intuition.
+ - rewrite <-H in H0. intuition.
- now rewrite IH.
- - rewrite e. cbn. destruct_match ; [|intuition]. now rewrite IH.
+ - rewrite H0. cbn. destruct_match ; [|intuition]. now rewrite IH.
- cbn. destruct_match ; [intuition|]. now rewrite IH.
Qed.
@@ -1613,8 +1849,9 @@ split.
+ intros Hperm x. elim Hperm.
- now reflexivity.
- intros x1 x2 l1 l2 Hx Hl IH. cbn.
- repeat destruct_match ; try (now rewrite IH) ;
- rewrite <-e, Hx in * ; now intuition.
+ repeat destruct_match ; try (now rewrite IH).
+ * rewrite <-H, Hx in * ; now intuition.
+ * rewrite <-H0, Hx in * ; now intuition.
- intros a b t. cbn. repeat destruct_match ; reflexivity.
- intros l1 l2 l3 _ H1 _ H2. now rewrite H1, <-H2.
+ intros Hcount. remember (length l) as m. generalize l l' Heqm Hcount.
@@ -2095,7 +2332,7 @@ induction l1; simpl in *; intuition. constructor.
Qed.
Theorem PermutationA_rev : forall l, PermutationA eqA l (rev l).
-Proof using HeqA. intro. apply (Permutation_PermutationA_weak _). apply Permutation_rev. Qed.
+Proof using HeqA. intro. now rewrite <- Permutation_rev. Qed.
Lemma fold_symmetric : forall (f : B -> A -> B),
Proper (eqB ==> eqA ==> eqB) f -> (forall x y z, eqB (f (f z x) y) (f (f z y) x)) ->
@@ -2162,6 +2399,43 @@ induction n using nat_ind2; intros l Hl [m Hm].
now rewrite rev_length.
Qed.
+(** Remove duplicate elements inside a list *)
+Fixpoint removeA_dups eqA_dec (l : list A) :=
+ match l with
+ | nil => nil
+ | e :: l => if mem eqA_dec e l then removeA_dups eqA_dec l else (e :: removeA_dups eqA_dec l)
+ end.
+
+Lemma removeA_dups_spec : forall eqA_dec l,
+ equivlistA eqA (removeA_dups eqA_dec l) l /\ NoDupA eqA (removeA_dups eqA_dec l).
+Proof using HeqA.
+intros eqA_dec l.
+induction l; cbn.
+* now split.
+* destruct IHl as [Hequiv Hnodup].
+ destruct_match.
+ + split; auto; [].
+ rewrite Hequiv.
+ split; intro Hin.
+ - now right.
+ - rewrite InA_cons in Hin. destruct Hin as [Heq | Hin]; trivial; [].
+ rewrite Heq, <- mem_true_iff. eassumption.
+ + split.
+ - now rewrite Hequiv.
+ - constructor; trivial; [].
+ now rewrite mem_false_iff, <- Hequiv in *.
+Qed.
+
+Global Instance removeA_dups_compat : forall eqA_dec,
+ Proper (PermutationA eqA ==> PermutationA eqA) (removeA_dups eqA_dec).
+Proof using HeqA.
+intros eqA_dec l1 l2 Hperm.
+apply NoDupA_equivlistA_PermutationA; trivial; try apply removeA_dups_spec; [].
+transitivity l1.
++ apply removeA_dups_spec.
++ rewrite Hperm. symmetry. apply removeA_dups_spec.
+Qed.
+
Theorem partition_filter : forall (f : A -> bool) l,
partition f l = (filter f l, filter (fun x => negb (f x)) l).
Proof using .
@@ -2247,6 +2521,13 @@ Qed.
End ToSortOut_results.
+Global Instance incl_PreOrder {A} : PreOrder (@incl A).
+Proof.
+split.
++ now intros l x Hin.
++ intros l1 l2 l3 H12 H23 x Hin. now apply H23, H12.
+Qed.
+
Global Arguments mem [A] [eqA] eq_dec x l.
Corollary partition_Permutation : forall {A} f (l : list A),
diff --git a/Util/MMultiset/MMultisetExtraOps.v b/Util/MMultiset/MMultisetExtraOps.v
index df83277bc5452cb24281eb631e066c11b5237166..bd5ae5abcf3ca3e46bd0e71a82b9d5cbcf7881d3 100644
--- a/Util/MMultiset/MMultisetExtraOps.v
+++ b/Util/MMultiset/MMultisetExtraOps.v
@@ -225,14 +225,18 @@ Section MMultisetExtra.
(** ** Function [map] and its properties **)
- Definition map f m := fold (fun x n acc => add (f x) n acc) m empty.
-
Section map_results.
- Variable f : elt -> elt.
+
+ Context {elt2 : Type}.
+ Context `{M2 : FMultisetsOn elt2}.
+
+ Definition map (f : elt -> elt2) m := fold (fun x n acc => add (f x) n acc) m empty.
+
+ Variable f : elt -> elt2.
Hypothesis Hf : Proper (equiv ==> equiv) f.
Global Instance map_compat : Proper (equiv ==> equiv) (map f).
- Proof using Hf M.
+ Proof using Hf M M2.
intros mâ‚ mâ‚‚ Hm. unfold map. apply (fold_compat _ _).
- repeat intro. msetdec.
- repeat intro. apply add_comm.
@@ -241,22 +245,23 @@ Section MMultisetExtra.
Qed.
Lemma map_In : forall x m, In x (map f m) <-> exists y, x == (f y) /\ In y m.
- Proof using Hf M.
+ Proof using Hf M M2.
intros x m. unfold In, map. apply fold_rect.
- + intros mâ‚ mâ‚‚ acc Heq Hequiv. rewrite Hequiv. now setoid_rewrite Heq.
- + setoid_rewrite empty_spec. split; try intros [? [_ ?]]; lia.
- + intros y m' acc Hm Hin Hrec. destruct (equiv_dec x (f y)) as [Heq | Hneq]; msetdec.
- - split.
- intros. exists y. split; trivial. msetdec.
- intros [? [? ?]]. msetdec.
- - rewrite Hrec. split; intros [z [Heq ?]]; exists z; split; msetdec.
+ * intros mâ‚ mâ‚‚ acc Heq Hequiv. rewrite Hequiv. now setoid_rewrite Heq.
+ * setoid_rewrite empty_spec. split; try intros [? [_ ?]]; lia.
+ * intros y m' acc Hm Hin Hrec. destruct (equiv_dec x (f y)) as [Heq | Hneq]. (* ; msetdec. *)
+ + split.
+ - intros. exists y. split; trivial. msetdec.
+ - intros [? [? ?]]. rewrite <- Heq, add_same.
+ destruct (equiv_dec y x0) as [Heq' | Hneq']; msetdec.
+ + msetdec. rewrite Hrec. split; intros [z [Heq ?]]; exists z; split; msetdec.
Qed.
Lemma map_empty : map f empty == empty.
Proof using M f. unfold map. now rewrite fold_empty. Qed.
Lemma map_add : forall x n m, map f (add x n m) == add (f x) n (map f m).
- Proof using Hf M.
+ Proof using Hf M M2.
intros x n m y. destruct n.
+ now do 2 rewrite add_0.
+ unfold map at 1. rewrite (fold_add_additive _).
@@ -269,50 +274,55 @@ Section MMultisetExtra.
Lemma map_spec : forall x m,
(map f m)[x] = cardinal (nfilter (fun y _ => if equiv_dec (f y) x then true else false) m).
- Proof using Hf M.
+ Proof using Hf M M2.
intros x m. pose (g := fun y (_ : nat) => if equiv_dec (f y) x then true else false). fold g.
assert (Hg : Proper (equiv ==> @Logic.eq nat ==> Logic.eq) g). { repeat intro. unfold g. msetdec. }
pattern m. apply ind; clear m.
+ intros ? ? Hm. now rewrite Hm.
- + intros * Hin Hrec. rewrite map_add, nfilter_add; trivial. unfold g at 2. msetdec. rewrite cardinal_add. lia.
+ + intros * Hin Hrec. rewrite map_add, nfilter_add; trivial. unfold g at 2.
+ destruct (equiv_dec (f x0) x) as [Heq | Hneq].
+ - rewrite Heq, cardinal_add, add_same. lia.
+ - msetdec.
+ now rewrite map_empty, nfilter_empty, cardinal_empty, empty_spec.
Qed.
Global Instance map_sub_compat : Proper (Subset ==> Subset) (map f).
- Proof using Hf M.
+ Proof using Hf M M2.
intro m. pattern m. apply ind; clear m.
+ intros ? ? Hm. now setoid_rewrite Hm.
+ intros m x n Hin Hn Hrec m' Hsub y.
assert (Hx : m[x] = 0). { unfold In in Hin. lia. }
- rewrite <- (add_remove_cancel x m' (Hsub x)). do 2 rewrite (map_add _). msetdec.
- - apply Nat.add_le_mono; trivial; [].
- repeat rewrite map_spec; trivial. apply add_subset_remove in Hsub.
- apply cardinal_sub_compat, nfilter_sub_compat; solve [lia | repeat intro; msetdec].
- - now apply Hrec, add_subset_remove.
+ rewrite <- (add_remove_cancel x m' (Hsub x)). do 2 rewrite (map_add _).
+ apply add_sub_compat.
+ - reflexivity.
+ - msetdec.
+ - apply Hrec, add_subset_remove. msetdec.
+ intros ? _. rewrite map_empty. apply subset_empty_l.
Qed.
Lemma map_singleton : forall x n, map f (singleton x n) == singleton (f x) n.
- Proof using Hf M.
+ Proof using Hf M M2.
intros x n y. destruct n.
+ repeat rewrite singleton_0. now rewrite map_empty.
- + unfold map. rewrite fold_singleton; repeat intro; msetdec.
+ + unfold map. rewrite fold_singleton; repeat intro; try lia.
+ - apply add_empty.
+ - msetdec.
Qed.
Lemma map_remove1 : forall x n m, n <= m[x] -> map f (remove x n m) == remove (f x) n (map f m).
- Proof using Hf M.
+ Proof using Hf M M2.
intros x n m Hle. rewrite <- (add_remove_cancel _ _ Hle) at 2. now rewrite (map_add _), remove_add_cancel.
Qed.
Lemma map_remove2 : forall x n m,
m[x] <= n -> map f (remove x n m) == remove (f x) m[x] (map f m).
- Proof using Hf M.
+ Proof using Hf M M2.
intros x n m Hle. rewrite <- (add_remove_id _ _ Hle) at 3.
now rewrite (map_add _), remove_add_cancel.
Qed.
Lemma fold_map_union : forall mâ‚ mâ‚‚, fold (fun x n acc => add (f x) n acc) mâ‚ mâ‚‚ == union (map f mâ‚) mâ‚‚.
- Proof using Hf M.
+ Proof using Hf M M2.
intros mâ‚ mâ‚‚. apply fold_rect with (m := mâ‚).
+ repeat intro. msetdec.
+ now rewrite map_empty, union_empty_l.
@@ -320,7 +330,7 @@ Section MMultisetExtra.
Qed.
Theorem map_union : forall mâ‚ mâ‚‚, map f (union mâ‚ mâ‚‚) == union (map f mâ‚) (map f mâ‚‚).
- Proof using Hf M.
+ Proof using Hf M M2.
intros mâ‚ mâ‚‚. unfold map at 1 2. rewrite (fold_union_additive _).
+ now apply fold_map_union.
+ repeat intro. msetdec.
@@ -329,7 +339,7 @@ Section MMultisetExtra.
Qed.
Theorem map_inter : forall mâ‚ mâ‚‚, map f (inter mâ‚ mâ‚‚) [<=] inter (map f mâ‚) (map f mâ‚‚).
- Proof using Hf M.
+ Proof using Hf M M2.
intros m1 m2 x. destruct (map f (inter m1 m2))[x] eqn:Hfx.
+ lia.
+ assert (Hin : In x (map f (inter m1 m2))) by msetdec.
@@ -339,7 +349,7 @@ Section MMultisetExtra.
Qed.
Theorem map_lub : forall mâ‚ mâ‚‚, lub (map f mâ‚) (map f mâ‚‚) [<=] map f (lub mâ‚ mâ‚‚).
- Proof using Hf M.
+ Proof using Hf M M2.
intros m1 m2 x. destruct (lub (map f m1) (map f m2))[x] eqn:Hfx.
+ lia.
+ assert (Hin : In x (lub (map f m1) (map f m2))).
@@ -353,14 +363,14 @@ Section MMultisetExtra.
Lemma map_from_elements :
forall l, map f (from_elements l) == from_elements (List.map (fun xn => (f (fst xn), snd xn)) l).
- Proof using Hf M.
+ Proof using Hf M M2.
induction l as [| [x n] l].
- apply map_empty.
- simpl from_elements. rewrite map_add. f_equiv. apply IHl.
Qed.
-
+
Lemma map_support : forall m, inclA equiv (support (map f m)) (List.map f (support m)).
- Proof using Hf M.
+ Proof using Hf M M2.
apply ind.
* repeat intro. msetdec.
* intros m x n Hin Hn Hrec. rewrite map_add; trivial. repeat rewrite support_add; try lia.
@@ -371,17 +381,17 @@ Section MMultisetExtra.
- right. now apply Hrec.
* now rewrite map_empty, support_empty.
Qed.
-
+
Lemma map_cardinal : forall m, cardinal (map f m) = cardinal m.
- Proof using Hf M.
+ Proof using Hf M M2.
apply ind.
+ repeat intro. msetdec.
+ intros m x n Hin Hn Hrec. rewrite (map_add _). do 2 rewrite cardinal_add. now rewrite Hrec.
- + now rewrite map_empty.
+ + now rewrite map_empty, 2 cardinal_empty.
Qed.
-
+
Lemma map_size : forall m, size (map f m) <= size m.
- Proof using Hf M.
+ Proof using Hf M M2.
apply ind.
+ repeat intro. msetdec.
+ intros m x n Hm Hn Hrec. rewrite map_add, size_add, size_add; trivial.
@@ -390,69 +400,71 @@ Section MMultisetExtra.
- contradiction Hinf. rewrite map_In. now exists x.
- lia.
- lia.
- + now rewrite map_empty.
+ + now rewrite map_empty, 2 size_empty.
Qed.
-
+
Section map_injective_results.
Hypothesis Hf2 : injective equiv equiv f.
-
+
Lemma map_injective_spec : forall x m, (map f m)[f x] = m[x].
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
intros x m. unfold map. apply fold_rect.
+ repeat intro. msetdec.
+ now do 2 rewrite empty_spec.
+ intros y m' acc Hin Hm Heq. destruct (equiv_dec x y) as [Hxy | Hxy].
- - msetdec.
+ - rewrite <- Hxy, 2 add_same. lia.
- repeat rewrite add_other; trivial. intro Habs. apply Hxy. now apply Hf2.
Qed.
-
+
Corollary map_injective_In : forall x m, In (f x) (map f m) <-> In x m.
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
intros x m. rewrite map_In; trivial. split; intro Hin.
+ destruct Hin as [y [Heq Hin]]. apply Hf2 in Heq. now rewrite Heq.
+ now exists x.
Qed.
-
+
Lemma map_injective_remove : forall x n m, map f (remove x n m) == remove (f x) n (map f m).
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
intros x n m. destruct (Compare_dec.le_dec n m[x]) as [Hle | Hlt].
* now apply map_remove1.
- * intro y. msetdec.
- + repeat rewrite map_injective_spec; trivial. msetdec.
+ * intro y. destruct (equiv_dec y (f x)) as [Heq | Hneq].
+ + now rewrite Heq, map_injective_spec, 2 remove_same, map_injective_spec.
+ destruct (In_dec y (map f m)) as [Hin | Hin].
- rewrite (map_In _) in Hin. destruct Hin as [z [Heq Hz]]. msetdec.
repeat rewrite map_injective_spec; trivial. msetdec.
- - rewrite not_In in Hin. rewrite Hin, <- not_In, (map_In _).
+ - rewrite not_In in Hin. msetdec. rewrite <- not_In, (map_In _).
intros [z [Heq Hz]]. msetdec. rewrite map_injective_spec in Hin; trivial. lia.
Qed.
-
+
Theorem map_injective_inter : forall mâ‚ mâ‚‚, map f (inter mâ‚ mâ‚‚) == inter (map f mâ‚) (map f mâ‚‚).
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
intros mâ‚ mâ‚‚ x. destruct ((inter (map f mâ‚) (map f mâ‚‚))[x]) eqn:Hn.
+ rewrite <- not_In in Hn |- *. intro Habs. apply Hn.
- rewrite (map_In _) in Habs. destruct Habs as [y [Heq Hy]]. msetdec.
- unfold gt in *. rewrite Nat.min_glb_lt_iff in *. now repeat rewrite map_injective_spec.
+ rewrite (map_In _) in Habs. destruct Habs as [y [Heq Hy]].
+ unfold In, gt in *. rewrite 2 inter_spec in *.
+ now rewrite Heq, 2 map_injective_spec.
+ rewrite inter_spec in Hn.
assert (Hx : In x (map f mâ‚)).
{ msetdec. }
rewrite map_In in *; trivial. destruct Hx as [y [Heq Hy]]. msetdec.
do 2 (rewrite map_injective_spec in *; trivial). msetdec.
Qed.
-
+
Theorem map_injective_diff : forall mâ‚ mâ‚‚, map f (diff mâ‚ mâ‚‚) == diff (map f mâ‚) (map f mâ‚‚).
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
intros mâ‚ mâ‚‚ x. destruct ((diff (map f mâ‚) (map f mâ‚‚))[x]) eqn:Hn.
+ rewrite <- not_In in Hn |- *. intro Habs. apply Hn.
rewrite (map_In _) in Habs. destruct Habs as [y [Heq Hy]]. msetdec.
- now repeat rewrite map_injective_spec.
- + assert (Hx : In x (map f mâ‚)) by msetdec.
+ now rewrite diff_spec, 2 map_injective_spec.
+ + rewrite diff_spec in *.
+ assert (Hx : In x (map f mâ‚)) by msetdec.
rewrite map_In in *; trivial. destruct Hx as [y [Heq _]]. msetdec.
do 2 (rewrite map_injective_spec in *; trivial). msetdec.
Qed.
-
+
Lemma map_injective_lub_wlog : forall x mâ‚ mâ‚‚, (map f mâ‚‚)[x] <= (map f mâ‚)[x] ->
(map f (lub mâ‚ mâ‚‚))[x] = (map f mâ‚)[x].
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
intros x mâ‚ mâ‚‚ Hle. destruct (map f mâ‚)[x] eqn:Heq1.
- apply Nat.le_0_r in Hle. destruct (map f (lub mâ‚ mâ‚‚))[x] eqn:Heq2; trivial.
assert (Hin : In x (map f (lub mâ‚ mâ‚‚))). { unfold In. lia. }
@@ -462,38 +474,38 @@ Section MMultisetExtra.
rewrite map_In in Hin. destruct Hin as [y [Heq Hin]]. rewrite Heq, map_injective_spec in *.
rewrite lub_spec. rewrite Nat.max_l; lia.
Qed.
-
+
Theorem map_injective_lub : forall mâ‚ mâ‚‚, map f (lub mâ‚ mâ‚‚) == lub (map f mâ‚) (map f mâ‚‚).
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
intros mâ‚ mâ‚‚ x. rewrite lub_spec. apply Nat.max_case_strong; intro Hle.
- now apply map_injective_lub_wlog.
- rewrite lub_comm. now apply map_injective_lub_wlog.
Qed.
-
+
Lemma map_injective : injective equiv equiv (map f).
- Proof using Hf Hf2 M. intros ? ? Hm x. specialize (Hm (f x)). repeat (rewrite map_injective_spec in Hm; trivial). Qed.
-
+ Proof using Hf Hf2 M M2. intros ? ? Hm x. specialize (Hm (f x)). repeat (rewrite map_injective_spec in Hm; trivial). Qed.
+
Lemma map_injective_subset : forall mâ‚ mâ‚‚, map f mâ‚ [<=] map f mâ‚‚ <-> mâ‚ [<=] mâ‚‚.
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
intros mâ‚ mâ‚‚. split; intro Hincl.
- intro x. setoid_rewrite <- map_injective_spec. apply Hincl.
- now apply map_sub_compat.
Qed.
-
+
Lemma map_injective_elements : forall m,
PermutationA eq_pair (elements (map f m)) (List.map (fun xn => (f (fst xn), snd xn)) (elements m)).
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
assert (Proper (eq_pair ==> eq_pair) (fun xn => (f (fst xn), snd xn))). { intros ? ? Heq. now rewrite Heq. }
apply ind.
+ repeat intro. msetdec.
+ intros m x n Hin Hn Hrec. rewrite (map_add _). repeat rewrite elements_add_out; trivial.
- simpl. now constructor.
- rewrite (map_In _). intros [y [Heq Hy]]. apply Hf2 in Heq. apply Hin. now rewrite Heq.
- + now rewrite map_empty, elements_empty.
+ + now rewrite map_empty, 2 elements_empty.
Qed.
-
+
Lemma map_injective_support : forall m, PermutationA equiv (support (map f m)) (List.map f (support m)).
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
apply ind.
* repeat intro. msetdec.
* intros m x n Hin Hrec. rewrite map_add; trivial. repeat rewrite support_add; try lia.
@@ -503,11 +515,11 @@ Section MMultisetExtra.
- rewrite support_spec in Habs. unfold In in *. contradiction.
- simpl. destruct (In_dec x m); try contradiction. rewrite <- map_injective_In in Hin; trivial.
destruct (In_dec (f x) (map f m)); try contradiction. now apply PermutationA_cons.
- * now rewrite map_empty, support_empty.
+ * now rewrite map_empty, 2 support_empty.
Qed.
-
+
Lemma map_injective_size : forall m, size (map f m) = size m.
- Proof using Hf Hf2 M.
+ Proof using Hf Hf2 M M2.
apply ind.
+ repeat intro. msetdec.
+ intros m x n Hin Hn Hrec. rewrite (map_add _). rewrite size_add, Hrec; trivial.
@@ -515,133 +527,129 @@ Section MMultisetExtra.
- rewrite map_In in Hinf; trivial. destruct Hinf as [y [Heq Hiny]].
apply Hf2 in Heq. rewrite Heq in Hin. contradiction.
- rewrite size_add; trivial. destruct (In_dec x m); reflexivity || contradiction.
- + now rewrite map_empty.
+ + now rewrite map_empty, 2 size_empty.
Qed.
-
+
End map_injective_results.
End map_results.
-
- Lemma map_extensionality_compat : forall f g, Proper (equiv ==> equiv) f ->
- (forall x, equiv (g x) (f x)) -> forall m, map g m == map f m.
- Proof using M.
- intros f g Hf Hext m x.
- assert (Hg : Proper (equiv ==> equiv) g). { intros ? ? Heq. do 2 rewrite Hext. now apply Hf. }
- repeat rewrite map_spec; trivial. f_equiv. apply nfilter_extensionality_compat.
- - intros y z Heq _ _ _. destruct (equiv_dec (g y) x), (equiv_dec (g z) x); trivial; rewrite Heq in *; contradiction.
- - intros y _. destruct (equiv_dec (f y) x), (equiv_dec (g y) x); trivial; rewrite Hext in *; contradiction.
- Qed.
-
- Lemma map_extensionality_compat_strong : forall f g, Proper (equiv ==> equiv) f -> Proper (equiv ==> equiv) g ->
- forall m, (forall x, In x m -> equiv (g x) (f x)) -> map g m == map f m.
- Proof using M.
- intros f g Hf Hg m Hext x.
- repeat rewrite map_spec; trivial. f_equiv. apply nfilter_extensionality_compat_strong.
- - intros y z Heq _ _ _. destruct (equiv_dec (g y) x), (equiv_dec (g z) x); trivial; rewrite Heq in *; contradiction.
- - intros y z Heq _ _ _. destruct (equiv_dec (f y) x), (equiv_dec (f z) x); trivial; rewrite Heq in *; contradiction.
- - intros y Hin. destruct (equiv_dec (f y) x), (equiv_dec (g y) x); rewrite Hext in *; trivial; contradiction.
- Qed.
-
- Lemma map_merge : forall f g, Proper (equiv ==> equiv) f -> Proper (equiv ==> equiv) g ->
- forall m, map f (map g m) == map (fun x => f (g x)) m.
- Proof using M.
- intros f g Hf Hg.
- apply ind.
- + repeat intro. msetdec.
- + intros m x n Hin Hn Hrec. repeat rewrite map_add; refine _. now rewrite Hrec.
- + now repeat rewrite map_empty.
- Qed.
-
- Lemma map_id : forall m, map id m == m.
- Proof using M.
- intro m. intro x. change x with (id x) at 1.
- rewrite map_injective_spec; autoclass; []. now repeat intro.
- Qed.
-
- Theorem map_injective_fold : forall A eqA, Equivalence eqA ->
- forall f g, Proper (equiv ==> Logic.eq ==> eqA ==> eqA) f -> transpose2 eqA f ->
- Proper (equiv ==> equiv) g -> injective equiv equiv g ->
- forall m (i : A), eqA (fold f (map g m) i) (fold (fun x => f (g x)) m i).
- Proof using M.
- intros A eqA HeqA f g Hf Hf2 Hg Hg2 m.
- assert (Hfg2 : transpose2 eqA (fun x => f (g x))). { repeat intro. apply Hf2. }
- pattern m. apply ind.
- + intros mâ‚ mâ‚‚ Hm. split; intros Heq i; rewrite fold_compat; trivial;
- solve [rewrite Heq; now apply fold_compat; refine _ | now rewrite Hm | reflexivity].
- + intros m' x n Hin Hn Hrec i. rewrite fold_compat; try apply map_add; reflexivity || trivial.
- repeat rewrite fold_add; trivial; refine _.
- - now rewrite Hrec.
- - rewrite (map_In _). intros [y [Heq Hy]]. apply Hin. apply Hg2 in Heq. now rewrite Heq.
- + intro. rewrite fold_compat; apply map_empty || reflexivity || trivial. now do 2 rewrite fold_empty.
- Qed.
-
- Lemma map_injective_nfilter : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
- forall m, nfilter f (map g m) == map g (nfilter (fun x => f (g x)) m).
- Proof using M.
- intros f g Hf Hg Hg2. apply ind.
- + repeat intro. msetdec.
- + intros m x n Hin Hn Hrec. rewrite (map_add _). repeat rewrite nfilter_add; trivial.
- - destruct (f (g x) n).
- now rewrite map_add, Hrec.
- apply Hrec.
- - refine _.
- - rewrite (map_In _). intros [y [Heq Hy]]. apply Hg2 in Heq. apply Hin. now rewrite Heq.
- + rewrite map_empty. now rewrite nfilter_empty, nfilter_empty, map_empty; autoclass.
- Qed.
-
- Lemma map_injective_npartition_fst : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
- forall m, fst (npartition f (map g m)) == map g (fst (npartition (fun x => f (g x)) m)).
- Proof using M. intros. repeat rewrite npartition_spec_fst; refine _. now apply map_injective_nfilter. Qed.
-
- Lemma map_injective_npartition_snd : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
- forall m, snd (npartition f (map g m)) == map g (snd (npartition (fun x => f (g x)) m)).
- Proof using M.
- intros. repeat rewrite npartition_spec_snd; refine _. apply map_injective_nfilter; trivial. repeat intro. msetdec.
- Qed.
-
- Lemma map_injective_for_all : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
- forall m, for_all f (map g m) = for_all (fun x => f (g x)) m.
- Proof using M.
- intros f g Hf Hg Hg2. apply ind.
- + repeat intro. msetdec.
- + intros m x n Hin Hn Hrec. rewrite (map_add _). repeat rewrite for_all_add; trivial.
- - now rewrite Hrec.
- - refine _.
- - now rewrite map_injective_In.
- + rewrite map_empty. repeat rewrite for_all_empty; autoclass.
- Qed.
-
- Lemma map_injective_exists : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
- forall m, exists_ f (map g m) = exists_ (fun x => f (g x)) m.
- Proof using M.
- intros f g Hf Hg Hg2. apply ind.
- + repeat intro. msetdec.
- + intros m x n Hin Hn Hrec. rewrite (map_add _). repeat rewrite exists_add; trivial.
- - now rewrite Hrec.
- - refine _.
- - rewrite (map_In _). intros [y [Heq Hy]]. apply Hg2 in Heq. apply Hin. now rewrite Heq.
- + rewrite map_empty. repeat rewrite exists_empty; autoclass.
- Qed.
-
- Theorem map_filter : forall f g, Proper (equiv ==> Logic.eq) f -> Proper (equiv ==> equiv) g ->
- forall m, filter f (map g m) == map g (filter (fun x => f (g x)) m).
- Proof using M.
- intros f g Hf Hg. apply ind.
- + intros m1 m2 Hm. now rewrite Hm.
- + intros m x n Hin Hn Hrec. rewrite map_add, 2 filter_add; autoclass; [].
- destruct (f (g x)).
- - rewrite map_add; trivial; []. f_equiv. apply Hrec.
- - apply Hrec.
- + rewrite map_empty, 2 filter_empty, map_empty; autoclass; reflexivity.
- Qed.
-
- Lemma map_partition_fst : forall f g, Proper (equiv ==> Logic.eq) f -> Proper (equiv ==> equiv) g ->
- forall m, fst (partition f (map g m)) == map g (fst (partition (fun x => f (g x)) m)).
- Proof using M. intros. rewrite 2 partition_spec_fst; try apply map_filter; autoclass. Qed.
-
- Lemma map_partition_snd : forall f g, Proper (equiv ==> Logic.eq) f -> Proper (equiv ==> equiv) g ->
- forall m, snd (partition f (map g m)) == map g (snd (partition (fun x => f (g x)) m)).
- Proof using M. intros. rewrite 2 partition_spec_snd; try apply map_filter; autoclass. Qed.
-
+
+ Section map_extensionality_results.
+ Context {elt2 : Type}.
+ Context `{M2 : FMultisetsOn elt2}.
+
+ Lemma map_extensionality_compat : forall f g : elt -> elt2, Proper (equiv ==> equiv) f ->
+ (forall x, equiv (g x) (f x)) -> forall m, map g m == map f m.
+ Proof using M M2.
+ intros f g Hf Hext m x.
+ assert (Hg : Proper (equiv ==> equiv) g). { intros ? ? Heq. do 2 rewrite Hext. now apply Hf. }
+ repeat rewrite map_spec; trivial. f_equiv. apply nfilter_extensionality_compat.
+ - intros y z Heq _ _ _. destruct (equiv_dec (g y) x), (equiv_dec (g z) x); trivial; rewrite Heq in *; contradiction.
+ - intros y _. destruct (equiv_dec (f y) x), (equiv_dec (g y) x); trivial; rewrite Hext in *; contradiction.
+ Qed.
+
+ Lemma map_extensionality_compat_strong : forall f g : elt -> elt2,
+ Proper (equiv ==> equiv) f -> Proper (equiv ==> equiv) g ->
+ forall m, (forall x, In x m -> equiv (g x) (f x)) -> map g m == map f m.
+ Proof using M M2.
+ intros f g Hf Hg m Hext x.
+ repeat rewrite map_spec; trivial. f_equiv. apply nfilter_extensionality_compat_strong.
+ - intros y z Heq _ _ _. destruct (equiv_dec (g y) x), (equiv_dec (g z) x); trivial; rewrite Heq in *; contradiction.
+ - intros y z Heq _ _ _. destruct (equiv_dec (f y) x), (equiv_dec (f z) x); trivial; rewrite Heq in *; contradiction.
+ - intros y Hin. destruct (equiv_dec (f y) x), (equiv_dec (g y) x); rewrite Hext in *; trivial; contradiction.
+ Qed.
+
+ Lemma map_id : forall m, map id m == m.
+ Proof using M.
+ intro m. intro x. change x with (id x) at 1.
+ rewrite map_injective_spec; autoclass; []. now repeat intro.
+ Qed.
+
+ Theorem map_injective_fold : forall A eqA, Equivalence eqA ->
+ forall f g, Proper (equiv ==> Logic.eq ==> eqA ==> eqA) f -> transpose2 eqA f ->
+ Proper (equiv ==> equiv) g -> injective equiv equiv g ->
+ forall m (i : A), eqA (fold f (map g m) i) (fold (fun x => f (g x)) m i).
+ Proof using M M2.
+ intros A eqA HeqA f g Hf Hf2 Hg Hg2 m.
+ assert (Hfg2 : transpose2 eqA (fun x => f (g x))). { repeat intro. apply Hf2. }
+ pattern m. apply ind.
+ + intros mâ‚ mâ‚‚ Hm. split; intros Heq i; rewrite fold_compat; trivial;
+ solve [rewrite Heq; now apply fold_compat; refine _ | now rewrite Hm | reflexivity].
+ + intros m' x n Hin Hn Hrec i. rewrite fold_compat; try apply map_add; reflexivity || trivial.
+ repeat rewrite fold_add; trivial; refine _.
+ - now rewrite Hrec.
+ - rewrite (map_In _). intros [y [Heq Hy]]. apply Hin. apply Hg2 in Heq. now rewrite Heq.
+ + intro. rewrite fold_compat; apply map_empty || reflexivity || trivial. now do 2 rewrite fold_empty.
+ Qed.
+
+ Lemma map_injective_nfilter : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
+ forall m, nfilter f (map g m) == map g (nfilter (fun x => f (g x)) m).
+ Proof using M M2.
+ intros f g Hf Hg Hg2. apply ind.
+ + repeat intro. msetdec.
+ + intros m x n Hin Hn Hrec. rewrite (map_add _). repeat rewrite nfilter_add; trivial.
+ - destruct (f (g x) n).
+ -- now rewrite map_add, Hrec.
+ -- apply Hrec.
+ - refine _.
+ - rewrite (map_In _). intros [y [Heq Hy]]. apply Hg2 in Heq. apply Hin. now rewrite Heq.
+ + rewrite map_empty. now rewrite nfilter_empty, nfilter_empty, map_empty; autoclass.
+ Qed.
+
+ Lemma map_injective_npartition_fst : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
+ forall m, fst (npartition f (map g m)) == map g (fst (npartition (fun x => f (g x)) m)).
+ Proof using M M2. intros. repeat rewrite npartition_spec_fst; refine _. now apply map_injective_nfilter. Qed.
+
+ Lemma map_injective_npartition_snd : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
+ forall m, snd (npartition f (map g m)) == map g (snd (npartition (fun x => f (g x)) m)).
+ Proof using M M2.
+ intros. repeat rewrite npartition_spec_snd; refine _. apply map_injective_nfilter; trivial. repeat intro. msetdec.
+ Qed.
+
+ Lemma map_injective_for_all : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
+ forall m, for_all f (map g m) = for_all (fun x => f (g x)) m.
+ Proof using M M2.
+ intros f g Hf Hg Hg2. apply ind.
+ + repeat intro. msetdec.
+ + intros m x n Hin Hn Hrec. rewrite (map_add _). repeat rewrite for_all_add; trivial.
+ - now rewrite Hrec.
+ - refine _.
+ - now rewrite map_injective_In.
+ + rewrite map_empty. repeat rewrite for_all_empty; autoclass.
+ Qed.
+
+ Lemma map_injective_exists : forall f g, compatb f -> Proper (equiv ==> equiv) g -> injective equiv equiv g ->
+ forall m, exists_ f (map g m) = exists_ (fun x => f (g x)) m.
+ Proof using M M2.
+ intros f g Hf Hg Hg2. apply ind.
+ + repeat intro. msetdec.
+ + intros m x n Hin Hn Hrec. rewrite (map_add _). repeat rewrite exists_add; trivial.
+ - now rewrite Hrec.
+ - refine _.
+ - rewrite (map_In _). intros [y [Heq Hy]]. apply Hg2 in Heq. apply Hin. now rewrite Heq.
+ + rewrite map_empty. repeat rewrite exists_empty; autoclass.
+ Qed.
+
+ Theorem map_filter : forall f g, Proper (equiv ==> Logic.eq) f -> Proper (equiv ==> equiv) g ->
+ forall m, filter f (map g m) == map g (filter (fun x => f (g x)) m).
+ Proof using M M2.
+ intros f g Hf Hg. apply ind.
+ + intros m1 m2 Hm. now rewrite Hm.
+ + intros m x n Hin Hn Hrec. rewrite map_add, 2 filter_add; autoclass; [].
+ destruct (f (g x)).
+ - rewrite map_add; trivial; []. f_equiv. apply Hrec.
+ - apply Hrec.
+ + rewrite map_empty, 2 filter_empty, map_empty; autoclass; reflexivity.
+ Qed.
+
+ Lemma map_partition_fst : forall f g, Proper (equiv ==> Logic.eq) f -> Proper (equiv ==> equiv) g ->
+ forall m, fst (partition f (map g m)) == map g (fst (partition (fun x => f (g x)) m)).
+ Proof using M M2. intros. rewrite 2 partition_spec_fst; try apply map_filter; autoclass. Qed.
+
+ Lemma map_partition_snd : forall f g, Proper (equiv ==> Logic.eq) f -> Proper (equiv ==> equiv) g ->
+ forall m, snd (partition f (map g m)) == map g (snd (partition (fun x => f (g x)) m)).
+ Proof using M M2. intros. rewrite 2 partition_spec_snd; try apply map_filter; autoclass. Qed.
+End map_extensionality_results.
+
(** ** Function [max] and its properties **)
(** *** Function [max_mult] computing the maximal multiplicity **)
@@ -1448,3 +1456,20 @@ Section MMultisetExtra.
Qed.
End MMultisetExtra.
+
+Section map_merge.
+ Context {elt elt2 elt3 : Type}.
+ Context `{M : FMultisetsOn elt}.
+ Context `{M2 : FMultisetsOn elt2}.
+ Context `{M3 : FMultisetsOn elt3}.
+
+ Lemma map_merge : forall f : elt2 -> elt3, forall g : elt -> elt2, Proper (equiv ==> equiv) f -> Proper (equiv ==> equiv) g ->
+ forall m, map f (map g m) == map (fun x => f (g x)) m.
+ Proof using M M2 M3.
+ intros f g Hf Hg.
+ apply ind.
+ + repeat intro. now rewrite H2.
+ + intros m x n Hin Hn Hrec. repeat rewrite map_add; refine _. now rewrite Hrec.
+ + now repeat rewrite map_empty.
+ Qed.
+End map_merge.
diff --git a/Util/MMultiset/MMultisetFacts.v b/Util/MMultiset/MMultisetFacts.v
index 1ebe82158e024d826f3ff5d01e70f3004c7d281b..9e99c3fb0a698b2b1c8766ca69f36233b8574581 100644
--- a/Util/MMultiset/MMultisetFacts.v
+++ b/Util/MMultiset/MMultisetFacts.v
@@ -74,6 +74,7 @@ Section MMultisetFacts.
| H : id (?x =/= ?y) |- _ => change (x =/= y) in H
end.
+ (* FIXME: Does it work with several [FMultisetsOn] instances? *)
Ltac msetdec_step :=
match goal with
(* Simplifying equalities *)
@@ -2177,12 +2178,55 @@ Section MMultisetFacts.
Lemma cardinal_fold_elements : forall m, cardinal m = List.fold_left (fun acc xn => snd xn + acc) (elements m) 0.
Proof using FMultisetsSpec. intro. now rewrite cardinal_spec, fold_spec. Qed.
+ Lemma cardinal_fold_support : forall m,
+ cardinal m = List.fold_left (fun acc x => m[x] + acc) (support m) 0.
+ Proof using FMultisetsSpec.
+ intro. rewrite cardinal_spec, fold_spec.
+ assert (Hf2 : forall m, Proper (eq ==> equiv ==> eq) (fun acc x => m[x] + acc)).
+ { intros ? ? ? ? ? ? Heq. rewrite Heq. lia. }
+ generalize 0. pattern m. apply ind.
+ + intros m1 m2 Hm.
+ assert (Hf12 : (eq ==> equiv ==> eq)%signature (fun acc x => m1[x] + acc) (fun acc x => m2[x] + acc)).
+ { intros ? ? ? ? ? Heq. rewrite Hm, Heq. lia. }
+ split; intros Heq acc; specialize (Heq acc).
+ - assert (Helem := elements_compat Hm).
+ apply fold_left_cardinal in Helem; try lia; [].
+ specialize (Helem acc acc (eq_refl acc)). rewrite <- Helem, Heq.
+ rewrite (fold_left_extensional Hf12 (reflexivity (support m1)) _ _ (eq_refl acc)).
+ assert (Hsupp := support_compat Hm).
+ apply (fold_left_symmetry_PermutationA _ _ (Hf2 m2)); trivial; lia.
+ - assert (Helem := elements_compat Hm).
+ apply fold_left_cardinal in Helem; try lia; [].
+ specialize (Helem acc acc (eq_refl acc)). rewrite Helem, Heq.
+ rewrite (fold_left_extensional Hf12 (reflexivity (support m1)) _ _ (eq_refl acc)).
+ assert (Hsupp := support_compat Hm). symmetry in Hsupp.
+ apply (fold_left_symmetry_PermutationA _ _ (Hf2 m2)); trivial; lia.
+ + clear m. intros m x n Hout Hn Hrec acc.
+ rewrite (fold_left_cardinal (elements_add_out Hn Hout) (eq_refl acc)).
+ cbn. rewrite Hrec. clear Hrec.
+ assert (Htranspose : forall x1 x2 k,
+ (fun acc e => (add x n m)[e] + acc) ((fun acc e => (add x n m)[e] + acc) k x1) x2
+ = (fun acc e => (add x n m)[e] + acc) ((fun acc e => (add x n m)[e] + acc) k x2) x1)
+ by msetdec.
+ rewrite (fold_left_symmetry_PermutationA _ _ (Hf2 (add x n m)) Htranspose (support_add _ _ Hn) _ _ (eq_refl acc)).
+ destruct_match; try contradiction; []. cbn.
+ assert (Hx : m[x] = 0). { unfold In in *. lia. }
+ rewrite add_same, Hx. cbn.
+ clear Htranspose Heqs n0.
+ assert (~ InA equiv x (support m)). { now rewrite support_spec. }
+ generalize (n + acc). clear acc.
+ induction (support m) as [| e supp]; try reflexivity; [].
+ cbn. intro acc. rewrite InA_cons in *. rewrite IHsupp; intuition; [].
+ f_equal. now rewrite add_other.
+ + now rewrite elements_empty, support_empty.
+ Qed.
+
Lemma cardinal_from_elements : forall l,
cardinal (from_elements l) = List.fold_left (fun acc xn => snd xn + acc) l 0.
Proof using FMultisetsSpec.
intro l. rewrite <- Nat.add_0_l at 1. generalize 0. induction l as [| [x n] l]; intro p; simpl.
- now rewrite cardinal_empty.
- - rewrite cardinal_add, Nat.add_assoc. rewrite (Nat.add_comm p n). apply IHl.
+ - rewrite cardinal_add, Nat.add_assoc. rewrite (Nat.add_comm p n). apply IHl.
Qed.
Lemma cardinal_total_sub_eq : forall m1 m2, m1 [<=] m2 -> cardinal m1 = cardinal m2 -> m1 == m2.
@@ -2661,6 +2705,17 @@ Section MMultisetFacts.
Lemma size_filter : forall m, size (filter f m) <= size m.
Proof using FMultisetsSpec Hf. intro. apply size_sub_compat, filter_subset. Qed.
+
+ Lemma cardinal_filter_elements : forall m,
+ cardinal (filter f m) = fold_left (fun acc xn => snd xn + acc) (List.filter (fun xn => f (fst xn)) (elements m)) 0.
+ Proof using FMultisetsSpec Hf.
+ intro m. rewrite cardinal_spec, fold_spec.
+ assert (Proper (PermutationA eq_pair ==> eq ==> eq) (fold_left (fun acc xn => snd xn + acc))).
+ { apply fold_left_symmetry_PermutationA; autoclass; [|].
+ + intros ? ? ? [] [] []; hnf in *; cbn in *. now subst.
+ + intros [] [] ?. cbn. lia. }
+ now rewrite elements_filter.
+ Qed.
End Filter_results.
Lemma filter_merge : forall f g, Proper (equiv ==> Logic.eq) f -> Proper (equiv ==> Logic.eq) g ->
diff --git a/Util/Preliminary.v b/Util/Preliminary.v
index e30d5a6d3f680983c398b0b0e270db55159be9c4..91855d36490ac9edf2ffe86e754180f3f886ff66 100644
--- a/Util/Preliminary.v
+++ b/Util/Preliminary.v
@@ -27,7 +27,7 @@ Ltac autoclass := eauto with typeclass_instances.
Ltac inv H := inversion H; subst; clear H.
Hint Extern 1 (equiv ?x ?x) => reflexivity : core.
Hint Extern 2 (equiv ?y ?x) => now symmetry : core.
-
+Hint Unfold complement : core.
(** ** Tactics **)
@@ -46,9 +46,12 @@ Ltac destr_match_eq name A :=
Ltac destruct_match_eq name := match goal with | |- ?A => destr_match_eq name A end.
Ltac destr_match A :=
- match A with | context[match ?x with | _ => _ end] =>
+ match A with context[match ?x with | _ => _ end] =>
destr_match x (* recursive call *)
- || destruct x (* if innermost match, destruct it *)
+ || match type of x with (* if innermost match, destruct it *)
+ | sumbool _ _ => let H := fresh in destruct x as [H | H]
+ | _ => let H := fresh in destruct x eqn:H
+ end
end.
Ltac destruct_match := match goal with | |- ?A => destr_match A end.
diff --git a/Util/SetoidDefs.v b/Util/SetoidDefs.v
index 2a6d5ab9c50be665e71ac881e3906d7b6dafd9f6..2a3bcc20e452198b7dfae48b305511c7b83adad1 100644
--- a/Util/SetoidDefs.v
+++ b/Util/SetoidDefs.v
@@ -54,6 +54,8 @@ Lemma equiv_dec_other {T U : Type} {S : Setoid T} {E : EqDec S}:
forall (e e': T) (A B : U), e=/= e' -> (if equiv_dec e e' then A else B) = B.
Proof using . intros. destruct_match; intuition auto with *. Qed.
+Definition equiv_decb_refl [T] [S : Setoid T] (E : EqDec S) : forall x : T, x ==b x = true :=
+ fun x => equiv_dec_refl x true false.
(** ** Setoid Definitions **)
@@ -189,17 +191,20 @@ Proof.
- abstract (intros [? ?]; contradiction).
Defined.
-#[export]Instance fst_compat (A B : Type) (SA : Setoid A) (SB : Setoid B) :
- Proper (@equiv (A*B) (prod_Setoid SA SB) ==> @equiv A SA) fst.
-Proof using . intros ?? [H _]. exact H. Qed.
+(* Local Instance fst_relprod_compat {A B} : forall R S, Proper (R * S ==> R) (@fst A B) := fst_compat. *)
+(* Local Instance snd_relprod_compat {A B} : forall R S, Proper (R * S ==> S) (@snd A B) := snd_compat. *)
-#[export]Instance snd_compat (A B : Type) (SA : Setoid A) (SB : Setoid B) :
- Proper (@equiv (A*B) (prod_Setoid SA SB) ==> @equiv B SB) snd.
-Proof using . intros ?? [_ H]. exact H. Qed.
+#[export] Instance fst_compat_pactole {A B : Type} {SA : Setoid A} {SB : Setoid B} :
+ Proper (@equiv _ (prod_Setoid SA SB) ==> equiv) fst.
+Proof. now intros [] [] []. Qed.
-#[export]Instance pair_compat (A B : Type) (SA : Setoid A) (SB : Setoid B) :
- Proper (@equiv A SA ==> @equiv B SB ==> @equiv (A*B) (prod_Setoid SA SB)) pair.
-Proof using . intros ?? Hf ?? Hs. split; cbn. exact Hf. exact Hs. Qed.
+#[export] Instance snd_compat_pactole {A B : Type} {SA : Setoid A} {SB : Setoid B} :
+ Proper (@equiv _ (prod_Setoid SA SB) ==> equiv) snd.
+Proof. now intros [] [] []. Qed.
+
+#[export] Instance pair_compat_pactole {A B : Type} {SA : Setoid A} {SB : Setoid B} :
+ Proper (equiv ==> equiv ==> @equiv _ (prod_Setoid SA SB)) pair.
+Proof. repeat intro. now split. Qed.
Lemma prod_Setoid_eq : ∀ {A B : Type} {SA : Setoid A} {SB : Setoid B}
(p1 p2 : A * B), (∀ a1 a2 : A, @equiv _ SA a1 a2 <-> a1 = a2)
@@ -300,3 +305,51 @@ Definition precompose_EqDec {T U} (f : T -> U) `{EqDec U}
Definition precompose_compat {T U} (f : T -> U) `{Setoid U} :
Proper (@equiv T (precompose_Setoid f) ==> equiv) f.
Proof using . intros x y Heq. apply Heq. Qed.
+
+(** Setoids for lists *)
+Definition eqlistA_Setoid {T} (S : Setoid T) : Setoid (list T) := {|
+ equiv := SetoidList.eqlistA equiv;
+ setoid_equiv := SetoidList.eqlistA_equiv setoid_equiv |}.
+
+Fixpoint eqlistA_dec {T} {eqT} {E : Equivalence eqT} (dec : forall x y : T, {eqT x y} + {~eqT x y}) l1 l2
+ : {SetoidList.eqlistA eqT l1 l2} + {~ SetoidList.eqlistA eqT l1 l2}.
+Proof.
+refine (
+ match l1, l2 with
+ | nil, nil => left (reflexivity nil)
+ | nil, cons e2 l2 => right _
+ | cons _ _, nil => right _
+ | cons e1 l1, cons e2 l2 => _
+ end).
++ abstract (intro Habs; inv Habs).
++ abstract (intro Habs; inv Habs).
++ destruct (dec e1 e2); [destruct (eqlistA_dec _ _ _ dec l1 l2) |].
+ - abstract (left; now constructor).
+ - abstract (right; intro Habs; now inv Habs).
+ - abstract (right; intro Habs; now inv Habs).
+Defined.
+
+Definition eqlistA_EqDec {T} {S : Setoid T} (E : EqDec S) : EqDec (eqlistA_Setoid S) :=
+ eqlistA_dec equiv_dec.
+
+(* Definition PermutationA_Setoid {T} {S : Setoid T} : Setoid (list T) := {|
+ equiv := PermutationA equiv;
+ setoid_equiv := PermutationA_Equivalence setoid_equiv |}. *)
+
+
+Lemma equiv_decb_spec: forall A (SA:Setoid A) (Aeq:EqDec SA) (a b:A), (a ==b b = true) <-> a == b.
+Proof.
+ unfold equiv_decb.
+ intros A SA Aeq a b.
+ destruct (a =?= b).
+ - tauto.
+ - cbn in c.
+ intuition.
+Qed.
+
+Corollary equiv_decb_false A (SA:Setoid A) (Aeq:EqDec SA) : forall a b : A,(a ==b b = false) <-> a =/= b.
+Proof.
+intros. unfold complement.
+rewrite <- equiv_decb_spec with (Aeq := Aeq), <- Bool.not_true_iff_false.
+tauto.
+Qed.
diff --git a/_CoqProject b/_CoqProject
index a3d6ed3bb38e551f0bc1a494d475508ba6b31132..ba2193a3cd3a3aff7f6ba2c5ff6186c2f93e627f 100644
--- a/_CoqProject
+++ b/_CoqProject
@@ -8,6 +8,8 @@
# <8.12. We only support >= 8.12 now so this is nont needed anymore.
-arg -w
-arg -deprecated-hint-without-locality
+-arg -w
+-arg -deprecated-instance-without-locality
# Spaces in args are not supported, see Makefile.local
#-arg -set
@@ -53,13 +55,14 @@ Setting.v
Models/NoByzantine.v
Models/Flexible.v
Models/Rigid.v
-Models/RigidFlexibleEquivalence.v
-Models/RigidFlexibleEquivalence_Assumptions.v
Models/DiscreteGraph.v
Models/Isometry.v
Models/Similarity.v
Models/ContinuousGraph.v
+Models/RigidFlexibleEquivalence.v
+Models/RigidFlexibleEquivalence_Assumptions.v
Models/GraphEquivalence.v
+Models/GraphEquivalence_Assumptions.v
Models/RingSSync.v
## Spaces
@@ -80,11 +83,13 @@ Spaces/Grid.v
## Observations
Observations/Definition.v
Observations/MultisetObservation.v
+Observations/MultisetObservationInfo.v
Observations/SetObservation.v
Observations/LimitedSetObservation.v
Observations/LimitedMultisetObservation.v
Observations/PointedObservation.v
Observations/PreCompositionObservation.v
+Observations/PairObservation.v
## Case Study: Convergence
CaseStudies/Convergence/Impossibility_2G_1B.v
@@ -94,6 +99,7 @@ CaseStudies/Convergence/Algorithm_noB.v
## Case Study: Gathering
CaseStudies/Gathering/Definitions.v
CaseStudies/Gathering/WithMultiplicity.v
+CaseStudies/Gathering/WithMultiplicityLight.v
CaseStudies/Gathering/Impossibility.v
CaseStudies/Gathering/Impossibility_Assumptions.v
CaseStudies/Gathering/InR/Impossibility.v
@@ -108,6 +114,9 @@ CaseStudies/Gathering/InR2/Peleg.v
CaseStudies/Gathering/InR2/Peleg_Assumptions.v
CaseStudies/Gathering/InR2/Viglietta.v
CaseStudies/Gathering/InR2/Viglietta_Assumptions.v
+CaseStudies/Gathering/InR2/Algorithm_withLight.v
+CaseStudies/Gathering/InR2/Algorithm_withLight_Assumptions.v
+
## Case Study : Weber
CaseStudies/Gathering/InR2/Weber/Utils.v
diff --git a/codemeta.json b/codemeta.json
new file mode 100644
index 0000000000000000000000000000000000000000..d6ace5d8e2dd34759b9a802fc172a18d720d908a
--- /dev/null
+++ b/codemeta.json
@@ -0,0 +1,57 @@
+{
+ "@context": "https://w3id.org/codemeta/3.0",
+ "type": "SoftwareSourceCode",
+ "applicationCategory": "Coq library dedicated to formal verification of mobile robotic swarm distributed protocols",
+ "author": [
+ {
+ "id": "https://orcid.org/0000-0001-8789-9781",
+ "type": "Person",
+ "affiliation": {
+ "type": "Organization",
+ "name": "Conservatoire National des Arts et Métiers"
+ },
+ "email": "Pierre.Courtieu@lecnam.net",
+ "familyName": "Courtieu",
+ "givenName": "Pierre"
+ },
+ {
+ "id": "https://orcid.org/0000-0001-7442-2538",
+ "type": "Person",
+ "affiliation": {
+ "type": "Organization",
+ "name": "Université Claude Bernard Lyon 1"
+ },
+ "email": "Xavier.Urbain@univ-lyon1.fr",
+ "familyName": "Urbain",
+ "givenName": "Xavier"
+ },
+ {
+ "id": "_:author_3",
+ "type": "Person",
+ "affiliation": {
+ "type": "Organization",
+ "name": "Verimag, Grenoble INP -- UGA"
+ },
+ "email": "lionel.rieg@univ-grenoble-alpes.fr",
+ "familyName": "Rieg",
+ "givenName": "Lionel"
+ }
+ ],
+ "codeRepository": "https://gitlab.liris.cnrs.fr/pactole/coq-pactole",
+ "description": "A Coq library dedicated to formally verifying distributed protocols for mobile robot swarms. The library implements various extensions of the Look-Compute-Move model, first proposed by Suzuki and Yamashita, providing a robust framework for protocol verification in different theoretical settings. ",
+ "keywords": [
+ "distributed systems",
+ "deductive verification",
+ "formal proof",
+ "robotic swarms"
+ ],
+ "license": "https://spdx.org/licenses/LGPL-3.0",
+ "name": "Pactole",
+ "programmingLanguage": "Coq/Rocq",
+ "relatedLink": "https://pactole.liris.cnrs.fr/",
+ "runtimePlatform": "Coq-8.20",
+ "version": "2.1",
+ "developmentStatus": "active",
+ "funding": "Digiteo Project #2009-38HD, ANR Project 2019-CE25-0005",
+ "referencePublication": "https://doi.org/10.4230/LITES.8.2.2"
+}
diff --git a/dev/build_package.sh b/dev/build_package.sh
index ff3060a9fb6e6d549d8e1cf33c0798d16487a461..33d6dec3f2488c32f7320e6534c7de63c7f73b64 100755
--- a/dev/build_package.sh
+++ b/dev/build_package.sh
@@ -19,42 +19,134 @@ mkdir ./package/CaseStudies/Gathering
mkdir ./package/CaseStudies/Gathering/InR
mkdir ./package/CaseStudies/Gathering/InR2
mkdir ./package/CaseStudies/Exploration
+mkdir ./package/CaseStudies/LifeLine
+mkdir ./package/minipactole
# Create a fresh Makefile from the _CoqPoject
coq_makefile -f _CoqProject -o Makefile
# Copy files into each directory
-cp Util/FSets/FSetInterface.v Util/FSets/FSetFacts.v Util/FSets/FSetList.v ./package/Util/FSets/
-
-cp Util/FMaps/FMapInterface.v Util/FMaps/FMapFacts.v Util/FMaps/FMapList.v ./package/Util/FMaps/
-
-cp Util/MMultiset/Preliminary.v Util/MMultiset/MMultisetInterface.v Util/MMultiset/MMultisetFacts.v Util/MMultiset/MMultisetWMap.v Util/MMultiset/MMultisetExtraOps.v ./package/Util/MMultiset/
-
-cp Util/Coqlib.v Util/Preliminary.v Util/SetoidDefs.v Util/NumberComplements.v Util/ListComplements.v Util/Ratio.v Util/Lexprod.v Util/Stream.v Util/Bijection.v ./package/Util/
-
-cp Core/Robots.v Core/RobotInfo.v Core/Configurations.v Core/Formalism.v ./package/Core/
-
-cp Setting.v Makefile _CoqProject ./package/
-
-cp Spaces/RealVectorSpace.v Spaces/RealMetricSpace.v Spaces/RealNormedSpace.v Spaces/EuclideanSpace.v Spaces/Similarity.v Spaces/R.v Spaces/R2.v Spaces/Graph.v Spaces/Ring.v Spaces/Grid.v Spaces/Isomorphism.v ./package/Spaces/
-
-cp Observations/Definition.v Observations/MultisetObservation.v Observations/SetObservation.v Observations/LimitedMultisetObservation.v Observations/LimitedSetObservation.v ./package/Observations/
-
-cp Models/Rigid.v Models/Flexible.v Models/Similarity.v Models/RigidFlexibleEquivalence.v Models/DiscreteGraph.v Models/ContinuousGraph.v Models/GraphEquivalence.v ./package/Models/
-
-cp CaseStudies/Convergence/Impossibility_2G_1B.v CaseStudies/Convergence/Algorithm_noB.v ./package/CaseStudies/Convergence/
-
-cp CaseStudies/Gathering/Definitions.v CaseStudies/Gathering/WithMultiplicity.v CaseStudies/Gathering/Impossibility.v ./package/CaseStudies/Gathering/
-
-cp CaseStudies/Gathering/InR/Algorithm.v CaseStudies/Gathering/InR/Impossibility.v ./package/CaseStudies/Gathering/InR/
-
-cp CaseStudies/Gathering/InR2/Algorithm.v ./package/CaseStudies/Gathering/InR2/
-#Gathering/InR2/FSyncFlexNoMultAlgorithm.v Gathering/InR2/Peleg.v
-
-cp CaseStudies/Exploration/Definitions.v CaseStudies/Exploration/ImpossibilityKDividesN.v CaseStudies/Exploration/Tower.v ./package/CaseStudies/Exploration/
-
-# Specific to workshops/lectures
-cp exercises.v ./package/
+cp Util/FSets/FSetInterface.v \
+ Util/FSets/FSetFacts.v \
+ Util/FSets/FSetList.v \
+ ./package/Util/FSets/
+
+cp Util/FMaps/FMapInterface.v \
+ Util/FMaps/FMapFacts.v \
+ Util/FMaps/FMapList.v \
+ ./package/Util/FMaps/
+
+cp Util/MMultiset/Preliminary.v \
+ Util/MMultiset/MMultisetInterface.v \
+ Util/MMultiset/MMultisetFacts.v \
+ Util/MMultiset/MMultisetWMap.v \
+ Util/MMultiset/MMultisetExtraOps.v \
+ ./package/Util/MMultiset/
+
+cp Util/Coqlib.v \
+ Util/Preliminary.v \
+ Util/SetoidDefs.v \
+ Util/NumberComplements.v \
+ Util/ListComplements.v \
+ Util/Ratio.v \
+ Util/Lexprod.v \
+ Util/Stream.v \
+ Util/Bijection.v \
+ ./package/Util/
+
+cp Core/Identifiers.v \
+ Core/State.v \
+ Core/Configuration.v \
+ Core/Formalism.v \
+ ./package/Core/
+
+cp Setting.v \
+ Pactole_all.v \
+ Makefile \
+ _CoqProject \
+ ./package/
+
+cp Spaces/RealVectorSpace.v \
+ Spaces/RealMetricSpace.v \
+ Spaces/RealNormedSpace.v \
+ Spaces/EuclideanSpace.v \
+ Spaces/Similarity.v \
+ Spaces/Isometry.v \
+ Spaces/R.v \
+ Spaces/R2.v \
+ Spaces/Graph.v \
+ Spaces/Ring.v \
+ Spaces/Grid.v \
+ Spaces/Isomorphism.v \
+ ./package/Spaces/
+
+cp Observations/Definition.v \
+ Observations/MultisetObservation.v \
+ Observations/MultisetObservationInfo.v \
+ Observations/SetObservation.v \
+ Observations/LimitedMultisetObservation.v \
+ Observations/LimitedSetObservation.v \
+ Observations/PointedObservation.v \
+ Observations/PreCompositionObservation.v \
+ Observations/PairObservation.v \
+ ./package/Observations/
+
+cp Models/NoByzantine.v \
+ Models/Rigid.v \
+ Models/Flexible.v \
+ Models/Isometry.v \
+ Models/Similarity.v \
+ Models/RigidFlexibleEquivalence.v \
+ Models/RigidFlexibleEquivalence_Assumptions.v \
+ Models/DiscreteGraph.v \
+ Models/ContinuousGraph.v \
+ Models/GraphEquivalence.v \
+ Models/GraphEquivalence_Assumptions.v \
+ ./package/Models/
+
+cp CaseStudies/Convergence/Impossibility_2G_1B.v \
+ CaseStudies/Convergence/Impossibility_2G_1B_Assumptions.v \
+ CaseStudies/Convergence/Algorithm_noB.v \
+ CaseStudies/Convergence/Algorithm_noB_Assumptions.v \
+ ./package/CaseStudies/Convergence/
+
+cp CaseStudies/Gathering/Definitions.v \
+ CaseStudies/Gathering/WithMultiplicity.v \
+ CaseStudies/Gathering/WithMultiplicityLight.v \
+ CaseStudies/Gathering/Impossibility.v \
+ CaseStudies/Gathering/Impossibility_Assumptions.v \
+ ./package/CaseStudies/Gathering/
+
+cp CaseStudies/Gathering/InR/Algorithm.v \
+ CaseStudies/Gathering/InR/Algorithm_Assumptions.v \
+ CaseStudies/Gathering/InR/Impossibility.v \
+ CaseStudies/Gathering/InR/Impossibility_Assumptions.v \
+ ./package/CaseStudies/Gathering/InR/
+
+cp CaseStudies/Gathering/InR2/Algorithm.v \
+ CaseStudies/Gathering/InR2/Algorithm_Assumptions.v \
+ CaseStudies/Gathering/InR2/Algorithm_withLight.v \
+ CaseStudies/Gathering/InR2/Algorithm_withLight_Assumptions.v \
+ CaseStudies/Gathering/InR2/FSyncFlexNoMultAlgorithm.v \
+ CaseStudies/Gathering/InR2/FSyncFlexNoMultAlgorithm_Assumptions.v \
+ CaseStudies/Gathering/InR2/Peleg.v \
+ CaseStudies/Gathering/InR2/Peleg_Assumptions.v \
+ CaseStudies/Gathering/InR2/Viglietta.v \
+ CaseStudies/Gathering/InR2/Viglietta_Assumptions.v \
+ ./package/CaseStudies/Gathering/InR2/
+
+cp CaseStudies/Exploration/Definitions.v \
+ CaseStudies/Exploration/ImpossibilityKDividesN.v \
+ CaseStudies/Exploration/ImpossibilityKDividesN_Assumptions.v \
+ CaseStudies/Exploration/Tower.v \
+ CaseStudies/Exploration/Tower_Assumptions.v \
+ ./package/CaseStudies/Exploration/
+
+cp CaseStudies/LifeLine/Algorithm.v \
+ ./package/CaseStudies/LifeLine/
+
+cp minipactole/minipactole.v \
+ ./package/minipactole/
# Compile the archive to make sure it works
time make -C package -j 3
diff --git a/minipactole/minipactole.v b/minipactole/minipactole.v
index 9c2d557149970acace4e0b0a32cb8b922fc07d23..80c277b77fb8da2bdcb14a925464d8e5c289fda3 100644
--- a/minipactole/minipactole.v
+++ b/minipactole/minipactole.v
@@ -10,7 +10,7 @@ Open Scope R_scope.
Inductive ident:Type := A | B. (* Nous avons seulement 2 robots. *)
Definition position := (R*R)%type. (*les coordonnées dans le plan euclidien.*)
-
+Unset Automatic Proposition Inductives.
Class State_info {info:Type}:Type := mkStI { }. (* Paramètre du modèle *)
Class State_pos {pos:Type}:Type := mkStP { }. (* Paramètre du modèle *)