Inductive cap := iso | trn | ref | box | val | tag.
Inductive ecap := C : cap -> ecap | iso_eph | trn_eph.

Inductive op := read | extract.
Definition adapt (o: op) (λ: ecap) (κ: cap) : option ecap :=
  match o, λ, κ with
  | read, iso_eph, iso => Some iso_eph
  | read, iso_eph, trn => Some iso_eph
  | read, iso_eph, ref => Some iso_eph
  | read, iso_eph, val => Some (C val)
  | read, iso_eph, box => Some (C val)
  | read, iso_eph, tag => Some (C tag)

  | read, C iso, iso => Some (C iso)
  | read, C iso, trn => Some (C iso)
  | read, C iso, ref => Some (C iso)
  | read, C iso, val => Some (C val)
  | read, C iso, box => Some (C val)
  | read, C iso, tag => Some (C tag)

  | read, trn_eph, iso => Some iso_eph
  | read, trn_eph, trn => Some trn_eph
  | read, trn_eph, ref => Some trn_eph
  | read, trn_eph, val => Some (C val)
  | read, trn_eph, box => Some (C val)
  | read, trn_eph, tag => Some (C tag)

  | read, C trn, iso => Some (C iso)
  | read, C trn, trn => Some (C trn)
  | read, C trn, ref => Some (C trn)
  | read, C trn, val => Some (C val)
  | read, C trn, box => Some (C val)
  | read, C trn, tag => Some (C tag)

  | read, C ref, iso => Some (C iso)
  | read, C ref, trn => Some (C trn)
  | read, C ref, ref => Some (C ref)
  | read, C ref, val => Some (C val)
  | read, C ref, box => Some (C box)
  | read, C ref, tag => Some (C tag)

  | read, C val, iso => Some (C val)
  | read, C val, trn => Some (C val)
  | read, C val, ref => Some (C val)
  | read, C val, val => Some (C val)
  | read, C val, box => Some (C val)
  | read, C val, tag => Some (C tag)

  | read, C box, iso => Some (C tag)
  | read, C box, trn => Some (C box)
  | read, C box, ref => Some (C box)
  | read, C box, val => Some (C val)
  | read, C box, box => Some (C box)
  | read, C box, tag => Some (C tag)

  | read, C tag, _ => None

  | extract, iso_eph, iso => Some iso_eph
  | extract, iso_eph, trn => Some iso_eph
  | extract, iso_eph, ref => Some iso_eph
  | extract, iso_eph, val => Some (C val)
  | extract, iso_eph, box => Some (C val)
  | extract, iso_eph, tag => Some (C tag)

  | extract, C iso, iso => Some iso_eph
  | extract, C iso, trn => Some (C val)
  | extract, C iso, ref => Some (C tag)
  | extract, C iso, val => Some (C val)
  | extract, C iso, box => Some (C tag)
  | extract, C iso, tag => Some (C tag)

  | extract, trn_eph, iso => Some iso_eph
  | extract, trn_eph, trn => Some trn_eph
  | extract, trn_eph, ref => Some trn_eph
  | extract, trn_eph, val => Some (C val)
  | extract, trn_eph, box => Some (C val)
  | extract, trn_eph, tag => Some (C tag)

  | extract, C trn, iso => Some iso_eph
  | extract, C trn, trn => Some (C val)
  | extract, C trn, ref => Some (C box)
  | extract, C trn, val => Some (C val)
  | extract, C trn, box => Some (C box)
  | extract, C trn, tag => Some (C tag)

  | extract, C ref, iso => Some iso_eph
  | extract, C ref, trn => Some trn_eph
  | extract, C ref, ref => Some (C ref)
  | extract, C ref, val => Some (C val)
  | extract, C ref, box => Some (C box)
  | extract, C ref, tag => Some (C tag)

  | extract, C val, _ => None
  | extract, C box, _ => None
  | extract, C tag, _ => None
  end.

Definition alias (λ: ecap) :=
  match λ with
  | iso_eph => iso
  | trn_eph => trn
  | C iso => tag
  | C trn => box
  | C ref => ref
  | C val => val
  | C box => box
  | C tag => tag
  end.

Definition unalias (κ: cap) :=
  match κ with
  | iso => iso_eph
  | trn => trn_eph
  | ref => C ref
  | val => C val
  | box => C box
  | tag => C tag
  end.

Inductive compatible : ecap -> ecap -> Prop :=
| compatible_isoe_tag : compatible iso_eph (C tag)

| compatible_trne_tag : compatible trn_eph (C tag)
| compatible_trne_box : compatible trn_eph (C box)

| compatible_iso_tag : compatible (C iso) (C tag)

| compatible_trn_tag : compatible (C trn) (C tag)
| compatible_trn_box : compatible (C trn) (C box)

| compatible_ref_tag : compatible (C ref) (C tag)
| compatible_ref_box : compatible (C ref) (C box)
| compatible_ref_ref : compatible (C ref) (C ref)

| compatible_val_tag : compatible (C val) (C tag)
| compatible_val_box : compatible (C val) (C box)
| compatible_val_val : compatible (C val) (C val)

| compatible_box_tag : compatible (C box) (C tag)
| compatible_box_box : compatible (C box) (C box)
| compatible_box_val : compatible (C box) (C val)
| compatible_box_ref : compatible (C box) (C ref)
| compatible_box_trn : compatible (C box) (C trn)
| compatible_box_trne : compatible (C box) trn_eph

| compatible_tag : forall λ, compatible (C tag) λ
.
Hint Constructors compatible.

Inductive subcap : ecap -> ecap -> Prop :=
| subcap_refl : forall λ, subcap λ λ
| subcap_isoe_iso : subcap iso_eph (C iso)
| subcap_iso_tag : subcap (C iso) (C tag)
| subcap_isoe_trne : subcap iso_eph trn_eph
| subcap_trne_trn : subcap trn_eph (C trn)
| subcap_trne_ref : subcap trn_eph (C ref)
| subcap_trne_val : subcap trn_eph (C val)
| subcap_trn_box : subcap (C trn) (C box)
| subcap_ref_box : subcap (C ref) (C box)
| subcap_val_box : subcap (C val) (C box)
| subcap_box_tag : subcap (C box) (C tag)

| subcap_isoe_trn : subcap iso_eph (C trn)
| subcap_isoe_ref : subcap iso_eph (C ref)
| subcap_isoe_val : subcap iso_eph (C val)
| subcap_isoe_box : subcap iso_eph (C box)
| subcap_isoe_tag : subcap iso_eph (C tag)

| subcap_trne_box : subcap trn_eph (C box)
| subcap_trne_tag : subcap trn_eph (C tag)

| subcap_ref_tag : subcap (C ref) (C tag)
| subcap_val_tag : subcap (C val) (C tag)
| subcap_trn_tag : subcap (C trn) (C tag)
(* | subcap_trans : forall λ λ' λ'', subcap λ λ' -> subcap λ' λ'' -> subcap λ λ'' *)
.
Hint Constructors subcap.

Inductive safe_to_write : ecap -> cap -> Prop :=
| safe_to_write_isoe : forall κ, safe_to_write iso_eph κ
| safe_to_write_trne : forall κ, safe_to_write trn_eph κ
| safe_to_write_ref  : forall κ, safe_to_write (C ref) κ

| safe_to_write_iso_iso : safe_to_write (C iso) iso
| safe_to_write_iso_val : safe_to_write (C iso) val
| safe_to_write_iso_tag : safe_to_write (C iso) tag

| safe_to_write_trn_iso : safe_to_write (C trn) iso
| safe_to_write_trn_trn : safe_to_write (C trn) trn
| safe_to_write_trn_val : safe_to_write (C trn) val
| safe_to_write_trn_tag : safe_to_write (C trn) tag
.
Hint Constructors safe_to_write.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B D /\ (wd_ C D /\ (col_ A B C /\ col_ A B D))))) -> col_ C B D)).
Proof.
  time tac.
Qed.

End FOFProblem.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: RelationalChoice.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** This file axiomatizes the relational form of the axiom of choice *)

Axiom relational_choice :
  forall (A B : Type) (R : A->B->Prop),
   (forall x : A, exists y : B, R x y) ->
     exists R' : A->B->Prop,
       subrelation R' R /\ forall x : A, exists! y : B, R' x y.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Undecidability.Synthetic.Undecidability.

From Undecidability.MinskyMachines
  Require Import ndMM2 ndMM2_undec.

From Undecidability.ILL
  Require Import IMSELL ndMM2_IMSELL.

Local Infix "≤" := (@IMSELL_le _) (at level 70).
Local Notation "u ≰ v" := (~ u ≤ v) (at level 70).
Local Notation U := (@IMSELL_U _).

(* Undecidability of IMSELL3, ie IMSELL with
   3 modalities {a,b,∞} with a,b < ∞ and
   ∞ is the only universal modality *)

Theorem IMSELL_undec (S : IMSELL_sig3) : undecidable (@IMSELL_cf_PROVABILITY3 S).
Proof.
  apply (undecidability_from_reducibility ndMM2_undec).
  now apply ndMM2_IMSELL.reduction.
Qed.

Theorem IMSELL3_undec : undecidable (@IMSELL_cf_PROVABILITY imsell3).
Proof.
  refine (@IMSELL_undec (exist _ imsell3 _)).
  now exists (Some true), (Some false), None.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint even (even_arg0 : natural) : bool
           := match even_arg0 with
              | Zero => true
              | Succ n => negb (even n)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.
Lemma negb_invol: forall b, negb (negb b) = b.
Proof.
   intros.
   induction b.
   - simpl. auto.
   - simpl. auto.
Qed.

Theorem theorem0 : forall (w : lst) (z : lst) (x : natural) (y : natural), eq (even (len (append w z))) (even (len (append w (Cons x (Cons y z))))).
Proof.
   intros.
   induction w.
   - simpl. rewrite IHw. reflexivity.
   - simpl. lfind. Admitted.


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

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

   PACTOLE project

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

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

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

(** *  The Gathering Problem  **)

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

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

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

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

Instance Loc : Location := make_Location R2.
Local Existing Instance R2_VS.
Local Existing Instance R2_ES.
Remove Hints R2_Setoid R2_EqDec : typeclass_instances.

Instance Info : State location := OnlyLocation (fun _ => True).

Lemma no_info : forall x y, get_location x == get_location y -> x == y.
Proof using . now intros. Qed.

(** Robots observe the location of others robots with strong multiplicity. *)
Instance Obs : Observation := set_observation.

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

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

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

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

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

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

Instance InaFun : inactive_function unit := NoChoiceInaFun.

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

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

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

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

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

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

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

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

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

(** Spectra can never be empty as the number of robots is non null. *)
Lemma obs_non_nil : forall config, !! config =/= empty.
Proof using size_G.
intros config Habs.
specialize (Habs (get_location (config (Good g1)))). rewrite empty_spec in Habs.
rewrite <- Habs. apply pos_in_config.
Qed.

Lemma elements_non_nil : forall config, elements (!! config) <> nil.
Proof using size_G. intro. rewrite elements_nil. apply obs_non_nil. Qed.

(* We need to unfold [obs_is_ok] for rewriting *)
Definition obs_from_config_spec : forall (config : configuration) pt,
  In pt (!! config) <-> InA (@equiv _ location_Setoid) pt (List.map get_location (config_list config))
 := fun config => obs_from_config_spec config origin.

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

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

(** The robogram solving the gathering problem in R². *)
Definition ffgatherR2_pgm (s : observation) : @path location location_Setoid :=
  paths_in_R2 (isobarycenter (elements s)).

Instance ffgatherR2_pgm_compat : Proper (equiv ==> equiv) ffgatherR2_pgm.
Proof using .
intros ? ? ?. unfold ffgatherR2_pgm, paths_in_R2.
now apply local_straight_path_compat, isobarycenter_compat, elements_compat.
Qed.

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

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

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

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

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

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

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

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

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

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

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

(** The minimum value 0 is reached only on gathered configurations. *)
Lemma gathered_elements : forall config pt,
  gathered_at pt config <-> PermutationA (@equiv _ location_Setoid) (elements (!! config)) (pt :: nil).
Proof using size_G.
intros config pt.
split; intro H.
* apply NoDupA_equivlistA_PermutationA; autoclass.
  + apply elements_NoDupA.
  + repeat constructor. intro Hin. inv Hin.
  + intro pt'.
    rewrite elements_spec, obs_from_config_spec, map_id, (@config_list_InA _ _ Info).
    split; intro Hin.
    - destruct Hin as [id Hid]. revert Hid. pattern id. apply no_byz. clear id; intros g Hid.
      specialize (H g). rewrite H in Hid. rewrite Hid. now left.
    - inv Hin; try (now rewrite InA_nil in *); [].
      exists (Good g1). now rewrite (H g1).
* intro id.
  assert (Hin : InA equiv (get_location (config (Good id))) (elements (!! config))).
  { simpl get_location. unfold Datatypes.id.
    rewrite elements_spec, obs_from_config_spec, map_id, (@config_list_InA _ _ Info).
    eexists; reflexivity. }
  rewrite H in Hin. now inv Hin.
Qed.

Lemma gathered_measure : forall config, measure config = 0%R <-> exists pt, gathered_at pt config.
Proof using size_G.
intros config. split; intro H.
* unfold measure, max_dist_obs in *.
  assert (Hnil := elements_non_nil config).
  assert (Hdup := elements_NoDupA (!! config)).
  setoid_rewrite gathered_elements.
  induction (elements (!! config)) as [| pt l]; try tauto; [].
  exists pt. destruct l as [| pt' l]; try reflexivity.
  inv Hdup. destruct IHl as [? Hperm]; discriminate || auto.
  + apply antisymmetry.
    - rewrite <- H. apply max_dist_list_list_cons_le.
    - rewrite <- (R2_dist_defined_2 pt'). apply max_dist_list_list_le; now left.
  + assert (l = nil).
    { rewrite <- length_zero_iff_nil.
      cut (length (pt' :: l) = length (x :: nil)); try (simpl; lia).
      f_equiv; eauto. }
    subst. rewrite PermutationA_1 in Hperm; autoclass; [].
    elim H2. left.
    cbn in H. do 2 rewrite R2_dist_defined_2 in H.
    cbn in H. setoid_rewrite (Rmax_comm 0)%R in H. rewrite (Rmax_left 0 0)%R in H; try reflexivity; [].
    rewrite dist_sym in H. repeat (rewrite (Rmax_left (dist pt' pt) 0) in H; try apply dist_nonneg).
    rewrite Rmax_left in H; try reflexivity; [].
    symmetry. now rewrite <- dist_defined.
* destruct H as [pt Hgather]. unfold measure.
  destruct (max_dist_obs_ex (!! config) (elements_non_nil config)) as [pt1 [pt2 [Hpt1 [Hpt2 Heq]]]].
  rewrite <- Heq, dist_defined. rewrite gathered_elements in Hgather. rewrite Hgather in *.
  inv Hpt1; inv Hpt2; try (now rewrite InA_nil in *); [].
  etransitivity; eauto.
Qed.

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

(** Rewriting the [round] function in the global setting. *)
Theorem round_simplify : forall da config, FSYNC_da da ->
  round ffgatherR2 da config
  == fun id => match id with
                 | Byz b => config (Byz b) (* dummy case *)
                 | Good g => let global_trajectory := straight_path (get_location (config (Good g)))
                                                                    (isobarycenter (elements (!! config))) in
                             let choice := da.(choose_update) config g global_trajectory in
                             update config g Similarity.id global_trajectory choice
               end.
Proof.
intros da config Hfsync. rewrite FSYNC_round_simplify; trivial; [].
apply no_byz_eq. intro g. unfold round.
assert (supp_nonempty := elements_non_nil config).
assert (Hda := similarity_center da config g).
remember (change_frame da config g) as sim.
assert (Hsim : Proper (equiv ==> equiv) sim). { intros ? ? Heq. now rewrite Heq. }
Local Opaque lift. Local Opaque map_config.
assert (Hperm : PermutationA equiv (List.map sim (elements (!! config)))
                                   (elements (!! (map_config sim config)))).
{ rewrite <- map_injective_elements, obs_from_config_map, obs_from_config_ignore_snd;
  autoclass; reflexivity || apply Bijection.injective. }
rewrite (obs_from_config_ignore_snd origin).
change (lift (existT _ ?x _)) with x.
change get_location with (@Datatypes.id location). unfold Datatypes.id.
simpl pgm. unfold ffgatherR2_pgm. changeR2.
remember (elements (!! config)) as E.
remember (elements (!! (map_config sim config))) as E'.
Time rewrite <- Hperm, isobarycenter_sim_morph; trivial; [].
assert (Hpath : paths_in_R2 (sim (isobarycenter E))
                == lift_path sim (straight_path (Similarity.center sim) (isobarycenter E))).
{ intro r. cbn [path_f lift_path straight_path paths_in_R2 local_straight_path].
  rewrite sim_add, sim_mul, sim_add, sim_opp. changeR2.
  rewrite Similarity.center_prop, opp_origin, add_origin, add_origin_l.
  simpl; f_equal; simpl; field. }
rewrite lift_update_swap, Hpath.
apply (update_compat
  (map_config (frame_choice_bijection (sim ⁻¹)) (map_config (frame_choice_bijection sim) config))
  config); auto.
+ rewrite <- (map_config_id config) at 2. rewrite map_config_merge.
  - f_equiv. intros x y Hxy. simpl. now rewrite Bijection.retraction_section.
  - auto.
  - simpl. repeat intro. now subst.
+ unfold lift_path; cbn -[straight_path isobarycenter].
  intro. now rewrite Bijection.retraction_section, Hda.
+ (* This should be assumed as a hypothesis *)
Admitted. (* Gathering in FSYNC: round_simplify -> hypothesis missing on the demon *)

(** If possible, the measure decreases by at least delta at each step. *)
(* FIXME: cleanup! *)
Theorem round_lt_config : forall da config,
    delta > 0 ->
    FSYNC_da da ->
    delta <= measure config ->
    measure (round ffgatherR2 da config) <= measure config - delta.
Proof using size_G.
  intros da config Hdelta HFSync Hnotdone.
  set (elems := elements (!! config)).
  set (C := isobarycenter elems).
  remember (elements (!! (round ffgatherR2 da config))) as nxt_elems.

  assert (Hantec: forall KP, InA equiv KP nxt_elems ->
            exists Pid, InA equiv (get_location (config Pid)) elems /\ round ffgatherR2 da config Pid == KP).
  { intros [KP k'] HinKP.
    rewrite Heqnxt_elems, elements_spec, obs_from_config_In in HinKP.
    destruct HinKP as [Pid HPid].
    exists Pid. split; trivial; [].
    unfold elems. rewrite elements_spec, obs_from_config_In.
    now exists Pid. }

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

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

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

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

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

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

(** If the measure is too small, it saturates at 0. *)
Theorem round_last_step : forall da config,
    delta > 0 ->
    FSYNC_da da ->
    measure config <= delta ->
    measure (round ffgatherR2 da config) == 0.
Proof using size_G.
intros da config Hdelta HFSync Hlt.
unfold measure.
set (elems := (elements (!! config))).
set (C := isobarycenter elems).
pose (nxt_elems := elements (!! (round ffgatherR2 da config))).
assert (Hantec : forall KP, InA equiv KP nxt_elems ->
                   exists g, InA equiv (get_location (config (Good g))) elems
                          /\ get_location (round ffgatherR2 da config (Good g)) == KP).
{ intros [KP k'] HinKP.
  unfold nxt_elems in HinKP. rewrite elements_spec, obs_from_config_In in HinKP.
  destruct HinKP as [id Hid].
  destruct id as [g | b]; try (destruct b; lia); [].
  exists g. split; trivial; [].
  unfold elems. rewrite elements_spec, obs_from_config_In.
  now exists (Good g). }
assert (HonlyC: forall KP, InA equiv KP nxt_elems -> KP == C).
{ intros KP HinKP.
  destruct (Hantec KP HinKP) as [g [Hin Hround]].
  rewrite <- Hround in *. clear Hround KP.
  rewrite (round_simplify _ _ HFSync (Good g)).
  cbn zeta.
  edestruct (ratio_spec config g) as [Hupdate | Hupdate]; try rewrite Hupdate.
  + (* valid case: mvt smaller than delta *)
    rewrite straight_path_1. reflexivity.
  + (* mvt at least delta: it is exactly delta *)
    destruct Hupdate as [Hupdate Hle]. rewrite Hupdate in *.
    remember (move_ratio (choose_update da config g
               (straight_path (get_location (config (Good g))) (isobarycenter (elements !! config))))) as r.
    cbn [straight_path path_f] in Hle.
    rewrite <- add_origin in Hle at 1. setoid_rewrite add_comm in Hle.
    rewrite dist_translation in Hle.
    rewrite mul_distr_add, mul_opp, dist_sym, <- R2dist_ref_0, dist_homothecy in Hle.
    assert (0 <= r <= 1) by apply ratio_bounds.
    rewrite Rabs_pos_eq in Hle; try tauto; [].
    assert (Hmeasure : forall p1 p2, InA equiv p1 elems -> InA equiv p2 elems -> dist p1 p2 <= measure config).
    { intros p1 p2 Hin1 Hin2. now apply max_dist_obs_le. }
    assert (Hle' := isobarycenter_dist_decrease elems (measure config) (elements_non_nil config) Hmeasure _ Hin).
    clear Hupdate Heqr Hmeasure. rewrite dist_sym in Hle'.
    assert (Hr : r == ratio_1).
    { apply (Rmult_eq_reg_r delta); try lra; [].
      rewrite Rmult_1_l. apply antisymmetry.
      - rewrite <- Rmult_1_l. apply Rmult_le_compat_r; lra || tauto.
      - rewrite Rmult_1_l in Hle. etransitivity; eauto; [].
        apply Rmult_le_compat_l; try tauto; []. etransitivity; eauto. }
    rewrite Hr. rewrite straight_path_1. reflexivity. }
destruct (max_dist_obs_ex _ (elements_non_nil (round ffgatherR2 da config)))
  as [pt0 [pt1 [Hinpt0 [Hinpt1 Hdist]]]].
rewrite <- Hdist, HonlyC, (HonlyC pt1); try (now subst); [].
now apply dist_defined.
Qed.

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

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

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

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

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

Lemma not_gathered_exists : forall config pt,
  ~ gathered_at pt config -> exists id, ~config id == pt.
Proof.
intros config pt Hgather.
destruct (forallb (fun x => R2dec_bool (config x) pt) names) eqn:Hall.
- elim Hgather. rewrite forallb_forall in Hall.
  intro id'. setoid_rewrite R2dec_bool_true_iff in Hall.
  hnf. repeat rewrite Hall; trivial; apply In_names.
- rewrite <- negb_true_iff, existsb_forallb, existsb_exists in Hall.
  destruct Hall as [id' [_ Hid']].
  rewrite negb_true_iff, R2dec_bool_false_iff in Hid'.
  now exists id'.
Qed.
*)
Lemma gathered_at_elements : forall config pt,
  gathered_at pt config -> PermutationA equiv (elements (!! config)) (pt :: nil).
Proof using size_G.
intros config pt Hgather.
apply NoDupA_equivlistA_PermutationA; autoclass.
+ apply elements_NoDupA.
+ repeat constructor. now rewrite InA_nil.
+ intro x.
  rewrite elements_spec, obs_from_config_spec, map_id, (@config_list_InA _ _ Info).
  split; intro Hin.
  - destruct Hin as [id Hid]. left. rewrite Hid. pattern id. apply no_byz. intro. now rewrite <- Hgather.
  - exists (Good g1). inv Hin; try (now rewrite InA_nil in *); [].
    transitivity pt; trivial; []. symmetry. now rewrite <- Hgather.
Qed.

Lemma gathered_at_forever : forall da config pt, FSYNC_da da ->
  gathered_at pt config -> gathered_at pt (round ffgatherR2 da config).
Proof using size_G.
intros da config pt Hda Hgather g.
rewrite round_simplify; trivial; []. cbn zeta.
rewrite (gathered_at_elements Hgather), isobarycenter_singleton.
rewrite Hgather, update_no_move; autoclass.
Qed.

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

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

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

End GatheringInR2.

(* Prefer not to leave this here, so that make -vos does not fail here.
See FSyncFlexNoMultAlgorithm_Assumptions.v *)
(* Print Assumptions FSGathering_in_R2. *)
(* FIXME: find and eliminate the use of Classical_Prop.classic
          It comes from a bug in intuition/tauto. See set_observation.v. *)


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo72:
  prime  87882427100100997730250576487417->
  prime  53316071460953772812439412794347360011.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      53316071460953772812439412794347360011
      606675
      ((87882427100100997730250576487417,1)::nil)
      0
      500
      5
      25)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Require Import MirrorCore.Lemma.
Require Import MirrorCore.Lambda.Expr.

Section reify_lemma.
  Variables typ func : Set.

  Variable is_forall : expr typ func -> option typ.
  Variable is_impl : expr typ func -> bool.

  Fixpoint get_alls (e : expr typ func)
  : list typ * expr typ func :=
    match e with
    | ExprCore.App f (ExprCore.Abs _ e) =>
      match is_forall f with
      | Some t =>
        let (alls,e) := get_alls e in
        (t :: alls, e)
      | None => (nil, e)
      end
    | _ => (nil, e)
    end.

  Fixpoint get_impls (e : expr typ func)
  : list (expr typ func) * expr typ func :=
    match e with
    | ExprCore.App (ExprCore.App f P) Q =>
      if is_impl f then
        let (impls,e) := get_impls Q in
        (P :: impls,e)
      else
        (nil, e)
    | _ => (nil, e)
    end.

  Definition convert_to_lemma (e : expr typ func)
  : lemma typ (expr typ func) (expr typ func) :=
    let (alls, e) := get_alls e in
    let (impls, e) := get_impls e in
    {| vars := rev alls
     ; premises := impls
     ; concl := e
     |}.
End reify_lemma.

Export MirrorCore.Lemma.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_sel_rfn_top_reduce :
  forall T1 x L Ts1 T1', T1 = (t_rfn_sel x L Ts1 T1') ->
                    forall T2 Ts2, T2 = (t_rfn_top Ts2) ->
                              subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_sel_equ_reduce :
  forall T1 x1 L1 Ts1 T', T1 = (t_rfn_sel x1 L1 Ts1 T') ->
                     forall T2 L2 T2', T2 = t_equ L2 T2' ->
                                  subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import HoTT.Basics HoTT.Types.
Require Import Extensions Limits.Pullback.
Require Import Modality Lex Open Closed Nullification.

Local Open Scope path_scope.

(** * The lex-modal fracture theorem *)

(** The fracture theorem for two modalities [O1] and [O2] and a type [A], when it holds, states that the naturality square

<<
 A   -->   O1 A
 |          |
 |          |
 V          V
O2 A --> O2 (O1 A)
>>

is a pullback.  This says in a certain precise sense that [A] can be recovered from its [O1]- and [O2]-reflections together with some information about how they fit together.  If we think of [O1] and [O2] as subuniverses or subtoposes, then the fracture theorem says that their "union", or more precisely their *gluing*, is the whole universe.

We will prove the fracture theorem holds under the assumptions that [O2] is lex, and that [O1]-connected types are [O2]-modal.  Note that like lex-ness, the latter is also a "large" hypothesis.  But also as with lex-ness, rather than hypothesize it polymorphically with a module type, we just hypothesize it in the obvious way and allow the polymophism of the resulting theorem to be computed automatically.  This actually gives more precise information: the fracture theorem for a particular type [A] only depends on this hypothesis for types [B] lying in the same universe as [A].  (In fact, as we will see, it only needs the special cases of the fibers of [to O1 A], but in examples it seems no harder to verify the general case.)

It may sometimes happen that in addition, the "intersection" of [O1] and [O2] is trivial.  This is naturally expressed in the context of the fracture theorem by saying that [O2]-modal types are [O1]-connected, i.e. the converse of the second hypothesis of our fracture theorem.  When this also holds, we can show that the universe [Type] can actually be reconstructed, up to equivalence, from the universes of [O1]- and [O2]-modal types and the [O2]-reflection from the first to the second, using the "Artin gluing construction" from topos theory.  *)

  (** ** The fracture theorem *)

  Section FractureTheorem.
    Context (O1 O2 : Modality).

    Definition fracture_square (A : Type)
    : O_functor O2 (to O1 A) o to O2 A == to O2 (O1 A) o to O1 A
    := to_O_natural O2 (to O1 A).

    (** Here are the hypotheses of the fracture theorem *)
    Context `{Lex O2}.

    Definition Gluable : Type
      := forall (A : Type), IsConnected O1 A -> In O2 A.
    Context (ino2_isconnectedo1 : Gluable).

    (** The fracture theorem. *)
    Definition ispullback_fracture_square A
    : IsPullback (fracture_square A).
    Proof.
      apply ispullback_symm.
      nrefine (ispullback_connmap_mapino_commsq O2 _).
      1-3:exact _.
      2:rapply mapinO_between_inO.
      intros x; refine (ino2_isconnectedo1 _ _).
    Defined.

    (** ** The fracture gluing theorem *)

    (** We now also assume the converse of the second hyopthesis *)
    Definition Disjoint : Type
      := forall (A : Type), In O2 A -> IsConnected O1 A.
    Context (isconnectedo1_ino2 : Disjoint).

    (** This implies that the universe decomposes into an [O1]-part, an [O2]-part, and a gluing map.  We define these pieces separately in order to make the maps transparent but the homotopies opaque. *)
    Definition fracture_glue_uncurried
    : { B : Type_ O1 & { C : Type_ O2 & C -> O2 B }} -> Type
      := fun BCf => Pullback BCf.2.2 (to O2 BCf.1).

    Definition fracture_glue
      (B C : Type) `{HB: In O1 B} `{HC: In O2 C} (f : C -> O2 B)
    : Type
      := fracture_glue_uncurried ((B;HB);((C;HC);f)).

    Definition fracture_unglue
    : Type -> { B : Type_ O1 & { C : Type_ O2 & C -> O2 B }}
    := fun A => ((O1 A ; O_inO A) ; ((O2 A ; O_inO A) ; O_functor O2 (to O1 A))).

    Definition fracture_unglue_isretr `{Univalence}
               (BCf : { B : Type_ O1 & { C : Type_ O2 & C -> O2 B }})
    : fracture_unglue (fracture_glue_uncurried BCf) = BCf.
    Proof.
      destruct BCf as [B [C f]]; simpl.
      (** The first two components of our path will be applications of univalence.  We begin by observing that maps we will use are equivalences. *)
      assert (IsEquiv (O_rec ((to O2 B)^*' f))).
      { apply isequiv_O_rec_O_inverts.
        apply O_inverts_conn_map, conn_map_pullback'.
        intros ob; apply isconnectedo1_ino2; exact _. }
      assert (IsEquiv (O_rec (f^* (to O2 B)))).
      { apply isequiv_O_rec_O_inverts.
        apply O_inverts_conn_map, conn_map_pullback; exact _. }
      (** Now we start building the path. *)
      simple refine (path_sigma' _ _ _).
      { apply path_TypeO; simpl.
        refine (path_universe (O_rec ((to O2 B)^*' f))). }
      refine (transport_sigma' _ _ @ _); simpl.
      simple refine (path_sigma' _ _ _).
      { apply path_TypeO; simpl.
        refine (path_universe (O_rec (f^* (to O2 B)))). }
      (** It remains to identify the induced function with the given [f].  We begin with some boilerplate. *)
      apply path_arrow; intros c.
      refine (transport_arrow_toconst _ _ _ @ _).
      refine (transport_arrow_fromconst
                (C := fun X:Type_ O1 => O2 X) _ _ _ @ _).
      refine (transport_compose O2 (TypeO_pr1 O1) _ _ @ _).
      refine (transport_compose idmap O2 _ _ @ _).
      (** Now we have to compute through the action of [ap] and [transport] on paths in sigmas and the universe.  In applying these it helps to specify a couple of intermediate steps explicitly. *)
      transitivity (transport idmap
                     (ap O2 (path_universe (O_rec ((to O2 B)^*' f))))
                     (O_functor O2 (to O1 (Pullback f (to O2 B)))
                                ((O_rec (f^* (to O2 B)))^-1 c)));
        [ apply ap11; repeat apply ap
        | transitivity (O_functor O2 (O_rec (to O2 B^*' f))
                          (O_functor O2 (to O1 (Pullback f (to O2 B)))
                                     ((O_rec (f^* (to O2 B)))^-1 c))) ].
      + refine (pr1_path_sigma_uncurried _ @ eisretr pr1 _).
      + refine (transport_compose idmap (TypeO_pr1 O2)
                  (path_TypeO O2 (O2 (Pullback f (to O2 B)); _) C _)^
                  c @ _).
        refine (ap (fun p => transport idmap p c) (ap_V _ _) @ _).
        refine (ap (fun p => transport idmap p^ c)
                   (pr1_path_sigma_uncurried _ @ eisretr pr1 _) @ _).
        refine (transport_path_universe_V _ _).
      + refine (ap (fun p => transport idmap p _)
                   (ap_O_path_universe O2 _) @ _).
        refine (transport_path_universe _ _).
      (** Now we're down to the real point. *)
      + refine ((O_functor_compose O2 _ _ _)^ @ _).
        refine (O_functor_homotopy O2 _ _ (O_rec_beta _) _ @ _).
        revert c; equiv_intro (O_rec (f^* (to O2 B))) x.
        refine (ap _ (eissect _ _) @ _).
        revert x; apply O_indpaths; intros x; simpl.
        refine (to_O_natural O2 _ x @ _); simpl.
        refine (_ @ ap f (O_rec_beta _ _)^).
        destruct x as [a [b q]]; simpl; exact (q^).
    Qed.

    Definition fracture_unglue_issect `{Univalence} (A : Type)
    : fracture_glue_uncurried (fracture_unglue A) = A.
    Proof.
      apply path_universe_uncurried, equiv_inverse.
      exact (Build_Equiv _ _ (pullback_corec (fracture_square A))
                        (ispullback_fracture_square A)).
    Qed.

    Definition isequiv_fracture_unglue `{Univalence}
    : IsEquiv fracture_unglue
      := isequiv_adjointify
           fracture_unglue
           fracture_glue_uncurried
           fracture_unglue_isretr
           fracture_unglue_issect.

    Definition equiv_fracture_unglue `{Univalence}
    : Type <~> { B : Type_ O1 & { C : Type_ O2 & C -> O2 B }}
      := Build_Equiv _ _ fracture_unglue isequiv_fracture_unglue.

  End FractureTheorem.

(** ** The propositional fracture theorem *)

(** An easy example of the lex-modal fracture theorem is supplied by the open and closed modalities for an hprop [U]. *)

Definition gluable_open_closed `{Funext} (U : HProp)
: Gluable (Op U) (Cl U).
Proof.
  intros A.
  change (Contr (U -> A) -> (U -> Contr A)); intros ? u.
  exists (center (U -> A) u); intros a.
  exact (ap10 (path_contr _ (fun _ => a)) u).
Defined.

Definition disjoint_open_closed `{Funext} (U : HProp)
: Disjoint (Op U) (Cl U).
Proof.
  intros A.
  change ((U -> Contr A) -> Contr (U -> A)); intros uc.
  exists (fun u => let i := uc u in center A).
  intros f; apply path_arrow; intros u.
  pose (uc u); apply path_contr.
Defined.

(** We can also prove the same thing without funext if we use the nullification versions of these modalities. *)

Definition gluable_open_closed' (U : HProp)
: Gluable (Op' U) (Cl' U).
Proof.
  intros A ? u; simpl in *.
  pose proof (contr_inhabited_hprop U u).
  assert (Contr A).
  { simple refine (contr_equiv (Op' U A) _).
    - refine (O_rec idmap).
      intros []; simpl.
      apply ooextendable_equiv.
      refine (equiv_isequiv (@equiv_contr_contr U Unit _ _)).
    - refine (isequiv_adjointify _ (to (Op' U) A) _ _).
      + intros a; apply O_rec_beta.
      + intros oa; revert oa; apply O_indpaths; intros a; simpl.
        apply ap. rapply O_rec_beta. }
  apply ooextendable_contr; exact _.
Defined.

Definition disjoint_open_closed' (U : HProp)
: Disjoint (Op' U) (Cl' U).
Proof.
  intros A An.
  apply isconnected_from_elim; intros C Cn f.
  simple refine (@local_rec _ C Cn tt _ tt ; _); simpl.
  - intros u.
    exact (f (@local_rec _ A An u Empty_rec tt)).
  - intros a; simpl.
    refine (@local_indpaths _ C Cn tt (fun _ => f a) _ _ tt);
      intros u; simpl in *.
    refine (_ @ (@local_rec_beta _ C Cn tt _ u)^).
    apply ap.
    exact (@local_indpaths _ A An u (fun _ => a) _ (Empty_ind _) tt).
Defined.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * Typeclass-based setoids, tactics and standard instances.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

(* $Id: SetoidClass.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Set Implicit Arguments.
Unset Strict Implicit.

Generalizable Variables A.

Require Import Coq.Program.Program.

Require Import Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.Morphisms.

(** A setoid wraps an equivalence. *)

Class Setoid A := {
  equiv : relation A ;
  setoid_equiv :> Equivalence equiv }.

(* Too dangerous instance *)
(* Program Instance [ eqa : Equivalence A eqA ] =>  *)
(*   equivalence_setoid : Setoid A := *)
(*   equiv := eqA ; setoid_equiv := eqa. *)

(** Shortcuts to make proof search easier. *)

Definition setoid_refl `(sa : Setoid A) : Reflexive equiv.
Proof. typeclasses eauto. Qed.

Definition setoid_sym `(sa : Setoid A) : Symmetric equiv.
Proof. typeclasses eauto. Qed.

Definition setoid_trans `(sa : Setoid A) : Transitive equiv.
Proof. typeclasses eauto. Qed.

Existing Instance setoid_refl.
Existing Instance setoid_sym.
Existing Instance setoid_trans.

(** Standard setoids. *)

(* Program Instance eq_setoid : Setoid A := *)
(*   equiv := eq ; setoid_equiv := eq_equivalence. *)

Program Instance iff_setoid : Setoid Prop :=
  { equiv := iff ; setoid_equiv := iff_equivalence }.

(** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *)

(** Subset objects should be first coerced to their underlying type, but that notation doesn't work in the standard case then. *)
(* Notation " x == y " := (equiv (x :>) (y :>)) (at level 70, no associativity) : type_scope. *)

Notation " x == y " := (equiv x y) (at level 70, no associativity) : type_scope.

Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : type_scope.

(** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *)

Ltac clsubst H :=
  match type of H with
    ?x == ?y => substitute H ; clear H x
  end.

Ltac clsubst_nofail :=
  match goal with
    | [ H : ?x == ?y |- _ ] => clsubst H ; clsubst_nofail
    | _ => idtac
  end.

(** [subst*] will try its best at substituting every equality in the goal. *)

Tactic Notation "clsubst" "*" := clsubst_nofail.

Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z.
Proof with auto.
  intros; intro.
  assert(z == y) by (symmetry ; auto).
  assert(x == y) by (transitivity z ; eauto).
  contradiction.
Qed.

Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z.
Proof.
  intros; intro.
  assert(y == x) by (symmetry ; auto).
  assert(y == z) by (transitivity x ; eauto).
  contradiction.
Qed.

Ltac setoid_simplify_one :=
  match goal with
    | [ H : (?x == ?x)%type |- _ ] => clear H
    | [ H : (?x == ?y)%type |- _ ] => clsubst H
    | [ |- (?x =/= ?y)%type ] => let name:=fresh "Hneq" in intro name
  end.

Ltac setoid_simplify := repeat setoid_simplify_one.

Ltac setoidify_tac :=
  match goal with
    | [ s : Setoid ?A, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H
    | [ s : Setoid ?A |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y)
  end.

Ltac setoidify := repeat setoidify_tac.

(** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *)

Program Instance setoid_morphism `(sa : Setoid A) : Proper (equiv ++> equiv ++> iff) equiv :=
  proper_prf.

Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper (equiv ++> iff) (equiv x) :=
  proper_prf.

(** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *)

Class PartialSetoid (A : Type) :=
  { pequiv : relation A ; pequiv_prf :> PER pequiv }.

(** Overloaded notation for partial setoid equivalence. *)

Infix "=~=" := pequiv (at level 70, no associativity) : type_scope.

(** Reset the default Program tactic. *)

Obligation Tactic := program_simpl.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Relations_1.
Require Export Relations_2.

Section Relations_3.
   Variable U : Type.
   Variable R : Relation U.

   Definition coherent (x y:U) : Prop :=
      exists z : _, Rstar U R x z /\ Rstar U R y z.

   Definition locally_confluent (x:U) : Prop :=
     forall y z:U, R x y -> R x z -> coherent y z.

   Definition Locally_confluent : Prop := forall x:U, locally_confluent x.

   Definition confluent (x:U) : Prop :=
     forall y z:U, Rstar U R x y -> Rstar U R x z -> coherent y z.

   Definition Confluent : Prop := forall x:U, confluent x.

   Inductive noetherian (x: U) : Prop :=
       definition_of_noetherian :
         (forall y:U, R x y -> noetherian y) -> noetherian x.

   Definition Noetherian : Prop := forall x:U, noetherian x.

End Relations_3.
Hint Unfold coherent: sets v62.
Hint Unfold locally_confluent: sets v62.
Hint Unfold confluent: sets v62.
Hint Unfold Confluent: sets v62.
Hint Resolve definition_of_noetherian: sets v62.
Hint Unfold Noetherian: sets v62.