(**************************************************************************)
(*   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 Reals.
Require Import Psatz.
Require Import Morphisms.
Require Import Arith.Div2.
Require Import Lia.
Require Import List SetoidList.
Require Import Pactole.Util.Preliminary.
Require Import Pactole.Setting.
Require Import Pactole.Spaces.EuclideanSpace.
Require Import Pactole.CaseStudies.Gathering.Definitions.
Require Pactole.CaseStudies.Gathering.WithMultiplicity.
Import Pactole.Observations.MultisetObservation.
Require Import Pactole.Models.Rigid.
Require Import Pactole.Models.NoByzantine.
Set Implicit Arguments.
Close Scope R_scope.
Close Scope VectorSpace_scope.
Import Datatypes. (* To recover Datatypes.id *)
Typeclasses eauto := (bfs).
Remove Hints eq_setoid : typeclass_instances.
(* TODO: make equiv not unfolded everywhere. *)
Arguments equiv : simpl never.

Section ImpossibilityProof.

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

(** We assume that the number of robots is even and non-null. *)
Hypothesis even_nG : Nat.Even n.
Hypothesis nG_non_0 : n <> 0.

Local Transparent G B.

(** The setting is an arbitrary metric space over R. *)
Context `{Location}.
(* Instance St : State location := OnlyLocation (fun _ => True). *)
Context {VS : RealVectorSpace location}.
Context {ES : EuclideanSpace location}.

(** We assume that the space is equipped with a [build_similarity] function
    that can map any pair of distinct points to any other pair. *)
Variable build_similarity : forall {pt1 pt2 pt3 pt4 : location},
  pt1 =/= pt2 -> pt3 =/= pt4 -> similarity location.
Hypothesis build_similarity_compat : forall pt1 pt1' pt2 pt2' pt3 pt3' pt4 pt4'
  (H12 : pt1 =/= pt2) (H34 : pt3 =/= pt4) (H12' : pt1' =/= pt2') (H34' : pt3' =/= pt4'),
  pt1 == pt1' -> pt2 == pt2' -> pt3 == pt3' -> pt4 == pt4' ->
  build_similarity H12 H34 == build_similarity H12' H34'.

Hypothesis build_similarity_eq1 : forall pt1 pt2 pt3 pt4 (Hdiff12 : pt1 =/= pt2) (Hdiff34 : pt3 =/= pt4),
  build_similarity Hdiff12 Hdiff34 pt1 == pt3.
Hypothesis build_similarity_eq2 : forall pt1 pt2 pt3 pt4 (Hdiff12 : pt1 =/= pt2) (Hdiff34 : pt3 =/= pt4),
  build_similarity Hdiff12 Hdiff34 pt2 == pt4.
Hypothesis build_similarity_inverse : forall pt1 pt2 pt3 pt4 (Hdiff12 : pt1 =/= pt2) (Hdiff34 : pt3 =/= pt4),
  inverse (build_similarity Hdiff12 Hdiff34) == build_similarity Hdiff34 Hdiff12.
Hypothesis build_similarity_swap : forall pt1 pt2 pt3 pt4 (Hdiff12 : pt1 =/= pt2) (Hdiff34 : pt3 =/= pt4),
  build_similarity (symmetry Hdiff12) (symmetry Hdiff34) == build_similarity Hdiff12 Hdiff34.

(** We are in a rigid formalism with no other info than the location,
    so the demon makes no choice and robots compute a target destination in the considered space. *)
Instance ActiveChoice : update_choice unit := NoChoice.
Instance InactiveChoice : inactive_choice unit := { inactive_choice_EqDec := unit_eqdec }.
Instance RobotChoice : robot_choice location := { robot_choice_Setoid := location_Setoid }.
Instance Info : State location := OnlyLocation (fun _ => True).
Instance UpdFun : update_function location (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) }.

(* Trying to avoid notation problem with implicit arguments *)
Notation "s [ x ]" := (multiplicity x s) (at level 2, no associativity, format "s [ x ]").
Notation obs_from_config := (@obs_from_config _ _ _ _ multiset_observation).
Notation "!! config" := (obs_from_config config origin) (at level 10).

(* FIXME: why is this instance not taken from Similarity from Definition *)
Instance Frame : frame_choice (similarity location) := FrameChoiceSimilarity.

Implicit Type config : configuration.
Implicit Type da : demonic_action.

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

Lemma nG_ge_2 : 2 <= nG.
Proof using even_nG nG_non_0.
assert (Heven := even_nG). assert (HnG0 := nG_non_0).
inversion Heven. simpl.
destruct n as [| [| ?]]; lia.
Qed.

Lemma half_size_config : Nat.div2 nG > 0.
Proof using even_nG nG_non_0.
assert (Heven := even_nG). assert (HnG0 := nG_non_0).
simpl. destruct n as [| [| ?]].
- lia.
- destruct Heven. lia.
- simpl. lia.
Qed.

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

Definition mk_info : location -> location := id.
Arguments mk_info _%VectorSpace_scope.
Lemma mk_info_get_location : forall pt, get_location (mk_info pt) == pt.
Proof using . reflexivity. Qed.
(*
(** We only assume that we know how to build a state from a position and this is compatible with [get_location]. *)
Variable mk_info : R -> info.
Hypothesis mk_info_get_location : forall pt, get_location (mk_info pt) == pt.
Instance mk_info_compat : Proper (equiv ==> equiv) mk_info.
Proof. simpl. repeat intro. now subst. Qed.
*)

(* To avoid passing the [nB = 0] argument each time. *)
Definition invalid_dec := WithMultiplicity.invalid_dec (reflexivity nB).

(** From [elements], we can rebuild the [config_list]. *)
Lemma obs_makes_config_list : forall config : configuration,
  PermutationA equiv (List.map get_location (config_list config))
                     (List.fold_right (fun '(x, n) acc => alls x n ++ acc) nil (elements (!! config))).
Proof using nG_non_0.
intro config.
unfold obs_from_config. cbn -[get_location config_list elements equiv location].
unfold make_multiset.
induction (List.map get_location (config_list config)) as [| e l]; try reflexivity; [].
(* maybe only the second arg is useful *)
assert (Hcompat : Proper (PermutationA equiv ==> PermutationA equiv ==> PermutationA equiv)
                         (fold_right (fun '(x, n) (acc : list location) => alls x n ++ acc))).
{ clear IHl l. intros l1 l1' Hl1 l2 l2' Hl2.
  revert l1 l1' Hl1. pattern l2, l2'.
  apply PermutationA_ind_bis with equiv; autoclass.
  + intros [] [] ? ? [Hl Hn] Hperm Hrec ? ? ?. simpl in *.
    rewrite Hn, Hl at 1. unfold equiv. now rewrite Hrec.
  + intros [] [] ? ? Hperm Hrec ? ? ?. simpl. rewrite Hrec, 2 app_assoc; try eassumption; [].
    f_equiv. apply PermutationA_app_comm; autoclass.
  + intros ? ? ? Hperm1 Hperm2 Hperm Hrec ? ? ?.
    rewrite Hperm2; try eassumption; []. now apply Hrec. }
cbn [List.map]. rewrite from_elements_cons.
rewrite IHl at 1.
assert (H01 : 0 < 1) by lia.
assert (Hperm := elements_add (x := e) (m := from_elements (List.map (fun x : location => (x, 1)) l))
                              (or_introl H01)).
rewrite (Hcompat _ _ (reflexivity _) _ _ Hperm).
cbn [fold_right alls plus app]. constructor; try reflexivity; [].
destruct (Nat.eq_dec (from_elements (List.map (fun x : location => (x, 1)) l))[e] 0) as [Heq | ?].
* (* [e] is not present in the observation *)
  rewrite Heq. cbn [alls app].
  rewrite Preliminary.removeA_out; try reflexivity; []. (* TODO: put it also in Util/Preliminary *)
  rewrite elements_spec. simpl. intuition.
* (* [e] does appear in the observation *)
  change (alls e (from_elements (List.map (fun x' : location => (x', 1)) l))[e] ++
          fold_right (fun '(x, n) (acc : list location) => alls x n ++ acc) nil
            (removeA (eqA:=eq_pair) pair_dec (e, (from_elements (List.map (fun x'' : location => (x'', 1)) l))[e])
              (elements (from_elements (List.map (fun x''' : location => (x''', 1)) l)))))
    with (fold_right (fun '(x, n) (acc : list location) => alls x n ++ acc) nil
           ((e, (from_elements (List.map (fun x : location => (x, 1)) l))[e])
            :: (removeA (eqA:=eq_pair) pair_dec (e, (from_elements (List.map (fun x : location => (x, 1)) l))[e])
               (elements (from_elements (List.map (fun x : location => (x, 1)) l)))))).
  apply Hcompat; try reflexivity; [].
  apply NoDupA_equivlistA_PermutationA; autoclass.
  + eapply NoDupA_strengthen, elements_NoDupA. apply subrelation_pair_elt.
  + constructor.
    - rewrite removeA_InA; autoclass; []. intuition.
    - eapply removeA_NoDupA, NoDupA_strengthen, elements_NoDupA; autoclass.
  + intro x. split; intro Hin.
    - change (InA eq_pair x (elements (from_elements (List.map (fun x : location => (x, 1)) l)))) in Hin.
      destruct (fst x =?= e) as [Heq | Heq].
      -- rewrite elements_spec in Hin. rewrite Heq in *. left. destruct x. simpl in *. intuition.
      -- right. rewrite removeA_InA; autoclass; [].
         split; trivial; [].
         intros [? _]. now apply Heq.
    - inv Hin.
      -- revert_one @equiv. intro Hx. rewrite Hx.
         change (InA eq_pair (e, (from_elements (List.map (fun y => (y, 1)) l))[e])
                             (elements (from_elements (List.map (fun y => (y, 1)) l)))).
         rewrite elements_spec; simpl.
         split; trivial; []. apply neq_0_lt. auto.
      -- revert_all.
         rewrite removeA_InA; autoclass. tauto.
Qed.

(** [Always_invalid e] means that (infinite) execution [e] is [invalid]
    forever. We will prove that with [bad_demon], robots are always apart. *)
Definition Always_invalid (e : execution) := Stream.forever (Stream.instant WithMultiplicity.invalid) e.

Instance Always_invalid_compat : Proper (equiv ==> iff) Always_invalid.
Proof using . apply Stream.forever_compat, Stream.instant_compat. apply WithMultiplicity.invalid_compat. Qed.

(** **  Linking the different properties  **)

Theorem different_no_gathering : forall (e : execution),
  Always_invalid e -> ~WillGather e.
Proof using even_nG nG_non_0.
intros e He Habs. induction Habs as [e Habs | e].
+ destruct Habs as [pt [Hnow Hlater]]. destruct He as [Hinvalid He].
  destruct Hinvalid as [_ [_ [pt1 [pt2 [Hdiff [Hin1 Hin2]]]]]].
  apply Hdiff. transitivity pt.
  - assert (Hin : In pt1 (!! (Stream.hd e))).
    { unfold In. setoid_rewrite Hin1. now apply half_size_config. }
    rewrite obs_from_config_In in Hin.
    destruct Hin as [id Hin]. rewrite <- Hin.
    apply (no_byz id). intro g. now unfold gathered_at in Hnow; specialize (Hnow g).
  - assert (Hin : In pt2 (!! (Stream.hd e))).
    { unfold In. setoid_rewrite Hin2. now apply half_size_config. }
    rewrite obs_from_config_In in Hin.
    destruct Hin as [id Hin]. rewrite <- Hin.
    symmetry. apply (no_byz id). intro g. apply Hnow.
+ inversion He. now apply IHHabs.
Qed.

Hint Resolve half_size_config : core.

(** As there is no byzantine robot, we can lift configurations for good robots as a full configuration.  *)
Definition lift_config {A} (config : G -> A) : ident -> A := fun id =>
  match id with
    | Good g => config g
    | Byz b => ltac:(exfalso; now apply (Nat.nlt_0_r (proj1_sig b)), proj2_sig)
  end.

Local Opaque G B.

(** We define a particular robot [g0] that will help us distinguish two towers:
    the first one will be the one that [g0] belongs to.
    The actual value of g0 is irrelevant so we make its body opaque.  *)
Definition g0 : G.
Proof using nG_non_0. exists 0. generalize nG_non_0. intro. lia. Qed.

(** *  Proof of the impossiblity of gathering  **)

(** From now on and until the final theorem we assume given a robogram [r]. *)

Variable r : robogram.
Open Scope R_scope.

(* A demon that makes the robogram fail on any invalid configuration:
   - if robots go on the position of the other one (symmetrical by definition of robogram),
     activate both and they swap positions;
   - otherwise, just activate one and the distance between them does not become zero
     and you can scale it back on the next round. *)

Definition observation0 : observation := add origin (Nat.div2 nG) (singleton one (Nat.div2 nG)).
Arguments observation0 : simpl never.

Theorem invalid_obs : forall config, WithMultiplicity.invalid config -> forall g,
  { sim : similarity location | !! config == map sim observation0 & sim origin == get_location (config (Good g)) }.
Proof.
intros config Hconfig g.
destruct (WithMultiplicity.invalid_strengthen (reflexivity _) Hconfig) as [pt1 [pt2 Hdiff Hobs]].
destruct (get_location (config (Good g)) =?= pt1) as [Heq1 | Heq1].
+ (* we map origin to pt1 and unit to pt2 *)
  exists (build_similarity (symmetry non_trivial) Hdiff).
  - unfold observation0.
    rewrite Hobs, map_add, map_singleton,
            build_similarity_eq1, build_similarity_eq2; autoclass.
  - now rewrite build_similarity_eq1.
+ (* we map origin to pt2 and unit to pt1 *)
  symmetry in Hdiff.
  exists (build_similarity (symmetry non_trivial) Hdiff).
  - unfold observation0.
    rewrite Hobs, map_add, map_singleton,
            build_similarity_eq1, build_similarity_eq2; autoclass; [].
    intro. rewrite 2 add_spec, 2 singleton_spec. do 2 destruct_match; simpl in *; lia.
  - rewrite build_similarity_eq1. symmetry.
    assert (Hin := pos_in_config config origin (Good g)).
    rewrite Hobs, add_In, In_singleton in Hin. hnf in Heq1. tauto.
Defined.

Definition proj1_sig2 {A : Type} {P Q : A -> Prop} (e : {x : A | P x & Q x}) := let (a, _, _) := e in a.

(* This proof is different that the one for R and requires invalid_obs to be transparent. *)
Lemma invalid_obs_compat : forall config1 config2 (H1 : WithMultiplicity.invalid config1) (H2 : WithMultiplicity.invalid config2),
  config1 == config2 ->
  forall g h, get_location (config1 (Good g)) == get_location (config2 (Good h)) ->
  proj1_sig2 (invalid_obs H1 g) == proj1_sig2 (invalid_obs H2 h).
Proof using build_similarity_compat even_nG.
intros config1 config2 H1 H2 Heq g h Hgh.
unfold invalid_obs.
destruct (WithMultiplicity.invalid_strengthen (reflexivity 0%nat) H1) as [pt1 [pt2 Hdiff Hobs]],
         (WithMultiplicity.invalid_strengthen (reflexivity 0%nat) H2) as [pt3 [pt4 Hdiff' Hobs']].
assert (Hperm : PermutationA equiv (pt1 :: pt2 :: nil) (pt3 :: pt4 :: nil)).
{ rewrite Heq, Hobs' in Hobs. apply support_compat in Hobs.
  revert Hobs. rewrite 2 support_add; auto; [].
  destruct (In_dec pt3 (singleton pt4 (Nat.div2 nG))) as [Habs |];
  [| destruct (In_dec pt1 (singleton pt2 (Nat.div2 nG))) as [Habs |]].
  - rewrite In_singleton in Habs. now elim Hdiff'.
  - rewrite In_singleton in Habs. now elim Hdiff.
  - rewrite 2 support_singleton; auto; []. now symmetry. }
repeat destruct_match; simpl; rewrite Hgh in *; intro.
+ assert (Heq1 : pt1 == pt3) by now transitivity (get_location (config2 (Good h))).
  rewrite Heq1 in Hperm. apply PermutationA_cons_inv in Hperm; autoclass; [].
  rewrite PermutationA_1 in Hperm; autoclass; [].
  now apply build_similarity_compat.
+ assert (Heqpt : pt1 == pt4 /\ pt2 == pt3).
  { rewrite PermutationA_2 in Hperm; autoclass; [].
    destruct Hperm as [[Heq1 Heq2] |?]; trivial; [].
    rewrite Heq1 in *. simpl complement in *. contradiction. }
  destruct Heqpt as [Heq1 Heq2].
  now apply build_similarity_compat.
+ assert (Heqpt : pt1 == pt4 /\ pt2 == pt3).
  { rewrite PermutationA_2 in Hperm; autoclass; [].
    destruct Hperm as [[Heq1 Heq2] |?]; trivial; [].
    rewrite Heq1 in *. simpl complement in *. contradiction. }
  destruct Heqpt as [Heq1 Heq2].
  now apply build_similarity_compat.
+ assert (Heq2 : pt2 == pt4).
  { transitivity (get_location (config2 (Good h))).
    - assert (Hin := pos_in_config config1 origin (Good h)).
      rewrite Hobs, Heq, add_In, In_singleton in Hin.
      simpl complement in *. symmetry. tauto.
    - assert (Hin := pos_in_config config2 origin (Good h)).
      rewrite Hobs', add_In, In_singleton in Hin.
      simpl complement in *. tauto. }
  rewrite Heq2 in Hperm. setoid_rewrite permA_swap in Hperm.
  apply PermutationA_cons_inv in Hperm; autoclass; [].
  rewrite PermutationA_1 in Hperm; autoclass; [].
  now apply build_similarity_compat.
Qed.

Global Opaque invalid_obs.

Theorem invalid_reverse : forall (sim : similarity location) config,
  !! config == map sim observation0 -> WithMultiplicity.invalid config.
Proof using even_nG nG_non_0.
intros sim config Hsim.
assert (Hcardinal := cardinal_obs_from_config config origin).
assert (Heven : Nat.Even nG).
{ rewrite <- Nat.even_spec.
  cut (Nat.odd nG = false).
  + unfold Nat.odd. now rewrite Bool.negb_false_iff.
  + apply Bool.not_true_is_false. intro Hodd.
    rewrite Hsim, map_cardinal in Hcardinal; autoclass; [].
    unfold observation0 in Hcardinal. rewrite cardinal_add, cardinal_singleton in Hcardinal.
    rewrite (Nat.div2_odd nG) in Hcardinal at 3. rewrite Hodd in *. simpl in *. lia. }
repeat split; trivial; [|].
+ rewrite <- Nat.even_spec in Heven.
  assert (HnG := nG_non_0). simpl nG in *.
  destruct n as [| [| ?]]; simpl; discriminate || lia || now elim HnG.
+ exists (sim origin), (sim one).
  repeat split.
  - intro Heq. apply Similarity.injective in Heq. symmetry in Heq. revert Heq. apply non_trivial.
  - rewrite Hsim, map_injective_spec; autoclass; try apply Similarity.injective; [].
    unfold observation0. rewrite add_same, singleton_other; try lia; [].
    symmetry. apply non_trivial.
  - rewrite Hsim, map_injective_spec; autoclass; try apply Similarity.injective; [].
    unfold observation0. rewrite add_other, singleton_same; try lia; [].
    apply non_trivial.
Qed.

(** The movement of robots in the reference configuration. *)
Definition move := get_location (r observation0).

(** The key idea is to prove that we can always make robots see the same observation in any invalid configuration.
    If they do not gather in one step, then they will never do so.

    So, in [config1], if the robot move to [one], we activate all robots and they swap locations.
    If it does not, we activate only this tower which does not reach to other one.
    The new configuration is the same up to scaling, translation and rotation.  *)

(** **  First case: the robots exchange their positions  **)

Section Move1.

Hypothesis Hmove : move == one.

Definition change_frame1 config (g : G) :=
  match invalid_dec config with
    | Specif.left  H => inverse (proj1_sig2 (invalid_obs H g))
    | Specif.right H => Similarity.id (* this second case will never be used *)
  end.

Instance change_frame1_compat : Proper (equiv ==> Logic.eq ==> equiv) change_frame1.
Proof using build_similarity_compat even_nG.
unfold change_frame1. intros config1 config2 Heq gg g ?. subst gg.
destruct (invalid_dec config1) as [H1 | ?],
         (invalid_dec config2) as [H2 | ?];
  try reflexivity || (apply WithMultiplicity.invalid_compat in Heq; tauto); [].
apply inverse_compat, invalid_obs_compat; trivial; now rewrite Heq.
Qed.

(** A demon swapping both towers *)
Definition da1 : demonic_action := {|
  activate := fun _ => true;
  relocate_byz := fun _ b => mk_info origin;
  change_frame := change_frame1;
  choose_update := fun _ _ _ => tt;
  choose_inactive := fun _ _ => tt;

  precondition_satisfied := fun _ _ => I;
  precondition_satisfied_inv := fun _ _ => I;

  activate_compat := ltac:(now repeat intro);
  relocate_byz_compat := ltac:(now repeat intro; f_equiv);
  change_frame_compat := change_frame1_compat;
  choose_update_compat := ltac:(now repeat intro);
  choose_inactive_compat := ltac:(now repeat intro) |}.

Definition bad_demon1 : demon := Stream.constant da1.

Lemma kFair_bad_demon1 : kFair 0 bad_demon1.
Proof using . coinduction bad_fair1. intros id1 id2. now constructor. Qed.

(* It is a more restricted version where we assume that the starting configuration is invalid. *)
Lemma round_simplify1 : forall config pt1 pt2,
  pt1 =/= pt2 ->
  !! config == add pt1 (Nat.div2 nG) (singleton pt2 (Nat.div2 nG)) ->
  round r da1 config == fun id => match id with
                          | Good g => mk_info (if get_location (config (Good g)) =?= pt1 then pt2 else pt1)
                          | Byz b => mk_info origin
                        end.
Proof using Hmove.
intros config pt1 pt2 Hdiff Hobs.
assert (Hcase : forall id, get_location (config id) == pt1 \/ get_location (config id) == pt2).
{ intro id. assert (Hin := pos_in_config config origin id).
  rewrite Hobs, add_In, In_singleton in Hin. subst. tauto. }
apply no_byz_eq. intro g.
rewrite mk_info_get_location.
unfold round. cbn -[equiv equiv_dec get_location map_config lift].
rewrite get_location_lift. unfold map_config at 2. cbn [projT1]. simpl get_location at 2. unfold id.
rewrite <- obs_from_config_map, obs_from_config_ignore_snd; autoclass; [].
unfold change_frame1.
destruct (invalid_dec config) as [Hvalid | Hvalid].
* (* invalid configuration *)
  destruct (invalid_obs Hvalid g) as [sim Hobs1 Horigin1].
  simpl proj1_sig2.
  rewrite Hobs1, map_merge; autoclass; [].
  rewrite map_extensionality_compat, map_id; autoclass; try apply Similarity.compose_inverse_l; [].
  rewrite Hmove.
  assert (Hperm : PermutationA equiv (pt1 :: pt2 :: nil) (sim origin :: sim one :: nil)).
  { apply support_compat in Hobs1. revert Hobs1.
    rewrite Hobs. unfold observation0.
    rewrite map_add, map_singleton; autoclass; [].
    rewrite 2 support_add; auto; [].
    destruct (In_dec pt1 (singleton pt2 (Nat.div2 nG))) as [Hin | Hin],
             (In_dec (sim origin) (singleton (sim one) (Nat.div2 nG))) as [Hin' | Hin'];
    rewrite In_singleton in Hin, Hin';
    try solve [ simpl in *; tauto ]; [|].
    - destruct Hin' as [Hin' _]. apply Similarity.injective in Hin'.
      symmetry in Hin'. elim (non_trivial Hin').
    - rewrite 2 support_singleton; auto. }
  rewrite PermutationA_2 in Hperm; autoclass; [].
  destruct_match.
  + assert (Hpt1 : sim origin == pt1) by (etransitivity; eauto).
    assert (Hpt2 : sim one == pt2).
    { decompose [and or] Hperm; auto; []. rewrite Hpt1 in *. now elim Hdiff. }
    now rewrite <- Hpt2.
  + assert (Hpt2 : sim origin == pt2).
    { destruct (Hcase (Good g)); try contradiction; []. etransitivity; eauto. }
    assert (Hpt1 : sim one == pt1).
    { decompose [and or] Hperm; auto; []. rewrite Hpt2 in *. now elim Hdiff. }
    now rewrite <- Hpt1.
* elim Hvalid.
  apply (invalid_reverse (build_similarity non_trivial Hdiff)).
  rewrite Hobs. unfold observation0.
  rewrite map_add, map_singleton, build_similarity_eq1, build_similarity_eq2; autoclass; [].
  apply add_singleton_comm.
Qed.

Lemma invalid_da1_next : forall config, WithMultiplicity.invalid config -> WithMultiplicity.invalid (round r da1 config).
Proof using Hmove.
intros config Hvalid.
destruct (WithMultiplicity.invalid_strengthen (reflexivity _) Hvalid) as [pt1 [pt2 Hdiff Hobs]].
(* As [config] is invalid, all robots are only on two locations. *)
assert (Hcase : forall id, get_location (config id) == pt1 \/ get_location (config id) == pt2).
{ intro id. assert (Hin := pos_in_config config origin id).
  rewrite Hobs, add_In, In_singleton in Hin. subst. tauto. }
(* We build the similarity that performs the swap. *)
assert (Hdiff' : pt2 =/= pt1) by now symmetry.
pose (sim := build_similarity Hdiff Hdiff' : similarity location).
assert (Hconfig : round r da1 config == map_config (lift (existT precondition sim I)) config).
{ rewrite (round_simplify1 config Hdiff Hobs).
  apply no_byz_eq. intro g.
  cbn [map_config]. rewrite get_location_lift, mk_info_get_location.
  destruct (get_location (config (Good g)) =?= pt1) as [Hg | Hg];
  destruct (Hcase (Good g)) as [Hg' | Hg']; rewrite Hg' in *;
  solve [ symmetry; apply build_similarity_eq1
        | symmetry; apply build_similarity_eq2
        |  auto; now elim Hg ]. }
(* Let us pick an arbitrary robot (here [g0]) and consider a similarity [sim1]
   that maps [!! config] to [observation0] and such that [sim1 g0 = origin]. *)
destruct (invalid_obs Hvalid g0) as [sim1 Hsim1 ?].
apply (invalid_reverse (sim ∘ sim1)).
rewrite Hconfig.
rewrite <- obs_from_config_ignore_snd, <- obs_from_config_map, Hsim1, map_merge; autoclass.
Qed.

(* Trick to perform rewriting in coinductive proofs : assert your property on any configuration
   equal to the one you want, then apply the cofixpoint before performing the required rewrites. *)
Theorem Always_invalid1 : forall config, WithMultiplicity.invalid config ->
  Always_invalid (execute r bad_demon1 config).
Proof using Hmove.
coinduction differs.
+ now simpl.
+ cbn. now apply invalid_da1_next.
Qed.

End Move1.

(** **  Second case: Only one robot is activated at a time  **)

(* TODO: clean the proofs in this case, there are way to complicated
         (in particular the lemmas and uses of change_frame2) *)
Section MoveNot1.

Hypothesis Hmove : move =/= one.

(** A function that return different results depending on which tower the robot is.
    Both results are parametrized by the ordered locations of the towers.
    The first function argument is the one for the tower where [g0] is. *)
Definition select_tower {A} (b_g0 b : forall pt1 pt2 : location, pt1 =/= pt2 -> A)
                            (default : A) (config : configuration) (id : ident) :=
  match invalid_dec config with
    | Specif.left  H =>
        match WithMultiplicity.invalid_strengthen (reflexivity _) H with
        | existT _ pt1 (exist2 _ _ pt2 Hdiff Hobs) =>
          if get_location (config (Good g0)) =?= pt1
          then if get_location (config id) =?= get_location (config (Good g0))
               then b_g0 pt1 pt2 Hdiff
               else b pt1 pt2 Hdiff
          else if get_location (config id) =?= get_location (config (Good g0))
               then b_g0 pt2 pt1 (symmetry Hdiff)
               else b pt2 pt1 (symmetry Hdiff)
        end
    | Specif.right H => default (* this second case will never be used *)
  end.

Instance select_tower_compat : forall A (eqA : relation A) b_g0 b,
  (forall pt1 pt2 pt1' pt2' (Hdiff : pt1 =/= pt2) (Hdiff' : pt1' =/= pt2'),
     pt1 == pt1' -> pt2 == pt2' -> eqA (b_g0 pt1 pt2 Hdiff) (b_g0 pt1' pt2' Hdiff')) ->
  (forall pt1 pt2 pt1' pt2' (Hdiff : pt1 =/= pt2) (Hdiff' : pt1' =/= pt2'),
     pt1 == pt1' -> pt2 == pt2' -> eqA (b pt1 pt2 Hdiff) (b pt1' pt2' Hdiff')) ->
  Proper (eqA ==> @equiv configuration _ ==> eq ==> eqA) (select_tower b_g0 b).
Proof using even_nG.
intros A eqA b_g0 b Hb_g0 Hb default1 default2 Hdefault config1 config2 Hconfig gg g ?. subst gg.
unfold select_tower.
destruct (invalid_dec config1) as [Hvalid1 | Hvalid1],
         (invalid_dec config2) as [Hvalid2 | Hvalid2];
try (exfalso; revert Hvalid1 Hvalid2; rewrite Hconfig; tauto); trivial; [].
change 0%nat with nB.
destruct (WithMultiplicity.invalid_strengthen (reflexivity nB) Hvalid1) as [pt1  [pt2  Hdiff  Hobs ]],
         (WithMultiplicity.invalid_strengthen (reflexivity nB) Hvalid2) as [pt1' [pt2' Hdiff' Hobs']].
assert (Hperm : PermutationA equiv (pt1 :: pt2 :: nil) (pt1' :: pt2' :: nil)).
{ apply support_compat in Hobs'. revert Hobs'.
  rewrite <- Hconfig, Hobs.
  rewrite 2 support_add; auto; [].
  destruct (In_dec pt1 (singleton pt2 (Nat.div2 nG))) as [Hin |];
  try (rewrite In_singleton in Hin; destruct Hin as [Hin _]; contradiction); [].
  destruct (In_dec pt1' (singleton pt2' (Nat.div2 nG))) as [Hin |];
  try (rewrite In_singleton in Hin; destruct Hin as [Hin _]; contradiction); [].
  rewrite 2 support_singleton; auto. }
apply PermutationA_2 in Hperm; autoclass; [].
assert (Hcase1 : forall id, get_location (config1 id) == pt1 \/ get_location (config1 id) == pt2).
{ intro id. assert (Hin := pos_in_config config1 origin id).
  rewrite Hobs, add_In, In_singleton in Hin. tauto. }
assert (Hcase2 : forall id, get_location (config2 id) == pt1' \/ get_location (config2 id) == pt2').
{ intro id. assert (Hin := pos_in_config config2 origin id).
  rewrite Hobs', add_In, In_singleton in Hin. tauto. }
clear Hobs Hobs' Hvalid1 Hvalid2.
Time repeat destruct_match; rewrite Hconfig in *; try (first [ assert (Heq : pt1 == pt1' /\ pt2 == pt2')
               by (destruct Hperm as [? | [Heq1 Heq2]]; trivial; [];
                   rewrite Heq1, Heq2 in *;
                   split; transitivity (get_location (config2 (Good g0))); auto)
           | assert (Heq : pt1 == pt2' /\ pt2 == pt1')
               by (destruct Hperm as [[Heq1 Heq2] | ?]; trivial; [];
                   rewrite Heq1, Heq2 in *;
                   split; transitivity (get_location (config2 (Good g0))); auto) ];
     destruct Heq as [Heq1 Heq2]; rewrite Heq1, Heq2 in *;
     (now apply Hb_g0) || (now apply Hb) || contradiction); [|].
- assert (Heq : pt1 == pt1' /\ pt2 == pt2').
  { destruct Hperm as [? | [Heq1 Heq2]]; trivial; [].
    destruct (Hcase2 (Good g0)); rewrite Heq1 in *; contradiction. }
  now apply Hb_g0.
- assert (Heq : pt1 == pt1' /\ pt2 == pt2').
  { destruct Hperm as [? | [Heq1 Heq2]]; trivial; [].
    destruct (Hcase2 (Good g0)); rewrite Heq1 in *; contradiction. }
  now apply Hb.
Qed.

(** General properties about [select_tower] *)
Lemma select_tower_case_1 : forall {A} `{Setoid A} b1 b2 (d : A) config id,
  (forall pt1 pt2 pt1' pt2' (Hdiff : pt1 =/= pt2) (Hdiff' : pt1' =/= pt2'),
     pt1 == pt1' -> pt2 == pt2' -> b1 pt1 pt2 Hdiff == b1 pt1' pt2' Hdiff') ->
  WithMultiplicity.invalid config ->
  get_location (config id) == get_location (config (Good g0)) ->
  exists pt Hdiff, select_tower b1 b2 d config id == b1 (get_location (config (Good g0))) pt Hdiff
                /\ In pt (!! config).
Proof using even_nG.
intros A ? b1 b2 d config id Hb1 ? Hcase.
unfold select_tower.
destruct (invalid_dec config) as [Hvalid | Hvalid].
* destruct (WithMultiplicity.invalid_strengthen (reflexivity 0%nat) Hvalid) as [pt1 [pt2 Hdiff Hobs]].
  repeat destruct_match; try contradiction; [|].
  + assert (Hdiff' : get_location (config (Good g0)) =/= pt2).
    { intro. apply Hdiff. now transitivity (get_location (config (Good g0))). }
    exists pt2, Hdiff'. split.
    - now apply Hb1.
    - rewrite Hobs, add_In, In_singleton. auto.
  + assert (Heq : get_location (config (Good g0)) == pt2).
    { assert (Hin := pos_in_config config origin (Good g0)).
      rewrite Hobs in Hin. rewrite add_In, In_singleton in Hin.
      destruct Hin as [[] | []]; trivial. contradiction. }
    revert_one @complement. intro Hdiff'.
    exists pt1, Hdiff'. split.
    - now apply Hb1.
    - rewrite Hobs, add_In, In_singleton. auto.
* contradiction.
Qed.

(* NB: If we have unicity of inquality proof, we can replace Hdiff with the assumption. *)
Lemma select_tower_case_2 : forall {A} `{Setoid A} b1 b2 (d : A) config id,
  (forall pt1 pt2 pt1' pt2' (Hdiff : pt1 =/= pt2) (Hdiff' : pt1' =/= pt2'),
     pt1 == pt1' -> pt2 == pt2' -> b2 pt1 pt2 Hdiff == b2 pt1' pt2' Hdiff') ->
  WithMultiplicity.invalid config ->
  get_location (config id) =/= get_location (config (Good g0)) ->
  exists Hdiff,
    select_tower b1 b2 d config id == b2 (get_location (config (Good g0))) (get_location (config id)) Hdiff.
Proof using .
intros A ? b1 b2 d config id Hb2 ? Hdiff.
unfold select_tower.
destruct (invalid_dec config) as [Hvalid | Hvalid].
+ destruct (WithMultiplicity.invalid_strengthen (reflexivity 0%nat) Hvalid) as [pt1 [pt2 Hdiff' Hobs']].
  assert (Hcase : get_location (config (Good g0)) == pt1 /\ get_location (config id) == pt2
               \/ get_location (config (Good g0)) == pt2 /\ get_location (config id) == pt1).
  { assert (Hin0 := pos_in_config config origin (Good g0)).
    assert (Hin := pos_in_config config origin id).
    rewrite Hobs', add_In,In_singleton in Hin0, Hin.
    destruct Hin as [[] | []], Hin0 as [[] | []];
    tauto || elim Hdiff; etransitivity; eauto. }
  exists (symmetry Hdiff).
  repeat destruct_match; simpl in *; destruct Hcase as [[] | []];
  unfold Datatypes.id in *;
  try solve [ congruence
        | now apply Hb2; auto
        | elim Hdiff'; transitivity (config (Good g0)); auto ].
+ contradiction.
Qed.

Lemma select_tower_default : forall {A} b1 b2 (d : A) config id,
  ~WithMultiplicity.invalid config -> select_tower b1 b2 d config id = d.
Proof using . intros A b1 b2 d config id Hvalid. unfold select_tower. destruct_match; tauto. Qed.

(** Using [select_tower], we define activation and change of frame. *)
Definition activate2 (b1 b2 : bool) := select_tower (fun _ _ _ => b1) (fun _ _ _ => b2) true.

Instance activate2_compat : forall b1 b2, Proper (equiv ==> eq ==> eq) (activate2 b1 b2).
Proof using even_nG. intros. unfold activate2. now apply select_tower_compat. Qed.

Lemma activate2_spec1 : forall b config id, WithMultiplicity.invalid config ->
  (activate2 b (negb b) config id = b <-> get_location (config id) == get_location (config (Good g0))).
Proof using Hmove even_nG.
intros b config id Hcase. unfold activate2.
destruct (get_location (config id) =?= get_location (config (Good g0))) as [Hloc | Hloc].
+ destruct (select_tower_case_1 (fun (pt1 pt2 : location) (_ : pt1 =/= pt2) => b)
                                (fun (pt1 pt2 : location) (_ : pt1 =/= pt2) => negb b)
                                true id ltac:(reflexivity) Hcase Hloc) as [pt [Hdiff [Heq Hin]]].
  rewrite Heq. tauto.
+ destruct (select_tower_case_2 (fun (pt1 pt2 : location) (_ : pt1 =/= pt2) => b)
                                (fun (pt1 pt2 : location) (_ : pt1 =/= pt2) => negb b)
                                true id ltac:(reflexivity) Hcase Hloc) as [Hdiff Heq].
  rewrite Heq. assert (Habs := Bool.no_fixpoint_negb b). intuition.
Qed.

Lemma activate2_spec2 : forall b config id, WithMultiplicity.invalid config ->
  (activate2 b (negb b) config id = negb b <-> get_location (config id) =/= get_location (config (Good g0))).
Proof using Hmove even_nG.
intros b config id Hinvalid. unfold activate2.
destruct (get_location (config id) =?= get_location (config (Good g0))) as [Hcase | Hcase].
+ destruct (select_tower_case_1 (fun (pt1 pt2 : location) (_ : pt1 =/= pt2) => b)
                                (fun (pt1 pt2 : location) (_ : pt1 =/= pt2) => negb b)
                                true id ltac:(reflexivity) Hinvalid Hcase) as [pt [Hdiff [Heq Hin]]].
  rewrite Heq. assert (Habs := Bool.no_fixpoint_negb b). intuition.
+ destruct (select_tower_case_2 (fun (pt1 pt2 : location) (_ : pt1 =/= pt2) => b)
                                (fun (pt1 pt2 : location) (_ : pt1 =/= pt2) => negb b)
                                true id ltac:(reflexivity) Hinvalid Hcase) as [Hdiff Heq].
  rewrite Heq. tauto.
Qed.

(* [change_frame2] maps the configuration to the canonical one,
   that is, one tower on [origin] and one on [one]. *)
Definition change_frame2 (config : configuration) (g : G) : similarity location :=
  @select_tower (similarity location)
    (fun pt1 pt2 (Hdiff : pt1 =/= pt2) => build_similarity Hdiff (symmetry non_trivial))
    (fun pt1 pt2 (Hdiff : pt1 =/= pt2) => build_similarity Hdiff non_trivial)
    Similarity.id
    config
    (Good g).

Instance change_frame2_compat : Proper (equiv ==> eq ==> equiv) change_frame2.
Proof using build_similarity_compat even_nG.
intros config1 config2 Hconfig g1 g2 Hg. unfold change_frame2.
cut (Good g1 = Good g2); try congruence; [].
generalize (Good g1), (Good g2). revert config1 config2 Hconfig.
apply select_tower_compat; reflexivity || intros; now apply build_similarity_compat.
Qed.

Local Definition Hcompat1 :=
  fun pt1 pt2 pt1' pt2' (Hdiff : pt1 =/= pt2) (Hdiff' : pt1' =/= pt2') Heq1 Heq2 =>
    build_similarity_compat Hdiff (symmetry non_trivial) Hdiff' (symmetry non_trivial)
                            Heq1 Heq2 (reflexivity _) (reflexivity _).

Local Definition Hcompat2 :=
  fun pt1 pt2 pt1' pt2' (Hdiff : pt1 =/= pt2) (Hdiff' : pt1' =/= pt2') Heq1 Heq2 =>
    build_similarity_compat Hdiff non_trivial Hdiff' non_trivial
                            Heq1 Heq2 (reflexivity _) (reflexivity _).

Lemma center_change_frame2 : forall config g, WithMultiplicity.invalid config ->
  Similarity.center (change_frame2 config g) == get_location (config (Good g)).
Proof using build_similarity_compat build_similarity_eq1 build_similarity_eq2 build_similarity_inverse even_nG.
intros config g Hinvalid. unfold change_frame2.
destruct (get_location (config (Good g)) =?= get_location (config (Good g0))) as [Hcase | Hcase].
+ destruct (select_tower_case_1 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                Similarity.id _ Hcompat1 Hinvalid Hcase) as [pt [Hdiff [Heq Hin]]].
  rewrite Heq. unfold Similarity.center.
  rewrite build_similarity_inverse. now rewrite build_similarity_eq1.
+ destruct (select_tower_case_2 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                Similarity.id _ Hcompat2 Hinvalid Hcase) as [Hdiff Heq].
  rewrite Heq. unfold Similarity.center.
  rewrite build_similarity_inverse. now rewrite build_similarity_eq2.
Qed.

Lemma change_frame2_eq : forall config g1 g2, WithMultiplicity.invalid config ->
  get_location (config (Good g1)) == get_location (config (Good g2)) <->
  change_frame2 config g1 == change_frame2 config g2.
Proof using build_similarity_compat build_similarity_eq1 build_similarity_eq2 build_similarity_inverse even_nG.
intros config g1 g2 Hinvalid. split; intro Hg1g2.
* unfold change_frame2.
  destruct (get_location (config (Good g1)) =?= get_location (config (Good g0))) as [Hcase | Hcase].
  + destruct (select_tower_case_1 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                  (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                  Similarity.id _ Hcompat1 Hinvalid Hcase) as [pt [Hdiff [Heq Hin]]].
    rewrite Hg1g2 in Hcase.
    destruct (select_tower_case_1 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                  (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                  Similarity.id _ Hcompat1 Hinvalid Hcase) as [pt' [Hdiff' [Heq' Hin']]].
    rewrite Heq, Heq'. apply Hcompat1; try reflexivity; [].
    apply (WithMultiplicity.invalid_same_location (reflexivity _) Hinvalid (pt3 := get_location (config (Good g0))));
    eauto using pos_in_config; now symmetry.
  + destruct (select_tower_case_2 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                  (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                  Similarity.id _ Hcompat2 Hinvalid Hcase) as [Hdiff Heq].
    rewrite Hg1g2 in Hcase.
    destruct (select_tower_case_2 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                  (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                  Similarity.id _ Hcompat2 Hinvalid Hcase) as [Hdiff' Heq'].
    rewrite Heq, Heq'. apply Hcompat2; auto.
* setoid_rewrite <- center_change_frame2; trivial; [].
  now rewrite Hg1g2.
Qed.

Lemma change_frame2_case : forall config g1, WithMultiplicity.invalid config ->
  get_location (config (Good g1)) =/= get_location (config (Good g0)) ->
  forall g, change_frame2 config g == change_frame2 config g0
         \/ change_frame2 config g == change_frame2 config g1.
Proof using build_similarity_compat even_nG.
intros config g1 Hinvalid Hneq g.
unfold change_frame2.
destruct (select_tower_case_1 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                              (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                              Similarity.id _ Hcompat1 Hinvalid (reflexivity _)) as [pt [Hdiff0 [Heq0 Hin]]].
destruct (select_tower_case_2 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                              (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                              Similarity.id _ Hcompat2 Hinvalid Hneq) as [Hdiff1 Heq1].
rewrite Heq0, Heq1.
destruct (get_location (config (Good g)) =?= get_location (config (Good g0))) as [Hg | Hg].
+ destruct (select_tower_case_1 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                Similarity.id _ Hcompat1 Hinvalid Hg) as [pt' [Hdiff' [Heq ?]]].
  left. rewrite Heq. apply build_similarity_compat; try reflexivity; [].
  apply (WithMultiplicity.invalid_same_location (reflexivity _) Hinvalid (pt3 := get_location (config (Good g0))));
  auto using pos_in_config; now symmetry.
+ destruct (select_tower_case_2 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                Similarity.id _ Hcompat2 Hinvalid Hg) as [Hdiff Heq].
  right. rewrite Heq. apply build_similarity_compat; try reflexivity; [].
  apply (WithMultiplicity.invalid_same_location (reflexivity _) Hinvalid (pt3 := get_location (config (Good g0))));
  auto using pos_in_config; now symmetry.
Qed.

Lemma change_frame2_obs : forall config g, WithMultiplicity.invalid config ->
  !! config == map (change_frame2 config g ⁻¹) observation0.
Proof using build_similarity_compat build_similarity_eq1 build_similarity_eq2 build_similarity_inverse even_nG.
intros config g Hinvalid.
pose (sim := change_frame2 config g). fold sim.
unfold observation0. rewrite map_add, map_singleton; autoclass; [].
assert (Hdiff_sim : sim⁻¹ origin =/= sim⁻¹ one).
{ intro Habs. apply Similarity.injective in Habs. now apply non_trivial. }
destruct (WithMultiplicity.invalid_strengthen (reflexivity _) Hinvalid) as [pt1 [pt2 Hdiff Hobs]].
assert (Hin0 : In (sim⁻¹ origin) (!! config)).
{ change (In (Similarity.center sim) (!! config)).
  unfold sim. rewrite center_change_frame2; auto using pos_in_config. }
assert (Hin1 : In (sim⁻¹ one) (!! config)).
{ unfold sim, change_frame2.
  destruct (get_location (config (Good g)) =?= get_location (config (Good g0))) as [Hcase | Hcase].
  - destruct (select_tower_case_1 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                  (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                  Similarity.id (Good g) Hcompat1 Hinvalid Hcase)
      as [pt [Hpt [Heq Hin]]].
    now rewrite Heq, build_similarity_inverse, build_similarity_eq2.
  - destruct (select_tower_case_2 (fun pt1 pt2 Hdiff => build_similarity Hdiff (symmetry non_trivial))
                                  (fun pt1 pt2 Hdiff => build_similarity Hdiff non_trivial)
                                  Similarity.id (Good g) Hcompat2 Hinvalid Hcase)
      as [Hpt Heq].
    rewrite Heq, build_similarity_inverse, build_similarity_eq1.
    apply pos_in_config. }
intro pt. rewrite Hobs, 2 add_spec, 2 singleton_spec.
repeat destruct_match;
solve [ lia
      | elim Hdiff; transitivity pt; eauto
      | elim Hdiff_sim; transitivity pt; eauto
      | elim Hdiff_sim;
        apply (WithMultiplicity.invalid_same_location (reflexivity _) Hinvalid (pt3 := pt)); auto; try (now symmetry); [];
        rewrite Hobs, add_In, In_singleton; auto
      | rewrite Hobs, add_In, In_singleton in Hin0, Hin1;
        unfold complement in *;
        destruct Hin0 as [[Hin0 _] | [Hin0 _]], Hin1 as [[Hin1 _] | [Hin1 _]];
        rewrite <- Hin0, <- Hin1 in *; contradiction ].
Qed.

(** Definition of the alternating frame changes. *)
Definition da2_left config : demonic_action := {|
  activate := activate2 true false config;
  relocate_byz := fun _ _ => mk_info origin;
  change_frame := change_frame2;
  choose_update := fun _ _ _ => tt;
  choose_inactive := fun _ _ => tt;

  precondition_satisfied := fun _ _ => I;
  precondition_satisfied_inv := fun _ _ => I;

  activate_compat := activate2_compat _ _ (reflexivity _);
  relocate_byz_compat := ltac:(now repeat intro);
  change_frame_compat := change_frame2_compat;
  choose_update_compat := ltac:(now repeat intro);
  choose_inactive_compat := ltac:(now repeat intro) |}.

Definition da2_right config : demonic_action := {|
  activate := activate2 false true config;
  relocate_byz := fun _ _ => mk_info origin;
  change_frame := change_frame2;
  choose_update := fun _ _ _ => tt;
  choose_inactive := fun _ _ => tt;

  precondition_satisfied := fun _ _ => I;
  precondition_satisfied_inv := fun _ _ => I;

  activate_compat := ltac:(now repeat intro; subst);
  relocate_byz_compat := ltac:(now repeat intro);
  change_frame_compat := change_frame2_compat;
  choose_update_compat := ltac:(now repeat intro);
  choose_inactive_compat := ltac:(now repeat intro) |}.

Lemma round_simplify2_left : forall config,
  !! config == map ((change_frame2 config g0)⁻¹) observation0 ->
  round r (da2_left config) config
  == fun id => match id with
                 | Good g => mk_info (if get_location (config (Good g)) =?= (change_frame2 config g0)⁻¹ origin
                                      then (change_frame2 config g)⁻¹ move else get_location (config (Good g)))
                 | Byz b => mk_info origin
               end.
Proof using Hmove build_similarity_eq1 build_similarity_eq2 build_similarity_inverse.
intros config Hobs.
apply no_byz_eq. intro g.
rewrite mk_info_get_location.
unfold round. cbn -[equiv equiv_dec get_location map_config lift inverse].
assert (Hinvalid := invalid_reverse _ _ Hobs).
assert (Hsim0 := center_change_frame2 g0 Hinvalid). unfold Similarity.center in Hsim0.
pose (sim := change_frame2 config g0). fold sim in Hsim0, Hobs.
destruct_match_eq Hcase.
* (* The robot is on the first tower so it moves like g0. *)
  rewrite activate2_spec1 in Hcase; trivial; [].
  assert (Hsim := proj1 (change_frame2_eq _ _ Hinvalid) Hcase).
  rewrite get_location_lift. cbn [projT1].
  assert (Hsimg : get_location (config (Good g)) == sim⁻¹ origin) by (etransitivity; eauto).
  destruct_match; try contradiction; [].
  f_equiv.
  change get_location with (@id location). unfold id.
  rewrite <- (obs_from_config_map (St := Info) (f := change_frame2 config g) _ I config).
  rewrite obs_from_config_ignore_snd, Hobs, map_merge; autoclass; [].
  rewrite (map_extensionality_compat (f := id)), map_id; autoclass; [].
  intro x. rewrite Hsim. fold sim. apply Similarity.compose_inverse_r.
* (* The robot is on the second tower so it does not move. *)
  rewrite activate2_spec2 in Hcase; trivial; [].
  fold sim.
  destruct_match; reflexivity || now elim Hcase; etransitivity; eauto.
Qed.

Lemma invalid_da2_left_next : forall config,
  WithMultiplicity.invalid config -> WithMultiplicity.invalid (round r (da2_left config) config).
Proof using Hmove build_similarity_eq1 build_similarity_eq2 build_similarity_inverse.
intros config Hinvalid.
pose (sim := change_frame2 config g0).
assert (Hdiff_move : sim⁻¹ move =/= sim⁻¹ one).
{ intro Heq. now apply Similarity.injective in Heq. }
assert (Hobs := change_frame2_obs g0 Hinvalid). fold sim in Hobs.
(* sim' maps the canonical config to the next round one *)
pose (sim' := build_similarity (symmetry non_trivial) Hdiff_move).
apply (invalid_reverse sim').
assert (Hconfig : round r (da2_left config) config
                  == map_config (lift (existT precondition (sim' ∘ sim) I)) config).
{ rewrite round_simplify2_left; auto; [].
  apply no_byz_eq. intro g. fold sim.
  cbn [map_config]. rewrite mk_info_get_location, get_location_lift.
  destruct (get_location (config (Good g)) =?= sim⁻¹ origin) as [Heq | Heq].
  + rewrite Heq. cbn -[equiv sim']. rewrite Bijection.section_retraction.
    change ((sim ⁻¹) 0%VS) with (Similarity.center sim) in Heq. unfold sim in Heq.
    rewrite center_change_frame2, change_frame2_eq in Heq; trivial; [].
    rewrite Heq. unfold sim'. now rewrite build_similarity_eq1.
  + assert (Heq' : get_location (config (Good g)) == (sim ⁻¹) one).
    { apply (WithMultiplicity.invalid_same_location (reflexivity _) Hinvalid (pt3 := (sim ⁻¹) origin)).
      - apply pos_in_config.
      - rewrite Hobs. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass.
      - rewrite Hobs. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass.
      - assumption.
      - intro Habs. apply Similarity.injective in Habs. now apply non_trivial. }
    rewrite Heq'. cbn -[equiv sim']. rewrite Bijection.section_retraction.
    unfold sim'. now rewrite build_similarity_eq2. }
rewrite Hconfig.
rewrite obs_from_config_ignore_snd, <- obs_from_config_map, Hobs; [| now autoclass].
rewrite map_merge; autoclass; [].
apply map_extensionality_compat; autoclass; [].
intro. cbn -[equiv sim']. now rewrite Bijection.section_retraction.
Qed.

Lemma da2_left_injective : forall config, WithMultiplicity.invalid config -> forall id1 id2,
  get_location (round r (da2_left config) config id1) == get_location (round r (da2_left config) config id2)
  <-> get_location (config id1) == get_location (config id2).
Proof using Hmove build_similarity_eq1 build_similarity_eq2 build_similarity_inverse.
intros config Hinvalid id1 id2.
pattern id2. apply no_byz. pattern id1. apply no_byz. clear id1 id2. intros g1 g2.
assert (Hobs := change_frame2_obs g0 Hinvalid).
pose (sim := change_frame2 config g0). fold sim in Hobs.
rewrite (round_simplify2_left config Hobs (Good g1)),
        (round_simplify2_left config Hobs (Good g2)).
rewrite 2 mk_info_get_location. fold sim.
do 2 destruct_match.
+ split; intro Heq.
  - etransitivity; eauto.
  - rewrite change_frame2_eq in Heq; trivial; []. now rewrite Heq.
+ revert_one equiv. intro Heq1. rewrite Heq1.
  change ((sim ⁻¹) 0%VS) with (Similarity.center sim) in Heq1.
  unfold sim in Heq1. rewrite center_change_frame2, change_frame2_eq in Heq1; trivial; [].
  assert (Heq2 : get_location (config (Good g2)) == (sim ⁻¹) one).
  { assert (Hin := pos_in_config config origin (Good g2)).
    rewrite Hobs in Hin. unfold observation0 in Hin.
    rewrite map_add, map_singleton, add_In, In_singleton in Hin; autoclass; [].
    now destruct Hin as [[] | []]. }
  rewrite Heq2, Heq1. fold sim.
  split; intro Heq; apply Similarity.injective in Heq; contradiction || now elim non_trivial.
+ revert_one equiv. intro Heq2. rewrite Heq2.
  change ((sim ⁻¹) 0%VS) with (Similarity.center sim) in Heq2.
  unfold sim in Heq2. rewrite center_change_frame2, change_frame2_eq in Heq2; trivial; [].
  assert (Heq1 : get_location (config (Good g1)) == (sim ⁻¹) one).
  { assert (Hin := pos_in_config config origin (Good g1)).
    rewrite Hobs in Hin. unfold observation0 in Hin.
    rewrite map_add, map_singleton, add_In, In_singleton in Hin; autoclass; [].
    now destruct Hin as [[] | []]. }
  rewrite Heq2, Heq1. fold sim.
  split; intro Heq; apply Similarity.injective in Heq; (now symmetry in Heq) || now elim non_trivial.
+ split; intro; solve [ etransitivity; eauto ].
Qed.

Lemma round_simplify2_right : forall config,
  !! config == map (change_frame2 config g0 ⁻¹) observation0 ->
  round r (da2_right config) config
  == fun id => match id with
                 | Good g => mk_info (if get_location (config (Good g)) =?= (change_frame2 config g0)⁻¹ origin
                                      then get_location (config (Good g)) else (change_frame2 config g)⁻¹ move)
                 | Byz b => mk_info 0%VS
               end.
Proof using Hmove build_similarity_eq1 build_similarity_eq2 build_similarity_inverse.
intros config Hobs.
apply no_byz_eq. intro g.
rewrite mk_info_get_location.
pose (sim := change_frame2 config g0). fold sim in Hobs |- *.
unfold round. cbn -[equiv_dec get_location map_config lift inverse].
assert (Hinvalid := invalid_reverse _ _ Hobs).
destruct_match_eq Hcase.
* (* The robot is on the second tower. *)
  assert (Hsim0 : get_location (config (Good g)) == sim⁻¹ one).
  { assert (Hin := pos_in_config config origin (Good g)).
    rewrite Hobs in Hin. unfold observation0 in Hin.
    rewrite map_add, map_singleton, add_In, In_singleton in Hin; autoclass; [].
    destruct Hin as [[] | []]; trivial; [].
    rewrite activate2_spec2 in Hcase; trivial; [].
    elim Hcase. etransitivity; eauto; []. now apply center_change_frame2. }
  rewrite (obs_from_config_ignore_snd origin).
  assert (Hobs' : observation0 == map (change_frame2 config g) (!! config)).
  { rewrite <- map_id. Time change id with (Bijection.section Similarity.id).
    rewrite <- (map_extensionality_compat _ _ (Similarity.compose_inverse_r (change_frame2 config g))).
    rewrite (change_frame2_obs g Hinvalid), map_merge; autoclass. }
  rewrite obs_from_config_ignore_snd, <- obs_from_config_map, <- Hobs'; autoclass; [].
  destruct_match; try reflexivity; [].
  fold move. rewrite Hsim0 in *. elim non_trivial. eapply Similarity.injective; eauto.
* (* The robot is on the first tower so it does not move. *)
  destruct_match; try reflexivity; [].
  exfalso. revert_one equiv. intro Heq.
  rewrite activate2_spec1 in Hcase; trivial; []. contradict Hcase.
  now rewrite <- (center_change_frame2 g0).
Qed.

Lemma invalid_da2_right_next : forall config,
  WithMultiplicity.invalid config -> WithMultiplicity.invalid (round r (da2_right config) config).
Proof using Hmove build_similarity_eq1 build_similarity_eq2 build_similarity_inverse.
intros config Hinvalid.
pose (sim0 := change_frame2 config g0).
assert (Hobs0 := change_frame2_obs g0 Hinvalid). fold sim0 in Hobs0.
(* Let us name a robot g1 on the second tower (the one that g0 is not on) and use its frame change
   to build the similarity that maps the canonical configuration to the next one. *)
assert (Hin : In ((sim0 ⁻¹) one) (!! config)).
{ rewrite Hobs0. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass. }
rewrite obs_from_config_In in Hin. destruct Hin as [[g1 | []] Hg1]; try lia; [].
pose (sim1 := change_frame2 config g1).
assert (Hdiff : get_location (config (Good g0)) =/= get_location (config (Good g1))).
{ rewrite Hg1, <- center_change_frame2; trivial; [].
  unfold Similarity.center. fold sim0. intro Habs.
  apply Similarity.injective in Habs. now apply non_trivial. }
assert (Hobs1 := change_frame2_obs g1 Hinvalid). fold sim1 in Hobs1.
assert (Hg0 : get_location (config (Good g0)) == (sim1 ⁻¹) one).
{ apply (WithMultiplicity.invalid_same_location (reflexivity _) Hinvalid (pt3 := (sim1 ⁻¹) 0%VS)).
  - apply pos_in_config.
  - rewrite Hobs1. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass.
  - rewrite Hobs1. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass.
  - change ((sim1 ⁻¹) 0%VS) with (Similarity.center sim1). unfold sim1. now rewrite center_change_frame2.
  - intro Habs. apply Similarity.injective in Habs. now apply non_trivial. }
assert (Hdiff_move0 : sim0⁻¹ move =/= sim0⁻¹ one).
{ intro Heq. now apply Similarity.injective in Heq. }
assert (Hdiff_move1 : sim1⁻¹ move =/= sim1⁻¹ one).
{ intro Heq. now apply Similarity.injective in Heq. }
(* sim' maps the canonical config to the next round one *)
pose (sim' := build_similarity non_trivial Hdiff_move1).
apply (invalid_reverse sim').
assert (Hconfig : round r (da2_right config) config
                  == map_config (lift (existT precondition (sim' ∘ sim0) I)) config).
{ rewrite round_simplify2_right; auto; [].
  apply no_byz_eq. intro g. fold sim0.
  cbn [map_config]. rewrite mk_info_get_location, get_location_lift.
  destruct (get_location (config (Good g)) =?= sim0⁻¹ origin) as [Heq | Heq].
  + rewrite Heq. cbn -[equiv sim']. rewrite Bijection.section_retraction.
    unfold sim'. now rewrite build_similarity_eq2, <- Hg0, <- center_change_frame2.
  + assert (Heq' : get_location (config (Good g)) == (sim0 ⁻¹) one).
    { apply (WithMultiplicity.invalid_same_location (reflexivity _) Hinvalid (pt3 := (sim0 ⁻¹) origin)).
      - apply pos_in_config.
      - rewrite Hobs0. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass.
      - rewrite Hobs0. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass.
      - assumption.
      - intro Habs. apply Similarity.injective in Habs. now apply non_trivial. }
    rewrite Heq'. cbn -[equiv sim']. rewrite Bijection.section_retraction.
    unfold sim'. rewrite build_similarity_eq1.
    rewrite <- Hg1, change_frame2_eq in Heq'; trivial; []. now rewrite Heq'. }
rewrite Hconfig.
rewrite obs_from_config_ignore_snd, <- obs_from_config_map, Hobs0; [| now autoclass].
rewrite map_merge; [| autoclass | autoclass]; [].
apply map_extensionality_compat; autoclass; [].
intro. cbn -[equiv sim']. now rewrite Bijection.section_retraction.
Qed.

Lemma da2_right_injective : forall config, WithMultiplicity.invalid config -> forall g1 g2,
  get_location (round r (da2_right config) config g1) == get_location (round r (da2_right config) config g2)
  <-> get_location (config g1) == get_location (config g2).
Proof using Hmove build_similarity_eq1 build_similarity_eq2 build_similarity_inverse.
intros config Hinvalid id1 id2.
pattern id2. apply no_byz. pattern id1. apply no_byz. clear id1 id2. intros g1 g2.
assert (Hobs0 := change_frame2_obs g0 Hinvalid).
pose (sim0 := change_frame2 config g0). fold sim0 in Hobs0.
rewrite (round_simplify2_right config Hobs0 (Good g1)),
        (round_simplify2_right config Hobs0 (Good g2)).
rewrite 2 mk_info_get_location.
(* Let us name a robot g3 on the second tower (the one that g0 is not on) and use its frame change
   to build the similarity that maps the canonical configuration to the next one. *)
assert (Hin : In ((sim0 ⁻¹) one) (!! config)).
{ rewrite Hobs0. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass. }
rewrite obs_from_config_In in Hin. destruct Hin as [[g3 | []] Hg3]; try lia; [].
pose (sim1 := change_frame2 config g3).
assert (Hdiff : get_location (config (Good g0)) =/= get_location (config (Good g3))).
{ rewrite Hg3, <- center_change_frame2; trivial; [].
  unfold Similarity.center. fold sim0. intro Habs.
  apply Similarity.injective in Habs. now apply non_trivial. }
do 2 destruct_match.
+ reflexivity.
+ revert_one equiv. intro Heq1. rewrite Heq1.
  split; intro Heq.
  - destruct (change_frame2_case g3 Hinvalid (symmetry Hdiff) g2) as [Hcase | Hcase].
    * rewrite <- Hcase. now apply center_change_frame2.
    * change ((change_frame2 config g0 ⁻¹) 0%VS) with (Similarity.center (change_frame2 config g0)).
      rewrite center_change_frame2; trivial; [].
      assert (Habs : (sim0 ⁻¹) 0%VS == (sim1 ⁻¹) one).
      { assert (Hin : In ((sim0 ⁻¹) 0%VS) (!! config)).
        { rewrite Hobs0. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass. }
        rewrite (change_frame2_obs g3 Hinvalid) in Hin. fold sim1 in Hin.
        unfold observation0 in Hin. rewrite map_add, map_singleton, add_In, In_singleton in Hin; autoclass.
        decompose [and or] Hin; trivial; elim Hdiff; []. now rewrite <- 2 center_change_frame2. }
      rewrite Hcase in Heq. fold sim0 sim1 in Heq. rewrite Heq in Habs.
      apply Similarity.injective in Habs. contradiction.
  - symmetry in Heq. contradiction.
+ revert_one equiv. intro Heq2. rewrite Heq2.
  change ((change_frame2 config g0 ⁻¹) 0%VS) with (Similarity.center (change_frame2 config g0)) in Heq2.
  rewrite center_change_frame2, change_frame2_eq in Heq2; trivial; [].
  assert (Heq1 : get_location (config (Good g1)) == (sim0 ⁻¹) one).
  { assert (Hin := pos_in_config config origin (Good g1)).
    rewrite Hobs0 in Hin. unfold observation0 in Hin.
    rewrite map_add, map_singleton, add_In, In_singleton in Hin; autoclass; [].
    now destruct Hin as [[] | []]. }
  rewrite Heq1.
  split; intro Heq; try (apply Similarity.injective in Heq; now elim non_trivial); [].
  destruct (change_frame2_case g3 Hinvalid (symmetry Hdiff) g1) as [Hcase | Hcase].
  * rewrite <- Hcase, <- Heq1. symmetry. now apply center_change_frame2.
  * change ((change_frame2 config g0 ⁻¹) 0%VS) with (Similarity.center (change_frame2 config g0)).
    rewrite center_change_frame2; trivial; [].
    assert (Habs : (sim0 ⁻¹) 0%VS == (sim1 ⁻¹) one).
    { assert (Hin : In ((sim0 ⁻¹) 0%VS) (!! config)).
      { rewrite Hobs0. unfold observation0. rewrite map_add, map_singleton, add_In, In_singleton; autoclass. }
      rewrite (change_frame2_obs g3 Hinvalid) in Hin. unfold observation0 in Hin.
      rewrite map_add, map_singleton, add_In, In_singleton in Hin; autoclass; [].
      decompose [and or] Hin; trivial; elim Hdiff; []. now rewrite <- 2 center_change_frame2. }
      rewrite Hcase in Heq. fold sim0 sim1 in Heq. rewrite <- Heq in Habs.
      apply Similarity.injective in Habs. contradiction.
+ assert (Heq1 : get_location (config (Good g1)) == (sim0 ⁻¹) one).
  { assert (Hin := pos_in_config config origin (Good g1)).
    rewrite Hobs0 in Hin. unfold observation0 in Hin.
    rewrite map_add, map_singleton, add_In, In_singleton in Hin; autoclass; [].
    now destruct Hin as [[] | []]. }
  assert (Heq2 : get_location (config (Good g2)) == (sim0 ⁻¹) one).
  { assert (Hin := pos_in_config config origin (Good g2)).
    rewrite Hobs0 in Hin. unfold observation0 in Hin.
    rewrite map_add, map_singleton, add_In, In_singleton in Hin; autoclass; [].
    now destruct Hin as [[] | []]. }
  rewrite Heq1, Heq2.
  rewrite <- Heq2 in Heq1. rewrite change_frame2_eq in Heq1; trivial; [].
  rewrite Heq1. split; reflexivity.
Qed.

(** A demon alternatively activating the "left" and "right" towers. *)
CoFixpoint bad_demon2 config : demon :=
   Stream.cons (da2_left config)
  (Stream.cons (da2_right (round r (da2_left config) config))
               (bad_demon2 (round r (da2_right (round r (da2_left config) config))
                           (round r (da2_left config) config)))).

Theorem Always_invalid2 : forall config, WithMultiplicity.invalid config ->
  Always_invalid (execute r (bad_demon2 config) config).
Proof using Hmove build_similarity_eq1 build_similarity_eq2 build_similarity_inverse.
cofix differs. intros config Hconfig.
constructor; [| constructor]; cbn.
- (* Inital state *)
  assumption.
- (* State after one step *)
  now apply invalid_da2_left_next.
- (* State after two steps *)
  apply differs. now apply invalid_da2_right_next, invalid_da2_left_next.
Qed.

Theorem kFair_bad_demon2 : forall config, WithMultiplicity.invalid config -> kFair 1 (bad_demon2 config).
Proof using Hmove build_similarity_eq1 build_similarity_eq2 build_similarity_inverse.
cofix fair_demon. intros config Hconfig.
constructor; [| constructor].
* clear fair_demon.
  intros id1 id2. apply (no_byz id2), (no_byz id1). clear id1 id2. intros g1 g2.
  rewrite (Stream.stream_eq (bad_demon2 config)).
  simpl Stream.hd.
  destruct (invalid_dec config) as [Hvalid | Hvalid].
  + assert (Hvalid' := invalid_da2_left_next Hvalid).
    destruct (get_location (config (Good g1)) =?= get_location (config (Good g0))) as [Htower | Htower];
    [| destruct (get_location (config (Good g2)) =?= get_location (config (Good g0))) as [Htower' | Htower']].
    - constructor 1. simpl. unfold activate2, select_tower.
      repeat destruct_match; trivial; contradiction.
    - constructor 2; simpl.
      ++ unfold activate2, select_tower. repeat destruct_match; trivial; contradiction.
      ++ unfold activate2, select_tower. repeat destruct_match; trivial; contradiction.
      ++ constructor 1. simpl. unfold activate2.
         destruct (select_tower_case_2 (fun pt1 pt2 (_ : pt1 =/= pt2) => false)
           (fun pt1 pt2 (_ : pt1 =/= pt2) => true) true (Good g1) ltac:(reflexivity) Hvalid')
           as [Hdiff Hactivate]; trivial; [].
         hnf. now rewrite da2_left_injective.
    - constructor 3; simpl.
      ++ unfold activate2, select_tower. repeat destruct_match; trivial; contradiction.
      ++ unfold activate2, select_tower. repeat destruct_match; trivial; contradiction.
      ++ constructor 1. simpl. unfold activate2.
         destruct (select_tower_case_2 (fun pt1 pt2 (_ : pt1 =/= pt2) => false)
           (fun pt1 pt2 (_ : pt1 =/= pt2) => true) true (Good g1) ltac:(reflexivity) Hvalid')
           as [Hdiff Hactivate]; trivial; [].
         hnf. now rewrite da2_left_injective.
  + constructor 1. simpl.
    unfold activate2. now apply select_tower_default.
* clear fair_demon.
  intros id1 id2. apply (no_byz id2), (no_byz id1). clear id1 id2. intros g1 g2.
  rewrite (Stream.stream_eq (bad_demon2 config)).
  simpl Stream.tl.
  pose (config':= round r (da2_left config) config).
  change (Between (Good g1) (Good g2)
                  (Stream.cons (da2_right config') (bad_demon2 (round r (da2_right config') config'))) 1).
  destruct (invalid_dec config') as [Hvalid | Hvalid].
  + assert (Hvalid' := invalid_da2_right_next Hvalid).
    destruct (get_location (config' (Good g1)) =?= get_location (config' (Good g0))) as [Htower | Htower];
    [destruct (get_location (config' (Good g2)) =?= get_location (config' (Good g0))) as [Htower' | Htower'] |].
    - constructor 3; simpl.
      ++ unfold activate2, select_tower. repeat destruct_match; trivial; contradiction.
      ++ unfold activate2, select_tower. repeat destruct_match; trivial; contradiction.
      ++ constructor 1. simpl. unfold activate2.
         destruct (select_tower_case_1 (fun pt1 pt2 (_ : pt1 =/= pt2) => true)
           (fun pt1 pt2 (_ : pt1 =/= pt2) => false) true (Good g1) ltac:(reflexivity) Hvalid')
           as [pt [Hdiff [Hactivate Hpt]]]; trivial; [].
         now rewrite da2_right_injective.
    - constructor 2; simpl.
      ++ unfold activate2, select_tower. repeat destruct_match; trivial; contradiction.
      ++ unfold activate2, select_tower. repeat destruct_match; trivial; contradiction.
      ++ constructor 1. simpl. unfold activate2.
         destruct (select_tower_case_1 (fun pt1 pt2 (_ : pt1 =/= pt2) => true)
           (fun pt1 pt2 (_ : pt1 =/= pt2) => false) true (Good g1) ltac:(reflexivity) Hvalid')
           as [pt [Hdiff [Hactivate Hpt]]]; trivial; [].
         now rewrite da2_right_injective.
    - constructor 1. simpl. unfold activate2, select_tower.
      repeat destruct_match; trivial; contradiction.
  + constructor 1. simpl.
    unfold activate2. now apply select_tower_default.
* apply fair_demon.
  now apply invalid_da2_right_next, invalid_da2_left_next.
Qed.

End MoveNot1.

(** **  Merging both cases  **)

Definition bad_demon : configuration -> demon.
Proof.
destruct (move =?= one) as [Hmove | Hmove].
- (** Robots exchange positions **)
  exact (fun _ => bad_demon1).
- (** Robots do not exchange positions **)
  exact bad_demon2.
Defined.

Theorem kFair_bad_demon : forall config, WithMultiplicity.invalid config -> kFair 1 (bad_demon config).
Proof using build_similarity_inverse.
intros. unfold bad_demon.
destruct (move =?= one).
- apply kFair_mono with 0%nat. exact kFair_bad_demon1. lia.
- now apply kFair_bad_demon2.
Qed.

Theorem kFair_bad_demon' : forall k config, (k>=1)%nat -> WithMultiplicity.invalid config -> kFair k (bad_demon config).
Proof using build_similarity_inverse.
intros.
eapply kFair_mono with 1%nat.
- apply kFair_bad_demon; auto.
- auto.
Qed.

(** * Final theorem

Given a non empty finite even set [G] and a robogram [r] on ([G]) × ∅,
for any invalid (bivalent) configuration, we can build a 1-fair demon
against which [r] does not solve the gathering problem. *)
Theorem noGathering :
  forall k, (1<=k)%nat ->
  forall config, WithMultiplicity.invalid config ->
  exists d, kFair k d
         /\ ~WillGather (execute r d config).
Proof using build_similarity_compat build_similarity_eq1 build_similarity_eq2 build_similarity_inverse even_nG nG_non_0.
intros k Hk config Hvalid. exists (bad_demon config).
split.
+ now apply kFair_bad_demon'.
+ apply different_no_gathering.
  unfold bad_demon.
  destruct (move =?= one) as [Hmove | Hmove].
  - now apply Always_invalid1.
  - now apply Always_invalid2.
Qed.

(** We can weaken the previous result to only proving that the demon is fair.
    This way, the statement is exactly complementary to the algorithm in InR2/Algorithm.v *)
Theorem noGathering_Fair :
  forall config, WithMultiplicity.invalid config ->
  exists d, Fair d /\ ~WillGather (execute r d config).
Proof using build_similarity_compat build_similarity_eq1 build_similarity_eq2 build_similarity_inverse even_nG nG_non_0.
intros config Hvalid.
destruct (noGathering ltac:(reflexivity) Hvalid) as [d [Hfair HnotGather]].
exists d. split; trivial; [].
eauto using kFair_Fair.
Qed.

End ImpossibilityProof.

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


From Undecidability.L Require Import L_facts.
From Complexity.L.AbstractMachines Require AbstractHeapMachineDef AbstractSubstMachine.
Import AbstractHeapMachineDef.clos_notation.
Import Programs.
Import BinNat.

(** ** Functional definitions of the abstract machines *)

Section SubstMachine.
  Import AbstractSubstMachine.

     (** *** TODO: Size-aware space machine  *)

   Fixpoint substP_keepTrack' m sizeQ P k revQ (akk : Pro) (curSize : N) {struct P} : option Pro:=
    match P with
    | [] => Some (rev akk)
    | t :: P0 =>
      let '(d,Q',k) :=
          match t with
            varT k' => if k' =? k then (sizeQ,None,Some k)
                      else (N.of_nat (sizeT (varT k')),Some t,Some k)
          | appT => (1%N,Some t,Some k)
          | lamT => (1%N,Some t,Some (1 + k))
          | retT => (1%N,Some t,if (k =? 0) then None else (Some (k-1)))
          end
      in
      let curSize : N := (d + curSize)%N in
      if (curSize <=? m)%N
      then let akk := match Q' with
                        None => revQ++akk
                      | Some t => t::akk
                      end
           in
           match k with
             Some k => substP_keepTrack'  m sizeQ P0 k revQ akk curSize
           | None => Some (rev akk)
           end
      else None
          end.

   Lemma substP_keepTrack'_sound m sizeQ P k Q akk curSize R :
     substP_keepTrack' m sizeQ P k (rev Q) akk curSize = Some R ->
     R = rev akk ++ substP P k Q.
   Proof.
     induction P as [|? ? IH]in m,k,akk,R,curSize |-*.
     -cbn. intros [= ->]. eauto using app_nil_r.
     -cbn. all:repeat (let eq := fresh "eq" in destruct _ eqn:eq;try congruence);intros H.
      all:try inv eq.
      all:try (eapply IH in H). all:cbn in *. all:autorewrite with list in *. all:cbn in *.
      all:pose Nat.sub_0_r.
      all:try congruence.
   Qed.

   Local Ltac rev_smpl := repeat (cbn [List.app rev sumn map sizeT] in *;repeat autorewrite with list in * ).

   Lemma substP_keepTrack'_keepsTrack m P k Q akk curSize:
     (curSize + N.of_nat (sizeP (substP P k Q)) <= m)%N
     -> substP_keepTrack' m (N.of_nat (sumn (map sizeT Q))) P k (rev Q) akk curSize
       = Some (rev akk++substP P k Q).
   Proof.
     all:unfold sizeP in *.
     intros H2.
     induction P as [|? ? IH]in H2,m,k,akk,curSize |-*.
     all:cbn - [N.of_nat]in *.
     1:now cbn;rewrite app_nil_r.
     all:repeat (let eq := fresh "eq" in destruct _ eqn:eq;try congruence).
     all:repeat rewrite N.leb_le in *.
     all:repeat rewrite N.leb_gt in *.
     all:repeat rewrite Nat.eqb_eq in *.
     all:repeat rewrite Nat.eqb_neq in *.

     all:try inv eq.
     all:idtac;rev_smpl.
     all:try rewrite ->! Nat.sub_0_r in *.
     1-6:rewrite IH;[rev_smpl;try reflexivity| rev_smpl;try Lia.lia].
     all:try easy.
   Qed.

   Definition substP_keepTrack (m:N) curSize P k Q : option Pro:=
     substP_keepTrack' m (N.of_nat (sumn (map sizeT Q))) P k (rev Q) [] curSize.

   Lemma substP_keepTrack_correct m curSize P k Q :
     (N.of_nat (sizeP (substP P k Q)) + curSize <= m)%N
     -> substP_keepTrack m curSize P k Q = Some (substP P k Q).
   Proof.
     intro.
     unfold substP_keepTrack.
     rewrite substP_keepTrack'_keepsTrack.
     -reflexivity.
     -lia.
   Qed.

   (*** Todo: track size of T,V*)

   Definition sizeTN (t : Tok) : N :=
     match t with
       varT k => 1 + N.of_nat k
     | _ => 1
     end.

   Fixpoint sumNmap' {X} (f: X -> N) A akk :=
     match A with
       [] => akk
     | a::A => sumNmap' f A (f a + akk)%N
     end.

   Definition sumNmap {X} (f: X -> _) A := sumNmap' f A 0%N.

   Definition sizePN P := sumNmap sizeTN P.

   Inductive substStepResult : Set :=
    EnoughSpace (x:list Pro * list Pro)
   | SpaceBoundReached.

   Definition substStep m '(T,V) : option substStepResult:=
     match T,V with
       (lamT::P)::T,_ =>
       match jumpTarget 0 [] P with
         Some (Q,P') => Some (EnoughSpace (tc P' T, Q :: V))
       | _ => None
       end
     | (appT :: P) :: T, Q :: R :: V =>
       let T:= tc P T in
       let curSize := (sumNmap sizePN T + sumNmap sizePN V)%N in
       match substP_keepTrack m curSize R 0 (lamT :: Q ++ [retT]) with
       | Some R' => Some (EnoughSpace (R' :: tc P T, V))
       | None => Some SpaceBoundReached
       end
     | _,_ => None
     end.

End SubstMachine.

Section HeapMachine.

  Import AbstractHeapMachineDef.
  Definition heapStep '(T,V,H) : option (list task * list clos * list heapEntry) :=
    match T with
    | closT (lam s, a) :: T =>
      Some (T, (s,a)::V, H)
    | appT :: T =>
      match V with
        g :: (s, b) :: V =>
        let '(H',c) := put H (heapEntryC g b) in
        Some (closT (s, c) :: T, V, H')
      | _ => None
      end
    | closT (var x, a) :: T =>
      match lookup H a x with
      | Some g => Some (T, g :: V, H)
      | _ => None
      end
    | closT (app s t, a) :: T =>
      Some (closT (s, a) :: closT (t, a) :: appT :: T, V,H)
    | [] => None
    end.

  Tactic Notation "destruct" "*" "eqn" :=
    let E := fresh "eq" in destruct * eqn:E.

  Lemma heapStep_sound: computesRel heapStep AbstractHeapMachineDef.step.
  Proof.
    intros x. unfold heapStep.
    repeat (destruct * eqn;subst;
            try match goal with
                  H : Some _ = Some _ |- _ => inv H
                | H : (_,_) = (_,_) |- _ => inv H
                | H : _ :: _ = _ :: _ |- _ => inv H
                | H : closT _ = closT _ |- _ => inv H
                | H : lam _ = lam _ |- _ => inv H

                end;
            eauto using AbstractHeapMachineDef.step).
    all:intros ? R'. all:inv R'. all:congruence.
  Qed.

End HeapMachine.


Require Import List.
Import ListNotations.
Require Import String.

Require Import Cryptol.Coqlib.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.AST.
Require Import Cryptol.Semantics.
Require Import Cryptol.Utils.
Require Import Cryptol.Builtins.
Require Import Cryptol.BuiltinSem.
Require Import Cryptol.Values.
Require Import Cryptol.Bitstream.

Require Import Cryptol.EvalTac.
Require Import Cryptol.Eager.

Import HaskellListNotations.
Open Scope string.
Require Import HMAC.HMAC_lib.

Require Import otp.OTP_cryptol.

Fixpoint xor_ext (l1 l2 : list ext_val) : option (list ext_val) :=
  match l1 with
  | (ebit x :: xs) => match l2 with
       | (ebit y :: ys) => match (xor_ext xs ys) with
             | Some bs => Some ((ebit (xorb x y)) :: bs)
             | _ => None
             end
       | [] => Some []
       | _ => None
       end
  | [] => Some []
  | _ => None
  end.

Definition xor_ext' (x y : ext_val) : ext_val :=
  match x with
  | eseq l1 => match y with
    | eseq l2 => match xor_ext l1 l2 with
       | Some bs => eseq bs
       | _ => ebit false
       end
    | _ => ebit false
    end
  | _ => ebit false
  end.

Definition otp_encrypt (key msg : ext_val) : ext_val :=
  xor_ext' key msg.

Lemma length_cons : forall {A : Type} n x (xs : list A),
  Datatypes.length xs = n <->
  Datatypes.length (x::xs) = S n.
Proof.
  split.
  - destruct n; intros.
    + rewrite length_zero_iff_nil in H. subst. simpl. reflexivity.
    + inversion H. simpl. reflexivity.
  - intros. inversion H. reflexivity.
Qed.

Lemma bool_destr : forall (b: bool),
    (if b then true else false) = b.
Proof.
  destruct b; auto.
Qed.

Theorem otp_equiv :
  forall key msg,
    (* key is the right type *)
    has_type key byte ->
    (* msg is the right type *)
    has_type msg byte ->
    (* applying the encrypt function to the key and value gives the model *)
    eager_eval_expr ge tempty sempty
                    (EApp (EApp (EVar encrypt) (EValue key)) (EValue msg))
                    (to_sval (otp_encrypt key msg)).
Proof.
  intros.
  (* break apart bytes into elements *)
  inversion H. do 9 (destruct l; simpl in H1; try omega).
  inversion H0. do 9 (destruct l; simpl in H5; try omega).
  subst.
  (* each element is a bit *)
  repeat match goal with
         | [ H : Forall _ _ |- _ ] => inversion H; clear H
         end;
    repeat match goal with
           | [ H : has_type _ tbit |- _ ] => inversion H; clear H
           end;
    subst.

  (* evaluate the function *)
  e. e. g. e. e. e. e. e. e. e.
  g.
  e. e. lv. e. lv. e.
  lv. lv.
  simpl. unfold xorb.
  repeat rewrite bool_destr.
  reflexivity.
Qed.


(** Univalent FOLDS

    Benedikt Ahrens, following notes by Michael Shulman

Contents of this file:

  - Definition of type of isomorphism [folds_iso a b] in a FOLDS precategory
    - consists of two families of isos and an iso, see [folds_iso_data]
      - [ϕ₁ : ∏ x, x ⇒ a → x ⇒ b]
      - [ϕ₂ : ∏ z, a ⇒ z → b ⇒ z]
      - [ϕ∙ :      a ⇒ a → b ⇒ b]
    - and a number of logical equivalences, see [folds_iso_prop]
  - Some lemmas expressing naturality of maps [ϕX]
  - Components [ϕ₂] and [ϕ∙] are determined by [ϕ₁]
    - [ϕ₂_determined]
    - [ϕo_determined]
  - Identity isomorphim [id_folds_iso], inverse [inv_folds_iso] and composition
  - Map [folds_iso_from_iso] associating to any FOLDS precat isomorphism
    an isomorphism in the corresponding precategory à la RezkCompletion
  - Map [iso_from_folds_iso] doing the converse, still departing from a FOLDS precategory
  - Lemma: [folds_iso_from_iso] and [iso_from_folds_iso] are inverse to each other

*)

Require Import UniMath.Folds.UnicodeNotations.

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.UnivalenceAxiom.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.

Require Import UniMath.Folds.folds_precat.
Require Import UniMath.Folds.from_precats_to_folds_and_back.

Local Notation "a ⇒ b" := (folds_morphisms a b).

(** * Definition of FOLDS precat isomorphisms **)

Section folds_iso_def.

Variable C : folds_precat.

Local Notation C':= (precat_from_folds_precat C).
Local Notation "f □ g" := (compose (C:=C') f g) (at level 40, no associativity).
Local Notation "'id' a" := (identity (C:=C') a) (at level 30).

Definition folds_iso_data (a b : C) : UU :=
  ((∏ (x : C), (x ⇒ a) ≃ (x ⇒ b))
 × (∏ (z : C), (a ⇒ z) ≃ (b ⇒ z)))
×             ((a ⇒ a) ≃ (b ⇒ b)).

Definition ϕ₁ {a b : C} (f : folds_iso_data a b) {x : C} : (x ⇒ a) ≃ (x ⇒ b) :=
      pr1 (pr1 f) x.
Definition ϕ₂ {a b : C} (f : folds_iso_data a b) {z : C} : (a ⇒ z) ≃ (b ⇒ z) :=
      pr2 (pr1 f) z.
Definition ϕo {a b : C} (f : folds_iso_data a b) : (a ⇒ a) ≃ (b ⇒ b) :=
      pr2 f.
Notation "ϕ∙" := ϕo. (* works as a notation, but not as an identifier *)

Definition folds_iso_prop {a b : C} (i : folds_iso_data a b) : UU :=
  ((((∏ (x y : C) (f : x ⇒ y) (g : y ⇒ a) (h : x ⇒ a), T f g h ≃ T f ((ϕ₁ i) g) ((ϕ₁ i) h))
   × (∏ (x z : C) (f : x ⇒ a) (g : a ⇒ z) (h : x ⇒ z), T f g h ≃ T ((ϕ₁ i) f) ((ϕ₂ i) g) h))
   × (∏ (z w : C) (f : a ⇒ z) (g : z ⇒ w) (h : a ⇒ w), T f g h ≃ T ((ϕ₂ i) f) g ((ϕ₂ i) h)))
 × (((∏ (x : C) (f : x ⇒ a) (g : a ⇒ a) (h : x ⇒ a),   T f g h ≃ T ((ϕ₁ i) f) ((ϕo i) g) ((ϕ₁ i) h))
   × (∏ (x : C) (f : a ⇒ x) (g : x ⇒ a) (h : a ⇒ a),   T f g h ≃ T ((ϕ₂ i) f) ((ϕ₁ i) g) ((ϕ∙ i) h)))
  × ((∏ (x : C) (f : a ⇒ a) (g h : a ⇒ x),             T f g h ≃ T ((ϕ∙ i) f) ((ϕ₂ i) g) ((ϕ₂ i) h))
   × (∏ f g h : a ⇒ a,                                 T f g h ≃ T ((ϕ∙ i) f) ((ϕ∙ i) g) ((ϕ∙ i) h)))))
   × (∏ f : a ⇒ a,                                     I f ≃ I ((ϕ∙ i) f)).

Definition isaprop_folds_iso_prop (a b : C) (i : folds_iso_data a b) : isaprop (folds_iso_prop i).
Proof.
  repeat (apply isapropdirprod);
   repeat (apply impred; intro); apply isapropweqtoprop; apply pr2.
Qed.

Definition folds_iso (a b : C) := ∑ i : folds_iso_data a b, folds_iso_prop i.

Definition folds_iso_data_from_folds_iso {a b : C} : folds_iso a b → folds_iso_data a b
  := λ i, pr1 i.
Coercion folds_iso_data_from_folds_iso : folds_iso >-> folds_iso_data.

Lemma folds_iso_eq {a b : C} (i i' : folds_iso a b) :
  folds_iso_data_from_folds_iso i = folds_iso_data_from_folds_iso i' → i = i'.
Proof.
  intro H.
  apply subtypePath.
  - intro; apply isaprop_folds_iso_prop.
  - assumption.
Qed.

(** * Lemmas about FOLDS isomorphisms *)
(** the families of equivalences constituting a FOLDS isomorphism
are given by composition **)

Section about_folds_isos.

Context {a b : C}.

Section fix_a_folds_iso.

Variable (i : folds_iso a b).

Lemma ϕ₁_is_comp (x : C) (f : x ⇒ a) : ϕ₁ i f = f □ (ϕ₁ i (id _ )).
Proof.
  set (q:=pr1 (pr1 (pr1 (pr1 (pr2 i))))).
  specialize (q _ _ f (id _ ) f).
  set (q':=pr1 q ); clearbody q'.
  assert (H: T f (id a) f).
  { set (H:= pr1 (pr2 (pr1 (pr2 C)))).
    apply H. apply I_func_I. }
  set (q'H:= q' H). clearbody q'H; clear H q' q.
  apply path_to_ctr. assumption.
Qed.

Lemma ϕ₂_is_comp (z : C) (g : a ⇒ z) : ϕ₂ i g = ϕ₂ i (id _ ) □ g.
Proof.
  set (q:=pr2 (pr1 (pr1 (pr2 i)))). simpl in q.
  specialize (q _ _ (id _ ) g g).
  set (q':=pr1 q ); clearbody q'.
  assert (H: T (id a) g g).
  { set (H:= pr2 (pr2 (pr1 (pr2 C)))).
    apply H. apply I_func_I. }
  set (q'H:= q' H). clearbody q'H; clear H q' q.
  apply path_to_ctr. assumption.
Qed.

Lemma ϕ₁_ϕ₂_id : ϕ₁ i (id _ ) □ (ϕ₂ i (id _ )) = id _.
Proof.
  set (q:=pr2 (pr1 (pr1 (pr1 (pr2 i))))). simpl in q.
  specialize (q _ _ (id _ ) (id _ ) (id _ )).
  set (q':=pr1 q ); clearbody q'.
  apply comp_compose2'.
  apply q'.
  apply comp_compose2.
  apply T_I_l.
Qed.

Lemma ϕo_id : ϕ∙ i (id _ ) = id _ .
Proof.
  apply id_identity2'.
  apply (pr2 (pr2 i)).
  apply I_func_I.
Qed.

Lemma ϕ₂_ϕ₁_id: ϕ₂ i (id a) □ ϕ₁ i (id a) = id b.
Proof.
  set (H':= pr2 (pr1 (pr2 (pr1 (pr2 i))))).
  simpl in H'.
  specialize (H' _ (id _ ) (id _ ) (id _ )).
  simpl in H'.
  rewrite <- ϕo_id.
  apply comp_compose2'.
  apply H'.
  apply comp_compose2.
  apply T_I_l.
Qed.

Lemma ϕ₁_ϕ₂_are_inverse : is_inverse_in_precat (C:= C') (ϕ₁ i (id _ )) (ϕ₂ i (id _ )).
Proof.
  split.
  - apply ϕ₁_ϕ₂_id.
  - apply ϕ₂_ϕ₁_id.
Qed.

Lemma ϕo_ϕ₁_ϕ₂ (f : a ⇒ a) : ϕ∙ i f = (ϕ₂ i (id _ ) □ f) □ ϕ₁ i (id _).
Proof.
  set (q:=pr2 (pr1 (pr2 (pr1 (pr2 i))))); simpl in q; clearbody q.
  specialize (q _ f (id _ ) f).
  set (q':=pr1 q). clearbody q'. simpl in q'. clear q.
  match goal with | [_ : ?a → _ |- _ ] => assert a end.
  { apply comp_compose2. apply (@id_right C'). }
  specialize (q' X). clear X.
  set (q:= comp_compose2' q'). clearbody q; clear q'.
  simpl in *.
  change (ϕ∙ i f) with (ϕ∙ (pr1 i) f).
  rewrite <- q. clear q.
  rewrite ϕ₂_is_comp. apply idpath.
Qed.

End fix_a_folds_iso.

(** * A FOLDS isomorphism is determined by the first family of isos **)

Variables i i' : folds_iso a b.

Hypothesis H : ϕ₁ i (id _ ) = ϕ₁ i' (id _ ).

Lemma ϕ₂_determined : ∏ x (f : a ⇒ x) , ϕ₂ i f = ϕ₂ i' f.
Proof.
  intros x f.
  rewrite (ϕ₂_is_comp i).
  rewrite (ϕ₂_is_comp i').
  assert (H': is_inverse_in_precat (C:=C') (ϕ₁ i (id _ )) (ϕ₂ i' (id _ ))).
  { split.
    - rewrite H. apply ϕ₁_ϕ₂_id.
    - rewrite H. apply ϕ₂_ϕ₁_id. }
  assert (X : ϕ₂ i (id _ ) = ϕ₂ i' (id _ )).
  { set (H1:= inverse_unique_precat _ _  _ _  _ (ϕ₁_ϕ₂_are_inverse i) H').
    assumption.
  }
  rewrite X.
  apply idpath.
Qed.

Lemma ϕo_determined : ∏ f, ϕ∙ i f = ϕ∙ i' f.
Proof.
  intro f.
  do 2 rewrite ϕo_ϕ₁_ϕ₂.
  rewrite ϕ₂_determined.
  rewrite H.
  apply idpath.
Qed.

Lemma folds_iso_equal : i = i'.
Proof.
  apply folds_iso_eq.
  apply dirprodeq.
  - apply dirprodeq.
    + apply funextsec; intro.
      apply subtypePath.
      * intro. apply isapropisweq.
      * apply funextfun; intro f.
        eapply pathscomp0.
        { apply ϕ₁_is_comp. }
        symmetry.
        eapply pathscomp0.
        { apply ϕ₁_is_comp. }
        rewrite H. apply idpath.
    + apply funextsec; intro.
      apply subtypePath.
      * intro; apply isapropisweq.
      * apply funextfun. unfold homot. apply ϕ₂_determined.
  - apply subtypePath.
    { intro. apply isapropisweq. }
    apply funextfun. intro t.
    apply ϕo_determined.
Qed.

End about_folds_isos.

(** * Identity FOLDS isomorphism **)

Definition id_folds_iso_data (a : C) : folds_iso_data a a.
Proof.
  repeat split.
  - intro x. apply idweq.
  - intro z. apply idweq.
  - apply idweq.
Defined.

Lemma id_folds_iso_prop (a : C) : folds_iso_prop (id_folds_iso_data a).
Proof.
  repeat split; intros; apply idweq.
Qed.

Definition id_folds_iso (a : C) : folds_iso a a := tpair _ (id_folds_iso_data a) (id_folds_iso_prop a).

(** * Inverse of a FOLDS isomorphism **)

Section folds_iso_inverse.

Context {a b : C} (i : folds_iso a b).

Definition inv_folds_iso_data : folds_iso_data b a.
Proof.
  repeat split.
  - intro x. exact (invweq (ϕ₁ i)).
  - intro z. exact (invweq (ϕ₂ i)).
  - exact (invweq (ϕ∙ i)).
Defined.

Lemma inv_folds_iso_prop : folds_iso_prop inv_folds_iso_data.
Proof.
  repeat split; intros.
  - simpl. apply invweq.
    set (q:=pr1 (pr1 (pr1 (pr1 (pr2 i))))). clearbody q.
    set (q':= q _ _ f (invmap (ϕ₁ i) g) (invmap (ϕ₁ i) h)).
    repeat rewrite (homotweqinvweq (ϕ₁ i)) in q'.
    apply q'.
  - simpl. apply invweq.
    set (q:=pr2 (pr1 (pr1 (pr1 (pr2 i))))). simpl in q; clearbody q.
    set (q':= q _ _ (invmap (ϕ₁ i) f) (invmap (ϕ₂ i) g) h); clearbody q'.
    repeat rewrite homotweqinvweq in q'.
    apply q'.
  - simpl. apply invweq.
    set (q:= ((pr2 (pr1 (pr1 (pr2 i)))))). clearbody q; simpl in q.
    set (q':= q _ _ (invmap (ϕ₂ i) f) g  (invmap (ϕ₂ i) h) ).
    repeat rewrite homotweqinvweq in q'.
    apply q'.
  - simpl; apply invweq.
    set (q:= pr1 (pr1 (pr2 (pr1 (pr2 i))))). clearbody q; simpl in q.
    set (q':= q _  (invmap (ϕ₁ i) f) (invmap (ϕ∙ i) g) (invmap (ϕ₁ i) h)).
    repeat rewrite homotweqinvweq in q'.
    apply q'.
  - simpl; apply invweq.
    set (q:= pr2 (pr1 (pr2 (pr1 (pr2 i))))). clearbody q; simpl in q.
    set (q':= q _ (invmap (ϕ₂ i) f) (invmap (ϕ₁ i) g) (invmap (ϕ∙ i) h)).
    repeat rewrite homotweqinvweq in q'.
    apply q'.
  - simpl. apply invweq.
    set (q:= pr1 (pr2 (pr2 (pr1 (pr2 i))))). clearbody q; simpl in q.
    specialize (q _ (invmap (ϕ∙ i) f) (invmap (ϕ₂ i) g) (invmap (ϕ₂ i) h)).
    repeat rewrite homotweqinvweq in q.
    apply q.
  - simpl. apply invweq.
    set (q:= pr2 (pr2 (pr2 (pr1 (pr2 i))))). clearbody q; simpl in q.
    specialize (q (invmap (ϕ∙ i) f) (invmap (ϕ∙ i) g) (invmap (ϕ∙ i) h)).
    repeat rewrite homotweqinvweq in q.
    apply q.
  - simpl. apply invweq.
    set (q:= pr2 (pr2 i)). simpl in q; clearbody q.
    specialize (q (invmap (ϕ∙ i) f)).
    rewrite homotweqinvweq in q.
    apply q.
Qed.

Definition inv_folds_iso : folds_iso b a :=
  tpair _ inv_folds_iso_data inv_folds_iso_prop.

End folds_iso_inverse.

(** * Composition of FOLDS isomorphisms **)

Section folds_iso_comp.

Context {a b c : C} (i : folds_iso a b) (i' : folds_iso b c).

Definition folds_iso_comp_data : folds_iso_data a c.
Proof.
  repeat split.
  - intro x; apply (weqcomp (ϕ₁ i) (ϕ₁ i')).
  - intro z; apply (weqcomp (ϕ₂ i) (ϕ₂ i')).
  - apply (weqcomp (ϕ∙ i) (ϕ∙ i')).
Defined.

Lemma folds_iso_comp_prop : folds_iso_prop folds_iso_comp_data.
Proof.
  repeat split.
  - intros. simpl. eapply weqcomp.
    + apply (pr1 (pr1 (pr1 (pr1 (pr2 i))))).
    + apply (pr1 (pr1 (pr1 (pr1 (pr2 i'))))).
  - intros; simpl; eapply weqcomp.
    + apply (pr2 (pr1 (pr1 (pr1 (pr2 i))))).
    + apply (pr2 (pr1 (pr1 (pr1 (pr2 i'))))).
  - intros; simpl; eapply weqcomp.
    + apply (pr2 (pr1 (pr1 (pr2 i)))).
    + apply (pr2 (pr1 (pr1 (pr2 i')))).
  - intros; simpl; eapply weqcomp.
    + apply (pr1 (pr1 (pr2 (pr1 (pr2 i))))).
    + apply (pr1 (pr1 (pr2 (pr1 (pr2 i'))))).
  - intros; simpl; eapply weqcomp.
    + apply (pr2 (pr1 (pr2 (pr1 (pr2 i))))).
    + apply (pr2 (pr1 (pr2 (pr1 (pr2 i'))))).
  - intros; simpl; eapply weqcomp.
    + apply (pr1 (pr2 (pr2 (pr1 (pr2 i))))).
    + apply (pr1 (pr2 (pr2 (pr1 (pr2 i'))))).
  - intros; simpl; eapply weqcomp.
    + apply (pr2 (pr2 (pr2 (pr1 (pr2 i))))).
    + apply (pr2 (pr2 (pr2 (pr1 (pr2 i'))))).
  - intros; simpl; eapply weqcomp.
    + apply (pr2 (pr2 i)).
    + apply (pr2 (pr2 i')).
Qed.

End folds_iso_comp.

(** * From isomorphisms to FOLDS isomorphisms **)

Section from_iso_to_folds_iso.

Variables a b : C.
Variable f : z_iso (C:=C') a b.

Definition folds_iso_data_from_z_iso : folds_iso_data a b :=
  make_dirprod (make_dirprod (z_iso_comp_left_weq f)
                           (z_iso_comp_right_weq (z_iso_inv_from_z_iso f)))
              (z_iso_conjug_weq f).

Lemma folds_iso_data_prop : folds_iso_prop folds_iso_data_from_z_iso.
Proof.
  repeat split; intros.
  - simpl. apply logeqweq.
    + intro H. apply comp_compose2.
      rewrite assoc. set (H2 := comp_compose2' H). rewrite H2.
      apply idpath.
    + intro H. apply comp_compose2.
      set (H2 := comp_compose2' H).
      rewrite assoc in H2.
      eapply post_comp_with_z_iso_is_inj.
      * apply (z_iso_is_inverse_in_precat f).
      * apply H2.
  - simpl. apply logeqweq.
    + intro H. apply comp_compose2.
      apply pathsinv0. eapply pathscomp0.
      * apply (pathsinv0 (comp_compose2' H)).
      * transitivity ((f0 □ (f □ (inv_from_z_iso f))) □ g).
        ** rewrite z_iso_inv_after_z_iso.
           rewrite id_right.
           apply idpath.
        ** repeat rewrite assoc; apply idpath.
    + intro H. apply comp_compose2.
      set (H2 := comp_compose2' H). apply pathsinv0.
      eapply pathscomp0.
      * apply (pathsinv0 H2).
      * transitivity ((f0 □ (f □ (inv_from_z_iso f))) □ g).
        ** repeat rewrite assoc; apply idpath.
        ** rewrite z_iso_inv_after_z_iso. rewrite id_right. apply idpath.
  - simpl. apply logeqweq.
    + intro H. apply comp_compose2.
      rewrite <- assoc. rewrite (comp_compose2' H). apply idpath.
    + intro H. apply comp_compose2.
      set (H2:= comp_compose2' H).
      rewrite <- assoc in H2.
      use (pre_comp_with_z_iso_inv_is_inj f). exact H2.
  - simpl; apply logeqweq.
    + intro H; apply comp_compose2.
      rewrite <- (comp_compose2' H).
      transitivity
          ((f0 □ (f □ (inv_from_z_iso f))) □ (g □ f)).
      * repeat rewrite assoc; apply idpath.
      * rewrite z_iso_inv_after_z_iso. rewrite id_right; apply assoc.
    + intro H; apply comp_compose2.
      set (H2 := comp_compose2' H).
      repeat rewrite assoc in H2.
      use pathscomp0.
      * exact ((f0 □ (f □ (inv_from_z_iso f))) □ g).
      * rewrite z_iso_inv_after_z_iso, id_right; apply idpath.
      * repeat rewrite assoc.
        use (post_comp_with_z_iso_is_inj f).
        exact H2.
  -  simpl; apply logeqweq.
    + intro H. apply comp_compose2.
      repeat rewrite assoc; rewrite assoc4.
      rewrite (comp_compose2' H).
      apply pathsinv0, assoc.
    + intro H; apply comp_compose2.
      set (H2 := comp_compose2' H).
      rewrite <- assoc in H2.
      use (pre_comp_with_z_iso_inv_is_inj f).
      use (post_comp_with_z_iso_is_inj f).
      rewrite assoc. rewrite assoc in H2. rewrite assoc in H2.
      use (pathscomp0 H2). rewrite <- assoc. apply idpath.
  - simpl. apply logeqweq.
    + intro H; apply comp_compose2.
      rewrite <- (comp_compose2' H); clear H.
      repeat rewrite <- assoc. apply maponpaths. repeat rewrite assoc.
      rewrite assoc4, z_iso_inv_after_z_iso, id_right.
      apply idpath.
    + intro H; apply comp_compose2.
      set (H':= comp_compose2' H); generalize H'; clear H' H; intro H.
      repeat rewrite <- assoc in H.
      use (pre_comp_with_z_iso_inv_is_inj f). use (pathscomp0 _ H).
      rewrite (@assoc C' _ _ _ _ f). rewrite z_iso_inv_after_z_iso. rewrite id_left.
      apply idpath.
  - simpl; apply logeqweq.
    + intro H; set (H':=comp_compose2' H); clearbody H'; clear H;
      rename H' into H; rewrite <- H; clear H.
      apply comp_compose2.
      repeat rewrite <- assoc; apply maponpaths; simpl.
      set (H':=@assoc C' _ _ _ _ f0 g f); clearbody H';
      simpl in *. rewrite <- H'; clear H'.
      apply maponpaths. simpl in *.
      repeat rewrite  (@assoc C').
      rewrite z_iso_inv_after_z_iso, id_left;
      apply idpath.
    + intro H; set (H':=comp_compose2' H); clearbody H'; clear H;
      rename H' into H.
      apply comp_compose2.
      repeat rewrite <- assoc in H.
      use (post_comp_with_z_iso_is_inj f). use (pre_comp_with_z_iso_inv_is_inj f).
      use (pathscomp0 _ H). rewrite (@assoc C' _ _ _ _ f). rewrite z_iso_inv_after_z_iso.
      rewrite id_left. rewrite <- assoc. apply idpath.
  - simpl. apply logeqweq.
    + intro H. apply id_identity2.
      rewrite (id_identity2' H). rewrite (@id_left C').
      apply (z_iso_after_z_iso_inv f).
    + intro H. apply id_identity2.
      set (H':=id_identity2' H); clearbody H'; clear H.
      set (H2:=z_iso_inv_to_left _ _ _ f _ _ H'); clearbody H2.
      rewrite id_right in H2.
      transitivity (f □ (inv_from_z_iso f)).
      * apply (z_iso_inv_on_left (C:=C')), pathsinv0, H2.
      * apply (z_iso_inv_after_z_iso (C := C')).
Qed.

Definition folds_iso_from_iso : folds_iso a b := tpair _ _ folds_iso_data_prop.

End from_iso_to_folds_iso.

(** * from FOLDS isomorphism to isomorphism **)

Section from_folds_iso_to_iso.

Variables a b : C.
Variable i : folds_iso a b.

Let i': a ⇒ b := ϕ₁ i (id _ ).
Let i'inv : b ⇒ a := ϕ₂ i (id _ ).

Definition iso_from_folds_iso : z_iso (C:=C') a b.
Proof.
  exists i'.
  exists i'inv.
  apply ϕ₁_ϕ₂_are_inverse.
Defined.

End from_folds_iso_to_iso.

(** * from FOLDS isos to isos and back, and the other way round **)

Section iso_from_folds_from_iso.

Hypothesis (hs: has_homsets C').
Context {a b : C} (i : z_iso (C:=C') a b).

Lemma iso_from_folds_iso_folds_iso_from_iso : iso_from_folds_iso _ _ (folds_iso_from_iso _ _ i) = i.
Proof.
  apply (z_iso_eq(C:=C',,hs)).
  apply (@id_left C').
Qed.

Variable i' : folds_iso a b.

Lemma folds_iso_from_iso_iso_from_folds_iso : folds_iso_from_iso _ _ (iso_from_folds_iso _ _ i') = i'.
Proof.
  apply folds_iso_equal.
  apply (@id_left C').
Qed.

End iso_from_folds_from_iso.

End folds_iso_def.