From Undecidability Require Import Definitions.
From Undecidability Require Import mu_nat partial equiv_on.

From Undecidability Require Import simple principles EnumerabilityFacts.

Require Import Nat Arith Lia.

Notation least' p n k := (n <= k /\ p k /\ forall i, n <= i -> p i -> k <= i)%nat.

Section WO.

  Variable p : nat -> Prop.

  (* Guardedness predicate *)
  Inductive G (n: nat) : Prop :=
  | GI : (~ p n -> G (S n)) -> G n.

  Lemma G_sig n :
    G n -> ~~ exists k, least' (fun k => p k) n k.
  Proof.
    induction 1 as [n _ IH].
    intros G.
    assert (~~ (p n \/ ~ p n)) as H by tauto. apply H. clear H. intros [H | H].
    - apply G. exists n. repeat split; eauto.
    - apply (IH H). intros (k & Hle & Hk & Hleast'). apply G.
      exists k. repeat split.
      + lia.
      + exact Hk.
      + intros i Hi. inversion Hi.
        * congruence.
        * eapply Hleast'; eauto. lia.
  Defined.

  Lemma G_zero n :
    G n -> G 0.
  Proof.
    induction n as [|n IH].
    - intros H. exact H.
    - intros H. apply IH. constructor. intros _. exact H.
  Defined.

  Theorem mu_nat :
    (exists n, p n) -> ~~ exists n, least' p 0 n.
  Proof.
    intros H. apply (G_sig 0).
    destruct H as [n H].
    apply (G_zero n).
    constructor. tauto.
  Defined.

End WO.

Definition the_least_pred (P : nat -> Prop) : nat -> Prop :=
  fun y => P y /\ forall y', P y' -> y <= y'.

Lemma the_least_pred_unique {P : nat -> Prop} {x y} :
  the_least_pred P x -> the_least_pred P y -> x = y.
Proof.
  firstorder lia.
Qed.

Lemma the_least_pred_impl' {P Q : nat -> Prop} {x} :
  the_least_pred P x -> (forall x, P x <-> Q x) -> the_least_pred Q x.
Proof.
  intros [H2 H3] H1. eapply H1 in H2. split. exact H2. intros y'. rewrite <- H1. apply H3.
Qed.

Lemma the_least_pred_equiv {P Q : nat -> Prop} {x} :
  (forall x, P x <-> Q x) -> the_least_pred P x <-> the_least_pred Q x.
Proof.
  intros. split; intros; eapply the_least_pred_impl'; eauto; firstorder.
Qed.

Lemma the_least_pred_impl {P Q : nat -> Prop} {x} :
  the_least_pred P x -> (forall x, P x -> exists y, Q y) -> ~~ exists x, the_least_pred Q x.
Proof.
  intros [H2 H3] H1. eapply H1 in H2.
  clear H1 H3 P.
  assert (exists x, Q x) as H by eauto. clear x H2. eapply mu_nat in H.
  intros G. apply H. intros (x & H1 & H2 & H3).  apply G.
  exists x. split. auto. intros. eapply H3. 1:lia. auto.
Qed.

Lemma the_least_ex (P : nat -> Prop) :
  (exists n, P n) -> ~~ exists n, the_least_pred P n.
Proof.
  intros H % mu_nat.
  intros G. apply H. intros (n & H1 & H2 & H3).
  apply G. exists n. split; auto with arith.
Qed.

Record FunRel X Y := {
  the_rel :> X -> Y -> Prop ;
  is_fun : (forall x y1 y2, the_rel x y1 -> the_rel x y2 -> y1 = y2) (* ; *)
  (* is_wtotal : (forall x, ~~ exists y, the_rel x y) *) }.

Definition on_value {X Y} (R : FunRel X Y) (P : Y -> Prop) x :=
  forall y, R x y -> P y.

Definition on_value' {X Y} (R : FunRel X Y) (P : Y -> Prop) x :=
  exists y, R x y /\ P y.

Lemma on_value_iff1 {X Y} (R : FunRel X Y) (P : Y -> Prop) x :
  on_value' R P x -> on_value R P x.
Proof.
  intros (y & H1 & H2) y' H.
  now rewrite <- (is_fun _ _ R _ _ _ H1 H).
Qed.

Definition total {X Y} (R : X -> Y -> Prop) :=
  forall x, exists y, R x y.

Lemma on_value_iff2 {X Y} (R : FunRel X Y) (P : Y -> Prop) x :
  total R ->
  on_value R P x -> on_value' R P x.
Proof.
  intros Htot H.
  destruct (Htot x) as [y Hy].
  exists y. split; [ assumption | ].
  eapply (H _ Hy).
Qed.

Definition weakly_total {X Y} (R : X -> Y -> Prop) :=
  forall x, ~~ exists y, R x y.

Lemma on_value_iff2' {X Y} (R : FunRel X Y) (P : Y -> Prop) x :
  weakly_total R ->
  on_value R P x -> ~~ on_value' R P x.
Proof.
  intros Htot H G.
  apply (Htot x); intros [y Hy].
  apply G.
  exists y. split; [ assumption | ].
  eapply (H _ Hy).
Qed.

Lemma on_value_imp {X Y} {P Q : Y -> Prop} R (x : X) :
  on_value R P x -> (forall y, P y -> Q y) -> on_value R Q x.
Proof.
  intros H1 H y Hy. apply H, H1, Hy.
Qed.

Lemma on_value_neg {X Y} {P : Y -> Prop} R (x : X) :
  ~ on_value R P x -> on_value R (fun y => ~ P y) x.
Proof.
  intros H y Hy G; cbn in *. apply H. intros y' Hy'. cbn in *.
  enough (y = y') as -> by assumption. eapply R; eauto.
Qed.

Program Definition the_least {X} (R : X -> nat -> Prop) : FunRel X nat :=
  {|
  the_rel x := the_least_pred (R x) ;
  is_fun := fun x y1 y2 H1 H2 => the_least_pred_unique H1 H2
  |}.

Axiom tonat : list bool -> nat.
Axiom ofnat : nat -> list bool.

Axiom ofnat_tonat : forall l, ofnat (tonat l) = l.
Axiom tonat_ofnat : forall n, tonat (ofnat n) = n.
Axiom length_log : forall n, length (ofnat n) <= Nat.log2 n.
Axiom length_mono : forall x y, x <= y -> length (ofnat x) <= length (ofnat y).

Hint Rewrite ofnat_tonat tonat_ofnat : length.
Hint Rewrite List.app_length : length.

Notation "| n |" := (length (ofnat n)) (at level 10).

Notation "⟨ x , y ⟩" := (tonat (ofnat x ++ ofnat y)) (at level 0).

Lemma length_pair x y : | ⟨x,y⟩ | = |x| + |y|.
Proof.
  now autorewrite with length.
Qed.

Lemma length_sublinear d : ~ forall n, n <= |n| + d.
Proof.
  intros H.
  pose (n := 1 + 2 * S d).
  assert (2 ^ n > n + S d).
  { subst n. rewrite Nat.pow_add_r, Nat.pow_mul_r.
    generalize (S d). cbn. induction n; cbn; lia.
  }
  specialize (H (2 ^ n)).
  pose proof (length_log (2 ^ n)).
  rewrite Nat.log2_pow2 in *; lia.
Qed.

Axiom Part : partiality.
Existing Instance Part.
Axiom ϕ : nat -> nat ↛ nat.

Notation "x ▷ y" := (@hasvalue Part nat x y) (at level 50).
Definition C := the_least (fun x s => exists c y, s = |c| + |y| /\ ϕ c y ▷ x).

Instance equiv_part {A} : equiv_on (part A) := {| equiv_rel := @partial.equiv _ A |}.

Definition universal u := forall c, exists x, forall y, ϕ c y ≡{_} (ϕ u ⟨x,y⟩).

Definition C_ u := the_least (fun x s => exists y, s = |y| /\ ϕ u y ▷ x).

Definition strongly_universal u := forall c i, ϕ c i ≡{_} ϕ u ⟨c,i⟩.

Lemma strongly_universal_universal u :
  strongly_universal u -> universal u.
Proof.
  intros H c'. red in H. setoid_rewrite <- H. exists c'. reflexivity.
Qed.

Hint Rewrite List.app_nil_l @list.nil_length : length.

Set Default Goal Selector "!".

Lemma strongly_universal_equivalence u :
  strongly_universal u -> forall x y, C x y <-> C_ u x y.
Proof.
  intros Huniv x y. rename u into c.  eapply the_least_pred_equiv.
  intros e. split.
  - intros (e' & i & -> & HH).
    eexists. eexists. 1:now rewrite <- length_pair.
    red in Huniv. unfold equiv_part in Huniv.
    do 2 red in Huniv. now  rewrite <- Huniv.
  - intros (i & -> & Hn). exists (tonat nil), i.
    split. 1:now autorewrite with length.
    eapply Huniv. now autorewrite with length.
Qed.

Axiom EPF : forall f : nat -> nat ↛ nat,
    exists γ, forall i, ϕ (γ i) ≡{_} f i.

Lemma EPF_univ_tot {u} : universal u ->
                     forall f : nat -> nat, exists c, forall x, ϕ u ⟨c,x⟩ ▷ f x.
Proof.
  intros Hu f.
  specialize (EPF (fun _ x => ret (f x))) as [γ H].
  destruct (Hu (γ 0)) as [c Hc].
  exists c. intros. cbn in * |-. red in H, Hc.
  rewrite <- Hc, H. eapply ret_hasvalue.
Qed.

Lemma EPF_univ {u} : universal u ->
                     forall f : nat ↛ nat, exists c, forall x, ϕ u ⟨c,x⟩ ≡{_} f x.
Proof.
  intros Hu f.
  specialize (EPF (fun _ => f)) as [γ H].
  destruct (Hu (γ 0)) as [c Hc].
  exists c. intros.
  rewrite <- Hc. eapply H.
Qed.

Lemma C_weakly_total u x :
  universal u -> ~~ exists y, C_ u x y.
Proof.
  intros Hu. eapply the_least_ex.
  destruct (EPF_univ_tot Hu (fun _ => x)) as [c Hc % fun H => H 0].
  eauto.
Qed.

Theorem Invariance u :
  universal u -> forall u', exists d,
  forall x y, C_ u x y -> forall y', C_ u' x y' -> y <= y' + d.
Proof.
  intros Hu u'.
  destruct (Hu u') as [d Hd]. exists (|d|).
  intros x ? ((y & -> & H) & Hleast) _ ((y' & -> & H2) & Hleast2).
  eapply Hd in H2.
  rewrite Hleast. 2: eauto.
  rewrite length_pair. lia.
Qed.

Axiom u : nat.
Axiom univ_u : universal u.

Definition N (x : nat) :=
  exists y, ϕ u y ▷ x /\ |y| < |x|.

Definition R (x : nat) :=
  forall y, ϕ u y ▷ x -> |y| >= |x|.

Lemma R_neg_N x :
  R x <-> ~ N x.
Proof.
  split.
  - intros H (y & H1 % H & H2). lia.
  - intros H y H1.
    assert (|y| >= |x| \/ |y| < |x|) as [ Ha | Ha ] by lia; [ auto | ].
    destruct H. exists y. eauto.
Qed.

Lemma MP_choice (R : nat -> nat -> Prop) : MP -> enumerable (fun '(x,y) => R x y) ->
  (forall x, ~~ exists y, R x y) -> exists f, forall x, R x (f x).
Proof.
  intros.
  eapply enumerable_AC; eauto.
  intros x. eapply MP_to_MP_semidecidable in H.
  red in H. eapply H with (p := fun x => exists n, R x n).
  - eapply SemiDecidabilityFacts.semi_decidable_ex.
    eapply SemiDecidabilityFacts.enumerable_semi_decidable; eauto.
    eapply ReducibilityFacts.enumerable_red.
    4: exact H0. all:eauto.
    exists (fun '(x,y) => (y, x)). intros []. firstorder.
  - eauto.
Qed.

Lemma enum_to:
  forall q : nat -> Prop, enumerable q -> enumerable (fun '(x, y) => x < | y | /\ q y).
Proof.
  intros q [f Hf].
  exists (fun nx => let (n, x) := embed_nat.unembed nx in if f n is Some y then if x <? |y| then Some (x, y) else None else None).
  intros (x, y). cbn -[Nat.ltb]. split.
  - intros [H1 [n H2] % Hf]. exists (embed_nat.embed (n, x)).
    rewrite embed_nat.embedP, H2.
    destruct (Nat.ltb_spec x (|y|)).
    + reflexivity.
    + lia.
  - intros (nx & H).
    destruct (embed_nat.unembed nx) as [n x'].
    destruct (f n) as [y'|] eqn:E; inversion H.
    destruct (Nat.ltb_spec x' (|y'|)); inversion H; subst.
    firstorder.
Qed.

Lemma par_enum_ϕ :
  enumerable (fun '(x, y) => ϕ u y ▷ x).
Proof.
  eapply ReducibilityFacts.enumerable_red.
  4: eapply enumerable_graph_part; eauto.
  all: eauto.
  exists (fun '(x,y) => (y, x)). intros [].  cbn. reflexivity.
Qed.

Lemma enumerable_N :
  enumerable N.
Proof.
  destruct (par_enum_ϕ) as [f Hf].
  exists (fun n => if f n is Some (x,y) then if Nat.ltb (|y|) (|x|) then Some x else None else None).
  red. intros x. split.
  - intros (y & H1 & H2).
    eapply (Hf (x, y)) in H1 as [n Hn].
    exists n. rewrite Hn.
    destruct (Nat.ltb_spec (|y|) (|x|)).
    + reflexivity.
    + lia.
  - intros [n Hn]. destruct (f n) as [[x' y] | ] eqn:E; inversion Hn.
    destruct (Nat.ltb_spec (|y|) (|x'|)).
    + inversion Hn. subst. exists y. split; eauto.
      eapply (Hf (x, y)). eauto.
    + congruence.
Qed.

From Undecidability Require Import FinitenessFacts.
From stdpp Require Import base.
Require Import List.

Lemma list_max_spec L x :
  In x L -> x <= list_max L.
Proof.
  induction L.
  - firstorder.
  - intros [-> | ]; cbn.
    + lia.
    + eapply IHL in H. unfold list_max in H. lia.
Qed.

From Undecidability Require Import Pigeonhole.

From Undecidability Require Import Dec.

Lemma non_finite_unbounded_fun (p : nat -> Prop) f :
  (forall n, exists L, forall x, f x <= n -> In x L) ->
  ~ exhaustible p -> forall x, ~~ exists y : nat, f y >= x /\ p y.
Proof.
  intros Hsur Hfin n. rewrite non_finite_spec in Hfin.
  2: intros; destruct (Nat.eq_decidable x1 x2); tauto.

  destruct (Hsur n) as [L HL].
  specialize (Hfin L).
  cunwrap. destruct Hfin as (y & H1 & H2).
  cprove exists y. split; [|eauto].
  unshelve cstart. 1:eapply le_dec.
  intros H. apply H2, HL. lia.
Qed.

Lemma unbounded_non_finite_fun (p : nat -> Prop) (f : nat -> nat) :
  (forall k, ~~ exists x, f x >= k /\ p x) -> ~ exhaustible p.
Proof.
  intros Hfin. eapply non_finite_nat.
  intros n H.
  pose (N := 1 + list_max (map f (seq 0 n))).
  eapply (Hfin N).
  intros (x & H1 & H2).
  apply H. eexists; split. 2: eauto.
  assert (x < n \/ x >= n) as [ | ] by lia; try lia.
  enough (f x > f x) by lia. subst N.
  unfold gt. unfold ge in H1.
  eapply Nat.lt_le_trans. 2: eauto. red. cbn.
  rewrite <- Nat.succ_le_mono.
  eapply list_max_spec.
  eapply in_map_iff. exists x. split; eauto.
  eapply in_seq. lia.
Qed.

Lemma NoDup_app {X} (l1 l2 : list X) :
  NoDup l1 -> NoDup l2 -> (forall x, In x l1 -> ~ (In x l2)) -> NoDup (l1 ++ l2).
Proof.
  induction 1 in l2 |- *.
  - eauto.
  - intros Hl2 Hel. cbn. econstructor. 2:eapply IHNoDup; eauto.
    + intros [ | ] % in_app_iff; firstorder.
Qed.

Lemma NoDup_map {X Y} (f : X -> Y) l :
  Inj (=) (=) f -> NoDup l -> NoDup (map f l).
Proof.
  induction 2; cbn; econstructor.
  1:intros (? & ? % H & ?) % in_map_iff.
  all: firstorder congruence.
Qed.

Lemma bitlist_for_k k :
  exists l : list (list bool), (forall x, In x l <-> length x = k) /\ NoDup l /\ length l = 2 ^ k.
Proof.
  induction k.
  - exists (nil :: nil). split; [ | split ].
    + cbn. intros []; cbn in *; firstorder congruence.
    + repeat econstructor; eauto.
    + reflexivity.
  - destruct IHk as (L & IH1 & IH2 & IH3).
    exists (map (cons true) L ++ map (cons false) L).
    split; [ | split].
    + intros l.
      rewrite in_app_iff, !in_map_iff.
      setoid_rewrite IH1.
      destruct l as [ | ].
      * cbn. split. 2:lia.
        intros [(? & [=] & ?) | (? & [=] & ?)].
      * cbn. split.
        -- intros [(? & [=] & ?) | (? & [=] & ?)]; subst; lia.
        -- destruct b; intros [=]; eauto.
    + eapply NoDup_app; try eapply NoDup_map; eauto.
      intros ? (? & <- & ?) % in_map_iff (? & ? & ?) % in_map_iff.
      congruence.
    + rewrite app_length, !map_length, IH3. cbn. lia.
Qed.

Lemma list_for_k k :
  exists l, (forall x, In x l <-> | x | = k) /\ NoDup l /\ length l = 2 ^ k.
Proof.
  destruct (bitlist_for_k k) as (l & H1 & H2 & H3).
  exists (map tonat l). split; [ | split].
  - intros x. cbn. rewrite in_map_iff.
    setoid_rewrite H1. split.
    + intros (y & <- & <-). now autorewrite with length.
    + intros <-. exists (ofnat x). now autorewrite with length.
  - eapply NoDup_map; auto. intros ? ? E % (f_equal ofnat).
    now rewrite !ofnat_tonat in E.
  - now rewrite map_length.
Qed.

Lemma list_for_le_k k :
  exists l, (forall x, In x l <-> | x | <= k) /\ NoDup l /\ length l = 2 ^ (S k) - 1.
Proof.
  induction k.
  - cbn. exists [ tonat nil ].
    split; [ | split ].
    + cbn. split.
      * intros [ <- | []]. now autorewrite with length.
      * intros H. left. destruct (ofnat x) eqn:E; inversion H.
        rewrite <- E. now autorewrite with length.
    + repeat econstructor. firstorder.
    + reflexivity.
  - cbn. destruct IHk as (l1 & IH1 & IH2 & IH3).
    destruct (list_for_k (S k)) as (l2 & H1 & H2 & H3).
    exists (l1 ++ l2). split; [ | split].
    + intros. rewrite in_app_iff, IH1, H1.
      lia.
    + eapply NoDup_app; firstorder lia.
    + rewrite app_length, IH3, H3. cbn; lia.
Qed.

Lemma at_most k : k > 0 ->
  forall l, (forall x, In x l -> | x | < k) -> NoDup l -> length l <= 2^ k - 1.
Proof.
  intros Hk l H1 H2. unfold lt in H1.
  destruct k.
  - lia.
  - setoid_rewrite <- Nat.succ_le_mono in H1.
    destruct (list_for_le_k k) as (l2 & H3 & H4 & H5).
    assert (length l <= length l2). {
      eapply NoDup_incl_length; firstorder.
    }
    enough (length l2 <= 2 ^ (S k) - 1) by lia.
    rewrite H5. lia.
Qed.

Definition injective {X Y} (R : X -> Y -> Prop) :=
  forall x1 x2 y, R x1 y -> R x2 y -> x1 = x2.

Lemma Forall2_ex_r {X Y} (R : X -> Y -> Prop) l1 l2 y :
  Forall2 R l1 l2 ->
  In y l2 -> exists x, In x l1 /\ R x y.
Proof.
  induction 1; repeat firstorder subst.
Qed.

Lemma functional_NoDup (R : nat -> nat -> Prop) l :
  injective R ->
  (forall x, In x l -> exists y, R x y) ->
  NoDup l ->
  exists l', NoDup l' /\ Forall2 R l l'.
Proof.
  intros HR Htot Hl. induction Hl.
  - exists []. split; econstructor.
  - destruct IHHl as (l' & H1 & H2).
    + firstorder.
    + destruct (Htot x) as [y Hy].
      1: firstorder.
      exists (y :: l'). split.
      * econstructor; [ | eauto].
        intros Hin.
        edestruct @Forall2_ex_r as (x' & H3 & H4); eauto.
        eapply H. eapply HR in H4 as <-; eauto.
      * econstructor; eauto.
Qed.

Lemma nonrandom_k k :
  ~ forall x, |x| = k -> N x.
Proof.
  intros H.
  destruct (list_for_k k) as (l & H1 & H2 & H3).
  eapply (functional_NoDup (fun x y => ϕ u y ▷ x ∧ | y | < | x |)) in H2 as (l' & H4 & H5).
  - assert (Forall (fun y => |y| < k) l'). {
      eapply list.Forall2_Forall_r; eauto.
      cbn. eapply Forall_forall.
      intros ? ? % H1. lia.
    }
    assert (length l' = 2 ^ k). { erewrite <- list.Forall2_length; eauto. }
    destruct k.
    + cbn in *. destruct H0.  1:inversion H2. cbn in *. lia.
    + unshelve epose proof (@at_most (S k) _ l' _ _).
      * lia.
      * eapply Forall_forall. eauto.
      * eauto.
      * rewrite H2 in H6.
        enough (2 ^ S k > S k) by lia.
        eapply Nat.pow_gt_lin_r. lia.
  - intros x1 x2 y [Hx1 Hx11] [Hx2 Hx22]. eapply hasvalue_det; eauto.
  - intros x (y & ? & ?) % H1 % H. eauto.
Qed.

Lemma unboundedR :
  forall k, ~~ exists x, | x | = k /\ R x.
Proof.
  setoid_rewrite R_neg_N. intros k G.
  assert (forall x, |x| = k -> ~~ N x) by firstorder. clear G.
  pose proof (nonrandom_k k).
  pose proof (list_for_k k) as (l & H1 & H2 & H3).
  setoid_rewrite <- H1 in H.
  setoid_rewrite <- H1 in H0. clear - H H0.
  induction l.
  - eapply H0. firstorder.
  - eapply H.
    + now left.
    + intros Ha. eapply IHl.
      * intros HH. eapply H0. intros. inversion H1 as [-> | ]; eauto.
      * firstorder.
Qed.

Lemma non_finite_length (p : nat -> Prop) :
  ~ exhaustible p -> forall x, ~~ exists y, x < | y | /\ p y.
Proof.
  intros H.
  unshelve epose proof (non_finite_unbounded_fun _ (fun x => |x|) _ H).
  - cbn. intros n.
    destruct (@list_for_le_k n) as [L HL].
    exists L. intros. eapply HL. eauto.
  - intros x. specialize (H0 (S x)). cunwrap.
    destruct H0 as (y & H1 & H2). cprove exists y.
    split. 1:lia. assumption.
Qed.

Lemma classical_finite {X} (p q : X -> Prop):
  listable p -> (forall x, p x -> ~~ q x) -> ~~ forall x, p x -> q x.
Proof.
  intros [l Hl]. red in Hl.
  setoid_rewrite Hl. clear p Hl.
  induction l.
  - firstorder.
  - cbn. intros H.
    specialize (IHl ltac:(firstorder)).
    cunwrap. ccase (q a) as [Ha | Ha].
    + cprove intros ? [-> | ]; eauto.
    + specialize (H a); firstorder.
Qed.

Lemma non_finite_R :
  ~ exhaustible R.
Proof.
  eapply unbounded_non_finite_fun with (f := fun x => |x|).
  intros k G.
  setoid_rewrite R_neg_N in G.
  assert (forall x, |x| = k -> ~~ N x).
  { intros x Hx GG. apply G. exists x. split. 1:lia. assumption. }
  clear G.

  eapply classical_finite in H.
  1:cstart; cunwrap; intros _; now eapply (nonrandom_k k).
  destruct (list_for_k k) as (L & H1 & _ & _).
  firstorder.
Qed.

Lemma dist f :
  exists d, forall x, exists y_x, ϕ u y_x ▷ f x /\ | y_x| < |x| + d.
Proof.
  destruct (EPF_univ_tot univ_u f) as [c Hc].
  exists (|c| + 1). intros x.
  exists (⟨ c, x ⟩). split. 1: eauto.
  autorewrite with length. lia.
Qed.

Lemma subset :
  MP -> forall q : nat -> Prop, (forall x, q x -> R x) -> enumerable q -> ~ exhaustible q -> False.
Proof.
  intros mp q H1 H2 H3.
  unshelve epose proof (MP_choice _ mp _ (non_finite_length _ H3)) as [f Hf].
  1: now eapply enum_to.
  assert (forall k y, ϕ u y ▷ f k -> |f k| <= |y|). {
    intros. destruct (Hf k) as [Hk1 Hk2].
    eapply H1; eauto.
  }
  destruct (dist f) as [d Hd].
  eapply (length_sublinear d). intros k.
  transitivity (|f k|). 1:eapply Nat.lt_le_incl, Hf.
  destruct (Hd k) as (y_k & Hk1 & Hk2).
  transitivity (|y_k|). 1: eauto.
  lia.
Qed.

Lemma get_partial_choice (R : nat -> nat -> Prop) :
  enumerable (fun '(x,y) => R x y) ->
  exists f : nat ↛ nat, forall x v_x,
    (f x ▷ v_x -> R x v_x) /\ (R x v_x -> exists v', f x ▷ v').
Proof.
  intros [f Hf].
  exists (fun x => bind (mu_tot (fun n => if f n is Some (x', y) then x =? x' else false))
                (fun n => if f n is Some (x', y) then ret y else undef)).
  intros x v_x. rewrite bind_hasvalue.
  split.
  - intros (n & (H1 & H3) % mu_tot_hasvalue & H2).
    destruct (f n) as [ [x' y] | ]eqn:E; try congruence.
    destruct (Nat.eqb_spec x x'); try congruence. subst.
    eapply ret_hasvalue_iff in H2. subst.
    eapply (Hf (x', v_x)). eauto.
  - intros [n Hn] % (Hf (x, v_x)).
    edestruct (mu_tot_ter) as [a Ha].
    2:{ destruct (f a) as [[x' y'] | ] eqn:E.
        - eexists. eapply bind_hasvalue. exists a. split. 1: eapply Ha.
          rewrite E. eapply ret_hasvalue.
        - eapply mu_tot_hasvalue in Ha as [Ha _].
          rewrite E in Ha. congruence.
    }
    cbn. rewrite Hn. eapply Nat.eqb_refl.
Qed.

Lemma dist_strong R :
  weakly_total R -> enumerable (fun '(x,y) => R x y) ->
  exists d, forall x, exists y_x, ~~ exists v_x, R x v_x /\ ϕ u y_x ▷ v_x /\ | y_x| < |x| + d.
Proof.
  intros Htot [f Hf] % get_partial_choice.
  destruct (EPF_univ univ_u f) as [c Hc].
  exists (|c| + 1). intros x.
  exists (⟨ c, x ⟩).
  specialize (Htot x). cunwrap. destruct Htot as [v_x' Hvx].
  pose proof (Hvx' := Hvx).
  eapply Hf in Hvx as [v_x Hvx].
  cprove exists v_x.
  repeat split.
  - eapply Hf. eauto.
  - eapply Hc. eauto.
  - autorewrite with length. lia.
Qed.

Lemma subset_strong :
  forall q : nat -> Prop, (forall x, q x -> R x) -> enumerable q -> ~ exhaustible q -> False.
Proof.
  intros q H1 H2 H3.
  destruct (dist_strong (fun k x => k < |x| /\ q x)) as [d Hd].
  - exact (non_finite_length _ H3).
  - now eapply enum_to.
  - eapply (length_sublinear d). intros k.
    destruct (Hd k) as [y_k H].
    unshelve cstart. 1:eapply le_dec.
    cunwrap. destruct H as (x_k & [H4 H5] & H6 & H7).
    cprove idtac.
    transitivity (|x_k|). 1:eapply Nat.lt_le_incl, H4.
    transitivity (|y_k|). 1: eapply H1; eauto. lia.
Qed.

Lemma exhaustible_ext {X} (p q : X -> Prop) :
  exhaustible p -> (forall x, p x <-> q x) -> exhaustible q.
Proof.
  firstorder.
Qed.

Lemma simple_N : MP -> simple N.
Proof.
  split. 2: split.
  - eapply enumerable_N.
  - intros ?. eapply non_finite_R, exhaustible_ext. 1: eauto.
    intros. now rewrite R_neg_N.
  - intros (q & H1 & H2 & H3). eapply subset; try eassumption.
    intros. eapply R_neg_N; eauto. firstorder.
Qed.

Lemma simple_N_strong : simple N.
Proof.
  split. 2: split.
  - eapply enumerable_N.
  - intros ?. eapply non_finite_R, exhaustible_ext. 1: eauto.
    intros. now rewrite R_neg_N.
  - intros (q & H1 & H2 & H3). eapply subset_strong; try eassumption.
    intros. eapply R_neg_N; eauto. firstorder.
Qed.

Lemma dist_again :
  forall f : nat -> nat, exists d, forall x y, C_ u (f x) y -> y <= |x| + d.
Proof.
  intros f.
  destruct (dist f) as [d Hd]. exists d.
  intros x y H. destruct (Hd x) as (y_x & H1 & H2).
  etransitivity.
  - eapply H; eauto.
  - lia.
Qed.

Lemma R_undecidable :
  MP -> ~ decidable R.
Proof.
  intros mp Hdec.
  unshelve epose proof (MP_choice _ mp _ unboundedR) as [g Hg].
  - cbn. eapply decidable_enumerable. 2:eauto.
    eapply DecidabilityFacts.decidable_iff.
    eapply DecidabilityFacts.decidable_iff in Hdec. destruct Hdec.
    econstructor. intros (x, y).
    exact _.
  - destruct (dist_again g) as [d].
    eapply length_sublinear with (d := d).
    intros k.
    unshelve cstart.  1:eapply le_dec.
    pose proof (C_weakly_total u (g k) univ_u) as Hk. cunwrap.
    destruct Hk as [C_u_k Hcuk].
    cprove idtac.
    transitivity (| g k|).
    1:{ eapply Nat.eq_le_incl. symmetry. eapply Hg. }
    destruct Hcuk as ([? [-> H1]] & H2).
    etransitivity.
    1:{ eapply Hg. eapply H1. }
    eapply H. cbn. firstorder.
Qed.

Lemma dist_again_strong R :
  weakly_total R -> enumerable (fun '(x,y) => R x y) ->
  exists d, forall x, ~~ exists v_x, R x v_x /\ forall y, C_ u (v_x) y -> y <= |x| + d.
Proof.
  intros H1 H2.
  destruct (dist_strong R H1 H2) as [d Hd].
  exists d. intros x.
  destruct (Hd x) as [y_x Hyx].
  cunwrap. destruct Hyx as (v_x & H3 & H4 & H5).
  cprove exists v_x. split; eauto.
  intros.
  etransitivity. 1:eapply H; eauto.
  lia.
Qed.

Lemma R_undecidable_strong :
  ~ decidable R.
Proof.
  intros Hdec.
  destruct (dist_again_strong (fun k x => |x| = k /\ R x)) as [d Hd].
  - exact unboundedR.
  - cbn. eapply decidable_enumerable. 2:eauto.
    eapply DecidabilityFacts.decidable_iff.
    eapply DecidabilityFacts.decidable_iff in Hdec. destruct Hdec.
    econstructor. intros (x, y).
    exact _.
  - eapply length_sublinear with (d := d).
    intros k.
    specialize (Hd k).
    unshelve cstart.  1:eapply le_dec. cunwrap.
    destruct Hd as (x_k & [H1 H2] & H3).
    rewrite <- H1 at 1.
    pose proof (C_weakly_total u x_k univ_u) as Hk. cunwrap.
    destruct Hk as [C_u_k Hcuk].
    destruct Hcuk as ([? [-> H4]] & H5).
    cprove idtac.
    etransitivity. 1:{ eapply H2. eauto. }
    eapply H3. cbn. firstorder.
Qed.


Require Import Rsequence.
Require Import Rseries_def Rseries_base_facts Rseries_cv_facts Rseries_pos_facts.

Require Import Lra MyRIneq.

Local Open Scope R_scope.
Local Open Scope Rseq_scope.

(** Remainder caracterization *)

Lemma Rser_rem_ext: forall An l Hl Bn l' Hl' n,
  An == Bn -> Rser_rem An l Hl n = Rser_rem Bn l' Hl' n.
Proof.
intros ; apply Rminus_eq_compat ;
 [eapply Rser_cv_unique | eapply Rseq_sum_ext] ;
 [ | erewrite Rser_cv_ext |] ; eassumption.
Qed.

Lemma Rser_rem_cv : forall An l (Hl : Rser_cv An l ) (n : nat),
    Rser_cv (Rseq_shifts An (S n)) (Rser_rem An l Hl n).
Proof.
intros An l Hl n ; unfold Rser_cv ; eapply Rseq_cv_eq_compat.
 intro p ; eapply Rseq_sum_shifts_compat.
 unfold Rser_rem ; apply Rseq_cv_minus_compat.
  apply Rseq_cv_shifts_compat_reciprocal ; assumption.
  apply Rseq_constant_cv.
Qed.

(** Compatibility between remainder and usual operations *)

Lemma Rser_rem_scal_compat_l: forall An l (k : R) Hkl Hl,
  Rser_rem (k * An) (k * l) Hkl == k * Rser_rem An l Hl.
Proof.
intros An l k Hkl Hl n ; unfold Rser_rem ; rewrite Rseq_sum_scal_compat_l ;
 unfold Rseq_plus, Rseq_minus, Rseq_constant, Rseq_mult ;  ring.
Qed.

Lemma Rser_rem_scal_compat_r: forall An l (k : R) Hlk Hl,
  Rser_rem (An * k) (l * k) Hlk == Rser_rem An l Hl * k.
Proof.
intros An l k Hlk Hl n ; unfold Rser_rem ; rewrite Rseq_sum_scal_compat_r ;
 unfold Rseq_plus, Rseq_minus, Rseq_constant, Rseq_mult ;  ring.
Qed.

Lemma Rser_rem_opp_compat: forall An l Hl Hl2,
  Rser_rem (- An) (- l) Hl == - Rser_rem An l Hl2.
Proof.
intros An l Hl Hl2 n ; unfold Rser_rem ; rewrite Rseq_sum_opp_compat ;
 unfold Rseq_plus, Rseq_minus, Rseq_opp ; ring.
Qed.

Lemma Rser_rem_plus_compat: forall An Bn la lb Hla Hlb Hlab,
  Rser_rem An la Hla + Rser_rem Bn lb Hlb == Rser_rem (An + Bn) (la + lb) Hlab.
Proof.
intros An Bn la lb Hla Hlb Hlab n ; unfold Rser_rem ;
 rewrite Rseq_sum_plus_compat ; unfold Rseq_plus, Rseq_minus ; ring.
Qed.

Lemma Rser_rem_minus_compat: forall An Bn la lb Hla Hlb Hlab,
  Rser_rem An la Hla - Rser_rem Bn lb Hlb == Rser_rem (An - Bn) (la - lb) Hlab.
Proof.
intros An Bn la lb Hla Hlb Hlab n ; unfold Rser_rem ;
 rewrite Rseq_sum_minus_compat ; unfold Rseq_plus, Rseq_minus ; ring.
Qed.

(** Convergence results *)

Lemma Rser_Rser_rem_equiv: forall An Bn x l (H : Rser_cv Bn l) n,
  (forall k, An k = Rseq_shifts Bn (S n) k) ->
  Rser_cv An x -> x = Rser_rem Bn l H n.
Proof.
intros An Bn x l Hl n Heq Hx ; eapply Rser_cv_unique.
 apply Hx.
 eapply Rser_cv_ext with (Rseq_shifts Bn (S n)).
  intro ; apply Heq.
  apply Rser_cv_shifts ; assumption.
Qed.

Lemma Rser_rem_pos: forall An k l (Hl : Rser_cv An l) ,
  (forall n, (n > k)%nat -> An n >= 0) ->
  {n | (n > k)%nat /\ An n > 0} ->
  Rser_rem An l Hl k > 0.
Proof.
intros An k l Hl An_pos [n [nk Hn]] ; apply Rlt_Rminus, Rlt_le_trans with (Rseq_sum An n).
 destruct n ; [inversion nk |].
  rewrite Rseq_sum_simpl ;apply Rle_lt_trans with (Rseq_sum An n) ; [| lra].
  clear Hn ; induction n.
   assert (k = O) by omega ; subst ; reflexivity.
   destruct (eq_nat_dec k (S n)).
    subst ; reflexivity.
    assert (S n > k)%nat by omega ; assert (0 <= An (S n)) by (apply Rge_le, An_pos ; auto) ;
    rewrite Rseq_sum_simpl ; transitivity (Rseq_sum An n) ; [intuition | lra].
   eapply Rseq_limit_comparison with (Rseq_sum An n) (Rseq_shifts (Rseq_sum An) n).
   intro p ; induction p ; unfold Rseq_constant, Rseq_shifts in *.
    rewrite plus_0_r ; reflexivity.
    rewrite <- plus_n_Sm, Rseq_sum_simpl ; assert (0 <= An (S (n +p)))
     by (apply Rge_le, An_pos ; omega) ; lra.
   apply Rseq_constant_cv.
   apply Rseq_cv_shifts_compat_reciprocal ; assumption.
Qed.


Require Export ZArith.

Inductive Z_btree : Set :=
  Z_leaf : Z_btree | Z_bnode : Z->Z_btree->Z_btree->Z_btree.

Inductive btree (A:Type) :Type :=
  bleaf : btree A | bnode : A ->btree A->btree A->btree A.

Fixpoint Z_btree_to_btree (t:Z_btree) : btree Z :=
  match t with
    Z_leaf => bleaf Z
  | Z_bnode x t1 t2 => bnode Z x
                         (Z_btree_to_btree t1)
                         (Z_btree_to_btree t2)
  end.

Fixpoint btree_to_Z_btree (t:btree Z) : Z_btree :=
  match t with
    bleaf _ => Z_leaf
  | bnode _ x t1 t2 => Z_bnode x
                         (btree_to_Z_btree t1)
                         (btree_to_Z_btree t2)
  end.

Theorem btree_to_Z_inv :
 forall t, Z_btree_to_btree (btree_to_Z_btree t) = t.
Proof.
 intros t; elim t; simpl; auto.
 intros x t1 IHt1 t2 IHt2; rewrite IHt1; rewrite IHt2;auto.
Qed.

Theorem Z_btree_to_inv :
 forall t, btree_to_Z_btree (Z_btree_to_btree t) = t.
Proof.
 intros t; elim t; simpl; auto.
 intros x t1 IHt1 t2 IHt2; rewrite IHt1; rewrite IHt2;auto.
Qed.


(**************************************************************************)
(**  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     *)
(**************************************************************************)

(**************************************************************************)
(* Author : Mathis Bouverot-Dupuis (June 2022).

 * This file implements an algorithm to ALIGN all robots on an arbitrary
 * axis, in the plane (R²). The algorithm assumes there are no byzantine robots,
 * and works in a RIGID and SEMI-SYNCHRONOUS setting.

 * The algorithm is as follows : all robots go towards the 'weber point' of
 * the configuration. The weber point, also called geometric median, is unique
 * if the robots are not aligned, and has the property that moving any robot
 * towards the weber point in a straight line doesn't change the weber point.
 * It thus remains at the same place throughout the whole execution.  *)
(**************************************************************************)

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 FunInd.
Require Import FMapFacts.

(* Helping typeclass resolution avoid infinite loops. *)
Typeclasses eauto := (bfs).

(* Pactole basic definitions *)
Require Export Pactole.Setting.
(* Specific to R^2 topology *)
Require Import Pactole.Spaces.R2.
(* Specific to gathering *)
Require Pactole.CaseStudies.Gathering.WithMultiplicity.
Require Import Pactole.CaseStudies.Gathering.Definitions.
(* Specific to multiplicity *)
Require Import Pactole.Observations.MultisetObservation.
(* Specific to rigidity *)
Require Import Pactole.Models.Rigid.
(* Specific to settings with no Byzantine robots *)
Require Import Pactole.Models.NoByzantine.
(* Utility lemmas. *)
Require Import Pactole.CaseStudies.Gathering.InR2.Weber.Utils.
(* Specific to definition and properties of the weber point. *)
Require Import Pactole.CaseStudies.Gathering.InR2.Weber.Weber_point.

(* User defined *)
Import Permutation.
Import Datatypes.

Set Implicit Arguments.
Close Scope R_scope.
Close Scope VectorSpace_scope.

Section Alignment.

(* We assume the existence of a function that calculates a weber point of a collection
 * (even when the weber point is not unique).
 * This is a very strong assumption : such a function may not exist in closed form,
 * and the Weber point can only be approximated. *)
Axiom weber_calc : list R2 -> R2.
Axiom weber_calc_correct : forall ps, Weber ps (weber_calc ps).
(* We also suppose this function doesn't depend on the order of the points.
* This is probably not necessary (we can show that it holds when the points aren't colinear)
* but simplifies the proof a bit. *)
Axiom weber_calc_compat : Proper (PermutationA equiv ==> equiv) weber_calc.
Local Existing Instance weber_calc_compat.

(* The number of robots *)
Variables n : nat.
Hypothesis lt_0n : 0 < n.

(* There are no byzantine robots. *)
Local Instance N : Names := Robots n 0.
Local Instance NoByz : NoByzantine.
Proof using . now split. Qed.

(* The robots are in the plane (R^2). *)
Local Instance Loc : Location := make_Location R2.
Local Instance LocVS : RealVectorSpace location := R2_VS.
Local Instance LocES : EuclideanSpace location := R2_ES.

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

(* Robots don't have an state (and thus no memory) apart from their location. *)
Local Instance St : State location := OnlyLocation (fun f => True).
Local Instance RobotC : robot_choice location := {| robot_choice_Setoid := location_Setoid |}.

(* Robots view the other robots' positions up to a similarity. *)
Local Instance FrameC : frame_choice (similarity location) := FrameChoiceSimilarity.
Local Instance UpdateC : update_choice unit := NoChoice.
Local Instance InactiveC : inactive_choice unit := NoChoiceIna.

(* We are in a rigid and semi-synchronous setting. *)
Local Instance UpdateF : update_function _ _ _.
  refine {| update := fun _ _ _ target _ => target |}.
Proof using . now repeat intro. Defined.
Local Instance InactiveF : inactive_function _.
  refine {| inactive := fun config id _ => config id |}.
Proof using . repeat intro. now subst. Defined.
Local Instance Rigid : RigidSetting.
Proof using . split. reflexivity. Qed.

(* The support of a multiset, but elements are repeated
 * a number of times equal to their multiplicity.
 * This is needed to convert an observation from multiset to list format,
 * so that we can use functions [colinear_dec] and [weber_calc]. *)
Definition multi_support {A} `{EqDec A} (s : multiset A) :=
  List.flat_map (fun '(x, mx) => alls x mx) (elements s).

Local Instance multi_support_compat {A} `{EqDec A} : Proper (equiv ==> PermutationA equiv) (@multi_support A _ _).
Proof using .
intros s s' Hss'. unfold multi_support. f_equiv.
+ intros [x mx] [y my] Hxy. inv Hxy. simpl in H0, H1. now rewrite H0, H1.
+ now apply elements_compat.
Qed.

(* The main algorithm : just move towards the weber point until all robots are aligned. *)
Definition gatherW_pgm obs : location :=
  if aligned_dec (multi_support obs)
  (* Don't move (the robot's local frame is always centered on itself, i.e. its position is at the origin). *)
  then origin
  (* Go towards the weber point. *)
  else weber_calc (multi_support obs).

Local Instance gatherW_pgm_compat : Proper (equiv ==> equiv) gatherW_pgm.
Proof using .
intros s1 s2 Hs. unfold gatherW_pgm.
repeat destruct_match.
+ reflexivity.
+ rewrite Hs in a. now intuition.
+ rewrite Hs in n0. now intuition.
+ apply weber_unique with (multi_support s1) ; auto.
  - rewrite Hs. now apply weber_calc_correct.
  - now apply weber_calc_correct.
Qed.

Definition gatherW : robogram := {| pgm := gatherW_pgm |}.

Lemma multi_support_add {A : Type} `{EqDec A} s x k : ~ In x s -> k > 0 ->
  PermutationA equiv (multi_support (add x k s)) (alls x k ++ multi_support s).
Proof using .
intros Hin Hk. unfold multi_support.
transitivity (flat_map (fun '(x0, mx) => alls x0 mx) ((x, k) :: elements s)).
+ f_equiv.
  - intros [a ka] [b kb] [H0 H1]. cbn in H0, H1. now rewrite H0, H1.
  - apply elements_add_out ; auto.
+ now cbn -[elements].
Qed.

Lemma multi_support_countA {A : Type} `{eq_dec : EqDec A} s x :
  countA_occ equiv eq_dec x (multi_support s) == s[x].
Proof using .
pattern s. apply MMultisetFacts.ind.
+ intros m m' Hm. f_equiv.
  - apply countA_occ_compat ; autoclass. now rewrite Hm.
  - now rewrite Hm.
+ intros m x' n' Hin Hn IH. rewrite add_spec, multi_support_add, countA_occ_app by auto.
  destruct_match.
  - now rewrite <-e, countA_occ_alls_in, Nat.add_comm, IH ; autoclass.
  - now rewrite countA_occ_alls_out, IH, Nat.add_0_l ; auto.
+ now reflexivity.
Qed.

(* This is the main result about multi_support. *)
Lemma multi_support_config config id :
  PermutationA equiv
    (multi_support (obs_from_config config (config id)))
    (config_list config).
Proof using .
cbv -[multi_support config_list equiv make_multiset List.map]. rewrite List.map_id.
apply PermutationA_countA_occ. intros x. rewrite multi_support_countA. now apply make_multiset_spec.
Qed.

Corollary multi_support_map f config id :
  Proper (equiv ==> equiv) (projT1 f) ->
  PermutationA equiv
    (multi_support (obs_from_config (map_config (lift f) config) (lift f (config id))))
    (List.map (projT1 f) (config_list config)).
Proof using .
intros H. destruct f as [f Pf]. cbn -[equiv config_list multi_support].
change (f (config id)) with (map_config f config id).
now rewrite multi_support_config, config_list_map.
Qed.

(* Simplify the [round] function and express it in the global frame of reference. *)
(* All the proofs below use this simplified version. *)
Lemma round_simplify da config : similarity_da_prop da ->
  round gatherW da config ==
  fun id =>
    if activate da id then
      if aligned_dec (config_list config) then config id
      else weber_calc (config_list config)
    else config id.
Proof using .
intros Hsim. apply no_byz_eq. intros g. unfold round.
cbn -[inverse equiv lift location config_list origin].
destruct_match ; try reflexivity.
pose (f := existT (fun _ : location -> location => True)
  (frame_choice_bijection (change_frame da config g))
  (precondition_satisfied da config g)).
pose (f_inv := existT (fun _ : location -> location => True)
  (frame_choice_bijection (change_frame da config g) ⁻¹)
  (precondition_satisfied_inv da config g)).
change_LHS (lift f_inv (gatherW_pgm (obs_from_config
  (map_config (lift f) config)
  ((lift f) (config (Good g)))
))).
assert (Proper (equiv ==> equiv) (projT1 f)) as f_compat.
{ unfold f ; cbn -[equiv]. intros x y Hxy ; now rewrite Hxy. }
unfold gatherW_pgm ; destruct_match.
+ rewrite multi_support_map in a by auto.
  cbn -[equiv inverse config_list location] in *.
  rewrite <-aligned_similarity in a. change_LHS (center (change_frame da config g)).
  rewrite Hsim ; cbn -[equiv config_list] ; unfold id.
  now destruct_match ; intuition.
+ rewrite multi_support_map in * by auto.
  cbn -[equiv inverse config_list location multi_support] in *.
  pose (sim := change_frame da config g) ; fold sim in n0 ; fold sim.
  rewrite <-aligned_similarity in n0. destruct_match ; intuition.
  apply weber_unique with (config_list config) ; auto ; [now apply weber_calc_correct|].
  apply weber_similarity with sim. cbn -[config_list]. rewrite Bijection.section_retraction.
  now apply weber_calc_correct.
Qed.

(* This is the goal (for all demons and configs). *)
Definition eventually_aligned config (d : demon) (r : robogram) :=
  Stream.eventually
    (Stream.forever (Stream.instant (fun c => aligned (config_list c))))
    (execute r d config).

(* If the robots are aligned, they stay aligned. *)
Lemma round_preserves_aligned da config : similarity_da_prop da ->
  aligned (config_list config) -> aligned (config_list (round gatherW da config)).
Proof using .
intros Hsim Halign. assert (round gatherW da config == config) as H.
{ intros id. rewrite round_simplify by auto. repeat destruct_match ; auto. }
now rewrite H.
Qed.

Lemma aligned_over config (d : demon) :
  Stream.forever (Stream.instant similarity_da_prop) d ->
  aligned (config_list config) ->
  Stream.forever (Stream.instant (fun c => aligned (config_list c))) (execute gatherW d config).
Proof using .
revert config d.
cofix Hind. intros config d Hsim Halign. constructor.
+ cbn -[config_list]. apply Halign.
+ cbn -[config_list]. simple apply Hind ; [apply Hsim |].
  apply round_preserves_aligned ; [apply Hsim | apply Halign].
Qed.

Lemma sub_lt_sub (i j k : nat) : j < i <= k -> k - i < k - j.
Proof using lt_0n. lia. Qed.

Lemma list_in_length_n0 {A : Type} x (l : list A) : List.In x l -> length l <> 0.
Proof using . intros Hin. induction l as [|y l IH] ; cbn ; auto. Qed.

(* This would have been much more pleasant to do with mathcomp's tuples. *)
Lemma config_list_In_combine x x' c c' :
  List.In (x, x') (combine (config_list c) (config_list c')) <->
  exists id, x == c id /\ x' == c' id.
Proof using lt_0n.
assert (g0 : G).
{ change G with (fin n). apply (exist _ 0). lia. }
split.
+ intros Hin. apply (@In_nth (location * location) _ _ (c (Good g0), c' (Good g0))) in Hin.
  destruct Hin as [i [Hi Hi']].
  rewrite combine_nth in Hi' by now repeat rewrite config_list_length. inv Hi'.
  assert (i < n) as Hin.
  {
    eapply Nat.lt_le_trans ; [exact Hi|]. rewrite combine_length.
    repeat rewrite config_list_length. rewrite Nat.min_id. cbn. lia.
  }
  pose (g := exist (fun x => x < n) i Hin).
  change (fin n) with G in *. exists (Good g) ;
  split ; rewrite config_list_spec, map_nth ; f_equiv ; unfold names ;
    rewrite app_nth1, map_nth by (now rewrite map_length, Gnames_length) ;
    f_equiv ; cbn ; change G with (fin n) ; apply nth_enum.
+ intros [[g|b] [Hx Hx']].
  - assert ((x, x') = nth (proj1_sig g) (combine (config_list c) (config_list c')) (c (Good g0), c' (Good g0))) as H.
    {
      rewrite combine_nth by now repeat rewrite config_list_length.
      destruct g as [g Hg].
      repeat rewrite config_list_spec, map_nth. rewrite Hx, Hx'. unfold names.
      repeat rewrite app_nth1, map_nth by now rewrite map_length, Gnames_length.
      repeat f_equal ; cbn ; change G with (fin n) ; erewrite nth_enum ; reflexivity.
    }
    rewrite H. apply nth_In. rewrite combine_length. repeat rewrite config_list_length.
    rewrite Nat.min_id. cbn. destruct g. cbn. lia.
  - exfalso. assert (Hbyz := In_Bnames b). apply list_in_length_n0 in Hbyz. rewrite Bnames_length in Hbyz. auto.
Qed.

(* This measure strictly decreases whenever a robot moves. *)
Definition measure config :=
  let ps := config_list config in
  n - countA_occ equiv R2_EqDec (weber_calc ps) ps.

Local Instance measure_compat : Proper (equiv ==> eq) measure.
Proof using . intros c c' Hc. unfold measure. now rewrite Hc. Qed.

(* All the magic is here : when the robots move
 * they go towards the weber point so it is preserved.
 * This still holds in a flexible and/or asynchronous setting.
 * The point calculated by weber_calc thus stays the same during an execution,
 * until the robots are colinear. *)
Lemma round_preserves_weber config da w :
  similarity_da_prop da -> Weber (config_list config) w ->
    Weber (config_list (round gatherW da config)) w.
Proof using lt_0n.
intros Hsim Hweb. apply weber_contract with (config_list config) ; auto.
unfold contract. rewrite Forall2_Forall, Forall_forall by now repeat rewrite config_list_length.
intros [x x']. rewrite config_list_In_combine.
intros [id [Hx Hx']]. revert Hx'. rewrite round_simplify by auto.
repeat destruct_match ; intros Hx' ; rewrite Hx, Hx' ; try apply segment_end.
assert (w == weber_calc (config_list config)) as Hw.
{ apply weber_unique with (config_list config) ; auto. now apply weber_calc_correct. }
rewrite <-Hw. apply segment_start.
Qed.

(* If a robot moves, either the measure decreases or the robots become colinear. *)
Lemma round_decreases_measure config da :
  similarity_da_prop da ->
  moving gatherW da config <> nil ->
    aligned (config_list (round gatherW da config)) \/
    measure (round gatherW da config) < measure config.
Proof using lt_0n.
intros Hsim Hmove.
destruct (aligned_dec (config_list (round gatherW da config))) as [Rcol | RNcol] ; [now left|right].
assert (weber_calc (config_list (round gatherW da config)) == weber_calc (config_list config)) as Hweb.
{
  apply weber_unique with (config_list (round gatherW da config)) ; auto.
  + apply round_preserves_weber ; [auto | apply weber_calc_correct].
  + apply weber_calc_correct.
}
unfold measure. apply sub_lt_sub. split.
+ destruct (not_nil_In Hmove) as [i Hi]. apply moving_spec in Hi.
  rewrite Hweb. apply countA_occ_lt.
  - rewrite Forall2_Forall, Forall_forall. intros [x x'] Hin.
    apply config_list_In_combine in Hin. destruct Hin as [j [-> ->]].
    rewrite round_simplify by auto. repeat destruct_match ; intuition.
    repeat rewrite config_list_length. reflexivity.
  - apply Exists_exists. exists (config i, round gatherW da config i).
    split ; [| now auto].
    apply config_list_In_combine. exists i ; intuition.
+ etransitivity ; [apply countA_occ_length_le|].
  rewrite config_list_length. cbn ; lia.
Qed.

Lemma gathered_aligned ps x :
  (Forall (fun y => y == x) ps) -> aligned ps.
Proof using .
rewrite Forall_forall. intros Hgathered.
unfold aligned. rewrite ForallTriplets_forall.
intros a b c Ha Hb Hc.
apply Hgathered in Ha, Hb, Hc. rewrite Ha, Hb, Hc, add_opp.
apply colinear_origin_r.
Qed.

(* If the robots aren't aligned yet then there exists at least one robot which,
 * if activated, will move.
 * Any robot that isn't on the weber point will do the trick. *)
Lemma one_must_move config : ~aligned (config_list config) ->
  exists r, forall da, similarity_da_prop da -> activate da r = true ->
                       round gatherW da config r =/= config r.
Proof using .
intros Nalign.
cut (exists r, config r =/= weber_calc (config_list config)).
{
  intros [r Hr]. exists r. intros da Hsim Hact. rewrite round_simplify by auto.
  repeat destruct_match ; intuition.
}
assert (List.Exists (fun x => x =/= weber_calc (config_list config)) (config_list config)) as HE.
{
  apply neg_Forall_Exists_neg ; [intros ; apply equiv_dec|].
  revert Nalign. apply contra. apply gathered_aligned.
}
rewrite Exists_exists in HE. destruct HE as [x [Hin Hx]].
apply (@In_InA R2 equiv _) in Hin.
foldR2. change location_Setoid with state_Setoid in *. rewrite config_list_InA in Hin.
destruct Hin as [r Hr]. exists r. now rewrite <-Hr.
Qed.

(* Fairness entails progress. *)
Lemma fair_first_move (d : demon) config :
  Fair d -> Stream.forever (Stream.instant similarity_da_prop) d ->
  ~(aligned (config_list config)) -> FirstMove gatherW d config.
Proof using .
intros Hfair Hsim Nalign.
destruct (one_must_move config Nalign) as [id Hmove].
destruct Hfair as [locallyfair Hfair].
specialize (locallyfair id).
revert config Nalign Hmove.
induction locallyfair as [d Hnow | d] ; intros config Nalign Hmove.
* apply MoveNow. apply Hmove in Hnow.
  + rewrite <-(moving_spec gatherW (Stream.hd d) config id) in Hnow.
    intros Habs. now rewrite Habs in Hnow.
  + apply Hsim.
* destruct (moving gatherW (Stream.hd d) config) as [| id' mov] eqn:Hmoving.
  + apply MoveLater ; trivial.
    apply IHlocallyfair.
    - apply Hfair.
    - apply Hsim.
    - apply no_moving_same_config in Hmoving. now rewrite Hmoving.
    - intros da Hda Hactive. apply no_moving_same_config in Hmoving.
      rewrite (Hmoving id).
      apply (round_compat (reflexivity gatherW) (reflexivity da)) in Hmoving.
      rewrite (Hmoving id).
      now apply Hmove.
  + apply MoveNow. rewrite Hmoving. discriminate.
Qed.

(* The proof is essentially a well-founded induction on [measure config].
 * Fairness ensures that the measure must decrease at some point. *)
Theorem weber_correct (d : demon) config :
  Fair d ->
  Stream.forever (Stream.instant similarity_da_prop) d ->
  eventually_aligned config d gatherW.
Proof using lt_0n.
remember (measure config) as k.
generalize dependent d. generalize dependent config.
pattern k. apply (well_founded_ind lt_wf). clear k.
intros k IHk config Hk d Hfair Hsim.
destruct (aligned_dec (config_list config)) as [align | Nalign] ;
  [now apply Stream.Now, aligned_over|].
induction (fair_first_move config Hfair Hsim Nalign) as [d config Hmove | d config Hmove FM IH_FM] ;
  destruct Hsim as [Hsim_hd Hsim_tl] ; cbn in Hsim_hd ; apply Stream.Later.
+ destruct (round_decreases_measure config Hsim_hd Hmove) as [Ralign | Rmeasure].
  - now apply Stream.Now, aligned_over.
  - eapply IHk.
    * rewrite Hk. exact Rmeasure.
    * reflexivity.
    * destruct Hfair as [_ Hfair_tl]. exact Hfair_tl.
    * exact Hsim_tl.
+ apply no_moving_same_config in Hmove.
  apply IH_FM ; (try rewrite Hmove) ; auto.
  destruct Hfair as [_ Hfair_tl]. exact Hfair_tl.
Qed.

End Alignment.


(*
  This file proves that the width used by the rem register in
  Hausner's implementation if large enough to store any intermediate
  value that may result while computing the quotient of two
  floating point binary numbers.
*)

Require Import aux.
Require Import base.
Require Import Reals.
Require Import micromega.Lra.

Open Scope R_scope.

(** Represents the dividend. *)
Parameter a : R.

(** Represents the divisor. *)
Parameter b : R.

(**
  Asserts the lower and upper bounds on the
  dividend and divisor.

  These follow because both [a] and [b], have
  the form: 1.b0b1...bn.
*)
Axiom a_lower_bound : 1 <= a.
Axiom a_upper_bound : a < 2.
Axiom b_lower_bound : 1 <= b.
Axiom b_upper_bound : b < 2.

(**
  Accepts a natural number, [n], and returns the
  bit append onto our quotient approximation in
  the n-th iteration.
*)
Parameter bit : nat -> R.

(**
  Accepts a natural number, [n], and returns
  the quotient approximation generated in the
  n-th iteration.
*)
Parameter approx : nat -> R.

Axiom bit_0 : forall n : nat, a < b * (approx n + 1/2^n) -> bit n = 0.

Axiom bit_1 : forall n : nat, b * (approx n + 1/2^n) <= a -> bit n = 1.

(**
  Asserts that [bit n] always returns a binary
  digit - i.e. a bit.
*)
Lemma bit_is_bit
  : forall n : nat, bit n = 0 \/ bit n = 1.
Proof.
  exact
    (fun n
      => or_ind
          (fun H : a < b * (approx n + 1/2^n)
            => or_introl (bit n = 1) (bit_0 n H))
          (fun H : b * (approx n + 1/2^n) <= a
            => or_intror (bit n = 0) (bit_1 n H))
          (Rlt_or_le a (b * (approx n + 1/2^n)))).
Qed.

(**
  Asserts that the initial quotient approximation
  is 0.
*)
Axiom approx_0 : approx 0 = 0.

(**
  Asserts that each quotient approximation is
  produced by appending a bit onto the end of
  the previous approximation.
*)
Axiom approx_Sn : forall n : nat, approx (S n) = approx n + bit n/2^n.

(**
  Accepts a natural number, [n], and returns
  a measure of the error between the current
  quotient approximation and the true value.
*)
Parameter error : nat -> R.

(** Represents the error equation. *)
Axiom error_n : forall n : nat, error n = a - b * approx n.

(** Asserts that the error is always positive. *)
Axiom error_is_pos : forall n : nat, 0 <= error n.

Lemma bit_0_inv
  : forall n : nat, bit n = 0 -> a < b * (approx n + 1/2^n).
Proof.
  exact
    (fun n H
      => or_ind
           (fun H0 : a < b * (approx n + 1/2^n)
             => H0)
           (fun H0 : b * (approx n + 1/2^n) <= a
             => False_ind _
                  (R1_neq_R0 (H || X = 0 @X by <- bit_1 n H0)))
           (Rlt_or_le a (b * (approx n + 1/2^n)))).
Qed.

Lemma bit_1_inv
  : forall n : nat, bit n = 1 -> b * (approx n + 1/2^n) <= a.
Proof.
  exact
    (fun n H
      => or_ind
           (fun H0 : a < b * (approx n + 1/2^n)
             => False_ind _
                  (R1_neq_R0 (eq_sym (H || X = 1 @X by <- bit_0 n H0))))
           (fun H0 : b * (approx n + 1/2^n) <= a
             => H0)
           (Rlt_or_le a (b * (approx n + 1/2^n)))).
Qed.

Lemma approx_lower_bound_aux_0 : 0 <= 0 + 2. Proof. lra. Qed.

Lemma approx_lower_bound_aux_1
  : forall n : nat, bit n = 0 -> b * (approx n + 1/2^n) = b * (approx (S n) + 2/2^(S n)).
Proof.
  intros n H.
  apply (Rmult_eq_compat_l b (approx n + 1/2^n) (approx (S n) + 2/2^(S n))).
  rewrite (approx_Sn n).
  rewrite (Rplus_assoc (approx n) (bit n/2^n) (2/2^(S n))).
  apply (Rplus_eq_compat_l (approx n) (1/2^n) (bit n/2^n + 2/2^(S n))).
  rewrite H.
  unfold Rdiv.
  rewrite (Rmult_0_l (/2^n)).
  simpl.
  rewrite (Rinv_mult_distr 2 (2^n) neq_2_0 (pow_nonzero 2 n neq_2_0)).
  rewrite <- (Rmult_assoc 2 (/2) (/2^n)).
  rewrite (Rinv_r 2 neq_2_0).
  fold (Rdiv 1 (2^n)).
  rewrite (Rplus_0_l (1/2^n)).
  reflexivity.
Qed.

Lemma approx_lower_bound_aux_2
  : forall n : nat, approx n + 1/2^n + 1/2^n = approx n + 2/2^n.
Proof.
  intro n.
  rewrite (Rplus_assoc (approx n) (1/2^n) (1/2^n)).
  apply (Rplus_eq_compat_l (approx n) (1/2^n + 1/2^n) (2/2^n)).
  unfold Rdiv.
  rewrite <- (Rmult_plus_distr_r 1 1 (/2^n)).
  rewrite (ltac:(lra) : 1 + 1 = 2).
  reflexivity.
Qed.

Lemma approx_lower_bound_aux_3
  : forall n : nat, 2/2^(S n) = 1/2^n.
Proof.
  intro n.
  simpl.
  unfold Rdiv.
  rewrite (Rinv_mult_distr 2 (2^n) neq_2_0 (pow_nonzero 2 n neq_2_0)).
  rewrite <- (Rmult_assoc 2 (/2) (/2^n)).
  rewrite (Rinv_r 2 neq_2_0).
  reflexivity.
Qed.

Lemma approx_lower_bound
  :  forall n : nat, a < b * (approx n + 2/2^n).
Proof.
  exact
    (nat_ind _
      (Rlt_le_trans a 2 (b * (0 + 2))
        a_upper_bound
        (Rle_trans 2 (1 * (0 + 2)) (b * (0 + 2))
          (ltac:(lra) : 2 <= 1 * (0 + 2))
          (Rmult_le_compat_r (0 + 2) 1 b
            approx_lower_bound_aux_0
            b_lower_bound))
        || a < b * (X + 2) @X by approx_0
        || a < b * (approx 0 + X) @X by (ltac:(field) : 2/2^0 = 2))
      (fun n (H : a < b * (approx n + 2/2^n))
        => or_ind
             (fun H0 : bit n = 0
               => ltac:(
                    rewrite <- (approx_lower_bound_aux_1 n H0);
                    exact (bit_0_inv n H0)) :
                  a < b * (approx (S n) + 2 / 2 ^ S n))
             (fun H0 : bit n = 1
               => H
                  || a < b * X @X by approx_lower_bound_aux_2 n
                  || a < b * (approx n + X/2^n + 1/2^n) @X by H0
                  || a < b * (X + 1/2^n) @X by approx_Sn n
                  || a < b * (approx (S n) + X) @X by approx_lower_bound_aux_3 n)
             (bit_is_bit n))).
Qed.

Lemma error_upper_bound_aux_0 : forall n : nat, 0 < 2/2^n.
Proof.
  intro n.
  unfold Rdiv.
  exact (Rmult_lt_0_compat 2 (/2^n) lt_0_2 (Rlt_inv_2n n)).
Qed.

Lemma error_upper_bound_aux_1 : forall n : nat, 4/2^n = 2 * (2/2^n).
Proof.
  intro n.
  rewrite <- (eq_2_2_4).
  unfold Rdiv.
  exact (Rmult_assoc 2 2 (/2^n)).
Qed.

Theorem error_upper_bound
  :  forall n : nat, error n < 4/2^n.
Proof.
  exact
    (fun n
      => Rlt_trans
           (error n) (b * (2/2^n)) (2 * (2/2^n))
           (Rplus_lt_compat_r
             (- (b * approx n)) a (b * approx n + b * (2/2^n))
             (approx_lower_bound n
               || a < X @X by <- Rmult_plus_distr_l b (approx n) (2/2^n))
             || X < b * approx n + b * (2/2^n) - b * approx n @X by error_n n
             || error n < X @X by (ltac:(ring) : b * approx n - b * approx n + b * (2/2^n) = b * approx n + b * (2/2^n) - b * approx n)
             || error n < X + b * (2/2^n) @X by <- Rplus_opp_r (b * approx n)
             || error n < X @X by <- Rplus_0_l (b * (2/2^n)))
           (Rmult_lt_compat_r (2/2^n) b 2
             (error_upper_bound_aux_0 n)
              b_upper_bound)
           || error n < X @X by error_upper_bound_aux_1 n).
Qed.


(** * Tests for vectors as iterated products. *)
(** Gianluca Amato,  Marco Maggesi, Cosimo Perini Brogi 2019-2021 *)

Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.Combinatorics.Vectors.

Local Open Scope stn.

Section Tests_el.

  Context {A : UU} {a b c d:A}.

  Let v := vcons a (vcons b (vcons c (vcons d vnil))).

  Goal el v (●0) = a. reflexivity. Qed.
  Goal el v (●1) = b. reflexivity. Qed.
  Goal el v (●2) = c. reflexivity. Qed.
  Goal el v (●3) = d. reflexivity. Qed.

  Goal make_vec (el v) = v. reflexivity. Qed.

  Let f : ⟦ 4 ⟧ → A := Eval compute in (el v).

  Goal (el (make_vec f) = f). reflexivity. Qed.

End Tests_el.

Section Test_vec_foldr.

  Context {A B : UU} (f : A -> B -> B) (b : B) (p q r : A).

  Let v := vcons p (vcons q (vcons r vnil)).

  Eval compute in vec_foldr f b v.

  Goal vec_foldr f b v = f p (f q (f r b)). reflexivity. Qed.

End Test_vec_foldr.

Section Test_vec_foldr1.

  Context {A : UU} (f : A -> A -> A)  (p q r t : A).

  Let v := vcons p (vcons q (vcons r (vcons t vnil))).

  Eval compute in vec_foldr1 f v.

  Goal vec_foldr1 f v = f p (f q (f r t)). reflexivity. Qed.

End Test_vec_foldr1.

Section Test_vec_append.

  Context {A : UU} {a b c d e : A}.

  Let u := vcons a (vcons b (vcons c vnil)).
  Let v := vcons d (vcons e vnil).
  Let w := vcons a (vcons b (vcons c (vcons d (vcons e vnil)))).

  Eval compute in vec_append u v.

  Goal vec_append u v = w. reflexivity. Qed.

End Test_vec_append.


(*******************************************************************************

Title: Equalizers.v
Authors: Jeremy Avigad, Chris Kapulkin, Peter LeFanu Lumsdaine
Date: 1 March 2013

Basic results on equalizers. Just a stub for now; given a file of its
own since it is used in both [Limits.v] and [Pullbacks.v], which are
otherwise independent.

TODO (mid): add a section on the universal property of equalizers.

*******************************************************************************)

Require Import HoTT.
Require Import Auxiliary.

Section Equalizers.

Definition equalizer {A B : Type} (f : A -> B) (g : A -> B)
  := { x:A & (f x) = (g x) }.

End Equalizers.

(*
Local Variables:
coq-prog-name: "hoqtop"
End:
*)


Require Export List. Export ListNotations.
Require Import ZArith.
Local Open Scope Z_scope.
Require Import VST.floyd.sublist.

Fixpoint repeat_op_nat{T: Type}(n: nat)(start: T)(op: T -> T): T := match n with
| O => start
| S m => op (repeat_op_nat m start op)
end.

Definition repeat_op{T: Type}(n: Z)(start: T)(op: T -> T): T := repeat_op_nat (Z.to_nat n) start op.

Lemma repeat_op_step: forall {T: Type} (i: Z) (start: T) (op: T -> T),
  0 <= i ->
  repeat_op (i + 1) start op = op (repeat_op i start op).
Proof.
  intros. unfold repeat_op. rewrite Z2Nat.inj_add by omega.
  rewrite Nat.add_1_r. simpl. reflexivity.
Qed.

Fixpoint repeat_op_table_nat{T: Type}(n: nat)(start: T)(op: T -> T): list T := match n with
| O => []
| S m => (repeat_op_table_nat m start op) ++ [repeat_op_nat m start op]
end.

Definition repeat_op_table{T: Type}(n: Z)(start: T)(op: T -> T): list T :=
  repeat_op_table_nat (Z.to_nat n) start op.

Lemma repeat_op_table_step: forall {T: Type} (i: Z) (start: T) (op: T -> T),
  0 <= i ->
  repeat_op_table (i + 1) start op = (repeat_op_table i start op) ++ [repeat_op i start op].
Proof.
  intros. unfold repeat_op_table. rewrite Z2Nat.inj_add by omega.
  rewrite Nat.add_1_r. simpl. reflexivity.
Qed.

Lemma repeat_op_table_nat_length: forall {T: Type} (i: nat) (x: T) (f: T -> T),
  length (repeat_op_table_nat i x f) = i.
Proof.
  intros. induction i. reflexivity. simpl. rewrite app_length. simpl.
  rewrite IHi. omega.
Qed.

Lemma repeat_op_table_length: forall {T: Type} (i: Z) (x: T) (f: T -> T),
  0 <= i ->
  Zlength (repeat_op_table i x f) = i.
Proof.
  intros. unfold repeat_op_table.
  rewrite Zlength_correct. rewrite repeat_op_table_nat_length.
  apply Z2Nat.id. assumption.
Qed.

Lemma repeat_op_nat_id: forall {T: Type} (n: nat) (v: T),
  repeat_op_nat n v id = v.
Proof.
  intros. induction n.
  - reflexivity.
  - simpl. apply IHn.
Qed.

Lemma repeat_op_table_nat_id_app: forall {T: Type} (len1 len2: nat) (v: T),
  repeat_op_table_nat (len1 + len2) v id
  = repeat_op_table_nat len1 v id ++ repeat_op_table_nat len2 v id.
Proof.
  intros. induction len2.
  - simpl. replace (len1 + 0)%nat with len1 by omega. rewrite app_nil_r. reflexivity.
  - replace (len1 + S len2)%nat with (S (len1 + len2)) by omega. simpl.
    rewrite IHlen2. rewrite <- app_assoc. f_equal. f_equal. do 2 rewrite repeat_op_nat_id.
    reflexivity.
Qed.

Lemma sublist_repeat_op_table_id: forall {T: Type} (lo n: Z) (v: T),
  0 <= lo ->
  0 <= n ->
  sublist lo (lo + n) (repeat_op_table (lo + n) v id) = repeat_op_table n v id.
Proof.
  intros.
  replace (lo + n) with (Zlength (repeat_op_table (lo + n) v id)) at 1
    by (apply repeat_op_table_length; omega).
  rewrite sublist_skip by omega.
  unfold repeat_op_table at 1. rewrite Z2Nat.inj_add by omega.
  rewrite repeat_op_table_nat_id_app.
  rewrite Zskipn_app1 by (
    rewrite Zlength_correct;
    rewrite repeat_op_table_nat_length;
    rewrite Z2Nat.id; omega
  ).
  rewrite skipn_short; [ reflexivity | ].
  rewrite repeat_op_table_nat_length. omega.
Qed.

Fixpoint fill_list_nat{T: Type}(n: nat)(f: nat -> T): list T := match n with
| O => []
| S m => (fill_list_nat m f) ++ [f m]
end.

Definition fill_list{T: Type}(n: Z)(f: Z -> T): list T :=
  fill_list_nat (Z.to_nat n) (fun i => f (Z.of_nat i)).

Lemma fill_list_step: forall {T: Type} (n: Z) (f: Z -> T),
  0 <= n ->
  fill_list (n + 1) f = fill_list n f ++ [f n].
Proof.
  intros. unfold fill_list. rewrite Z2Nat.inj_add by omega.
  rewrite Nat.add_1_r. simpl. rewrite Z2Nat.id by omega. reflexivity.
Qed.

Ltac eval_list l :=
  let l' := eval hnf in l in lazymatch l' with
  | ?h :: ?tl => let tl' := eval_list tl in constr:(h :: tl')
  | (@nil ?T) => constr:(@nil T)
  end.


Require Export Base.

Section operations.

Variable T : finType.
Variables A B C : {set T}.

(*2.1*)
Lemma cup_def :
    A ∪ B = [set x | (x ∈ A) || (x ∈ B)].
Proof.
    auto.
Qed.

(*2.2*)
Lemma sub_cup_l :
    A ⊂ (A ∪ B).
Proof.
    apply subsetUl.
Qed.

Lemma sub_cup_r :
    B ⊂ (A ∪ B).
Proof.
    apply subsetUr.
Qed.

(*2.3*)
Lemma subsub__Usub :
    A ⊂ C -> B ⊂ C -> (A ∪ B) ⊂ C.
Proof.
    move => AC AB; apply /subUsetP => //=.
Qed.

(*2.4*)
Lemma setU_self :
    A ∪ A = A.
Proof.
    apply extension; apply /subsetP => x H.
    +   case /setUP : H => //.
    +   apply /setUP; left => //.
Qed.

(*2.5*)
Lemma cup_comm :
    A ∪ B = B ∪ A.
Proof.
    apply setUC.
Qed.

(*2.6*)
Lemma cup_assoc :
    (A ∪ B) ∪ C = A ∪ (B ∪ C).
Proof.
    apply extension; apply /subsetP => x H;
        apply /setUP; case /setUP : H => H;
        try (case /setUP : H => H).
    +   left => //.
    +   right; apply /setUP; left => //.
    +   right; apply /setUP; right => //.
    +   left; apply /setUP; left => //.
    +   left; apply /setUP; right => //.
    +   right => //.
Restart.
    by rewrite -setUA.
Qed.

(*2.7*)
Lemma sub__setU :
    A ⊂ B <-> A ∪ B = B.
Proof.
    split => H.
    +   move /subsetP : H => H.
        apply extension; apply /subsetP => x Hx.
        -   case /setUP : Hx => H0 => //.
            apply H => //.
        -   apply /setUP; right => //.
    +   rewrite -H.
        apply subsetUl.
Qed.

(*2.8*)
Lemma sub__UsubU :
    A ⊂ B -> (A ∪ C) ⊂ (B ∪ C).
Proof.
    move /subsetP => H.
    apply /subsetP => x Hx.
    case /setUP : Hx => H0; apply /setUP; [left|right] => //.
    by apply H.
Qed.

(*2.9*)
Lemma empty_cup :
    ∅ ∪ A = A.
Proof.
    apply set0U.
Qed.

(*2.10*)
Goal (A ∪ B) ∩ C = (A ∩ C) ∪ (B ∩ C).
apply setIUl. Qed.

Goal (A ∩ B) ∪ C = (A ∪ C) ∩ (B ∪ C).
apply setUIl. Qed.

(*2.11*)
Goal (A ∪ B) ∩ A = A.
apply setUK. Qed.

Goal (A ∩ B) ∪ A = A.
apply setIK. Qed.

(*2.12*)
Goal A ∩ (¬ A) = ∅.
Proof.
    apply setICr.
Restart.
    apply extension; apply /subsetP => x H.
    +   case /setIP : H => H /setCP F => //.
    +   rewrite in_set0 in H.
        inversion H.
Qed.

Goal A ∪ (¬ A) = setT.
Proof.
    apply setUCr.
Restart.
    apply extension; apply /subsetP => x H.
    +   apply in_setT.
    +   apply /setUP.
        remember (x ∈ A) as Hx.
        destruct Hx; [left => //|right].
        apply /setCP => F.
        rewrite F in HeqHx => //.
Qed.

(*2.13*)
Goal ¬ (¬ A) = A.
Proof.
    apply extension; apply /subsetP => x;
    rewrite 2!in_setC; rewrite Bool.negb_involutive => //.
Qed.

(*2.14*)
Goal  ¬ ∅ = [set: T].
Proof.
    apply setC0.
Restart.
    apply extension; apply /subsetP => x Hx.
    +   apply in_setT.
    +   rewrite in_setC.
        rewrite in_set0 => //.
Qed.

Goal ¬ [set : T] = ∅.
Proof.
    apply setCT.
Restart.
    apply extension; apply /subsetP => x Hx.
    +   rewrite in_setC in Hx.
        rewrite in_setT in Hx.
        inversion Hx.
    +   rewrite in_set0 in Hx.
        inversion Hx.
Qed.

(*2.15*)
Goal A ⊂ B -> (¬ B) ⊂ (¬ A).
Proof.
    move => /subsetP H.
    apply /subsetP => x /setCP Hb.
    apply /setCP => F.
    contradict Hb; apply H => //.
Qed.

(*2.16*)

Goal ¬ (A ∪ B) = (¬ A) ∩ (¬ B).
Proof.
    apply setCU.
Restart.
    apply extension; apply /subsetP => x Hx.
    +   move /setCP : Hx => Hx.
        apply /setIP; split; apply /setCP => F;
        apply Hx; apply /setUP; [left|right] => //.
    +   move /setIP : Hx => [/setCP nHa /setCP nHb].
        apply /setCP; case /setUP => [Ha|Hb] => //.
Qed.

Goal ¬ (A ∩ B) = (¬ A) ∪ (¬ B).
    apply setCI.
Restart.
    apply extension; apply /subsetP => x Hx.
    +   apply /setUP.
        rewrite in_setC in Hx.
        move /setIP : Hx => Hx. (* H : ~~ b に対しても    、bP : reflect P b　が使える *)
        case : (not_and_or _ _ Hx) => H ;
        [left|right]; apply /setCP => //.
    +   apply /setCP => /setIP [Ha Hb].
        move /setUP : Hx => [/setCP nHa |/ setCP nHb] => //.
Qed.

Goal A ⊂ B -> (¬ B) ⊂ (¬ A).
Proof.
    move => /subsetP H.
    apply /subsetP => x /setCP nHB.
    apply /setCP => HA.
    apply nHB; apply H => //.
Qed.

Variable me : T.

Goal forall someone, someone ∈ ¬ [set me] -> someone <> me.
Proof.
    move => someone /setCP H /eqP F.
    apply H; rewrite in_set1 => //.
Qed.

End operations.

(* 2.17 *)
Section bigop1.
Variable (T : finType) (A C : {set T}) (U : {set {set T}}).

Goal A ∈ U -> A ⊂ (⊔ U).
Proof.
    move => AU; apply /subsetP => x xA; apply /bigUP; exists A => //.
Qed.

Goal A ∈ U -> ⊓ U ⊂ A.
Proof.
    move => AU; apply /subsetP => x /bigIP H; apply H => //.
Qed.

End bigop1.

Section bigop2.

Variable (T : finType) (C : {set T}) (U : {set {set T}}).

Goal (forall A, A ∈ U -> A ⊂ C) -> ⊔ U ⊂ C.
Proof.
    move => H; apply /subsetP => x /bigUP [Y [xY YU]].
    move : (H Y YU); move /subsetP; apply => //.
Qed.

Goal (forall A, A ∈ U -> C ⊂ A) -> C ⊂ ⊓ U.
Proof.
    move => H; apply /subsetP => x xC; apply /bigIP => Y YU.
    move : (H Y YU); move /subsetP; apply => //.
Qed.

End bigop2.


(*|
################
Subtyping in Coq
################

:Link: https://stackoverflow.com/q/41306638
|*)

(*|
Question
********

I defined Subtype as follows
|*)

Record Subtype {T : Type} (P : T -> Prop) := {
    subtype       :> Type;
    subtype_inj   :> subtype -> T;
    subtype_isinj : forall s t : subtype,
      (subtype_inj s = subtype_inj t) -> s = t;
    subtype_h     : forall x : T, P x -> (exists s : subtype,x = subtype_inj s);
    subtype_h0    : forall s : subtype, P (subtype_inj s)
  }.

(*| Can the following theorem be proven? |*)

Theorem Subtypes_Exist : forall {T} (P : T -> Prop), Subtype P.
Abort. (* .none *)

(*|
If not, is it provable from any well-known compatible axiom? Or Can I
add this as an axiom? Would it conflict with any usual axiom? (like
extensionality, functional choice, etc.)
|*)

(*|
Answer
******

Your definition is practically identical to the one of MathComp;
indeed, what you are missing mainly is injectivity due to proof
relevance.

For that, I am afraid you will need to assume propositional
irrelevance:
|*)

Require Import ProofIrrelevance.

Theorem Subtypes_Exist : forall {T} (P : T -> Prop), Subtype P.
Proof.
  intros T P; set (subtype_inj := @proj1_sig T P).
  apply (@Build_Subtype _ _ { x | P x} subtype_inj).
  + intros [s Ps] [t Pt]; simpl; intros ->.
    now rewrite (proof_irrelevance _ Ps Pt).
  + now intros x Px; exists (exist _ x Px).
  + now intro H; destruct H.
Qed.

(*|
You can always restrict you predicate ``P`` to a type which is
effectively proof-irrelevant, of course.
|*)


Require Import Rbase Ranalysis.
Require Import Rinterval Rfunctions Rfunction_def Rfunction_facts.
Require Import Ranalysis_def Ranalysis_def_simpl.
Require Import MyRIneq MyR_dist Lra.

Local Open Scope R_scope.

(** stricly_whatever implies whatever *)

Lemma strictly_increasing_in_increasing_in : forall D f,
  strictly_increasing_in D f -> increasing_in D f.
Proof.
intros D f f_incr x y Dx Dy [Hlt | Heq].
 left ; apply f_incr ; assumption.
 subst ; reflexivity.
Qed.

Lemma strictly_decreasing_in_decreasing_in : forall D f,
  strictly_decreasing_in D f -> decreasing_in D f.
Proof.
intros D f f_decr x y Dx Dy [Hlt | Heq].
 left ; apply f_decr ; assumption.
 subst ; reflexivity.
Qed.

Lemma strictly_monotonous_in_monotonous_in : forall D f,
 strictly_monotonous_in D f -> monotonous_in D f.
Proof.
intros D f [Hd | Hi] ;
 [left ; apply strictly_decreasing_in_decreasing_in |
 right ; apply strictly_increasing_in_increasing_in] ; assumption.
Qed.

Lemma strictly_increasing_increasing f : strictly_increasing f -> increasing f.
Proof.
  apply strictly_increasing_in_increasing_in.
Qed.

Lemma strictly_decreasing_decreasing f : strictly_decreasing f -> decreasing f.
Proof.
  apply strictly_decreasing_in_decreasing_in.
Qed.

Lemma strictly_monotonous_monotonous f : strictly_monotonous f -> monotonous f.
Proof.
  apply strictly_monotonous_in_monotonous_in.
Qed.

(** Strict monotonicity implies injectivity *)

Lemma strictly_increasing_in_injective_in : forall D f,
  strictly_increasing_in D f -> injective_in D f.
Proof.
intros D f f_inc x y x_in y_in feq ; destruct (Rtotal_order x y) as [Hlt | [Heq | Hgt]].
 destruct (Rlt_irrefl (f y)) ; apply Rle_lt_trans with (f x).
  rewrite feq ; reflexivity.
  apply f_inc ; assumption.
 assumption.
 destruct (Rlt_irrefl (f x)) ; apply Rle_lt_trans with (f y).
  rewrite feq ; reflexivity.
  apply f_inc ; assumption.
Qed.

Lemma strictly_decreasing_in_injective_in : forall D f,
  strictly_decreasing_in D f -> injective_in D f.
Proof.
intros D f f_dec x y x_in y_in feq ; destruct (Rtotal_order x y) as [Hlt | [Heq | Hgt]].
 destruct (Rlt_irrefl (f x)) ; apply Rle_lt_trans with (f y).
  rewrite feq ; reflexivity.
  apply f_dec ; assumption.
 assumption.
 destruct (Rlt_irrefl (f y)) ; apply Rle_lt_trans with (f x).
  rewrite feq ; reflexivity.
  apply f_dec ; assumption.
Qed.

Lemma strictly_monotonous_in_injective_in : forall D f,
  strictly_monotonous_in D f -> injective_in D f.
Proof.
intros D f [f_dec | f_inc] ;
 [apply strictly_decreasing_in_injective_in |
  apply strictly_increasing_in_injective_in] ; assumption.
Qed.

Lemma strictly_increasing_injective f : strictly_increasing f -> injective f.
Proof.
  apply strictly_increasing_in_injective_in.
Qed.

Lemma strictly_decreasing_injective f : strictly_decreasing f -> injective f.
Proof.
  apply strictly_decreasing_in_injective_in.
Qed.

Lemma strictly_monotonous_injective f : strictly_monotonous f -> injective f.
Proof.
  apply strictly_monotonous_in_injective_in.
Qed.

(** It also helps simplify Rmin / Rmax statements *)

Lemma increasing_in_Rmin_simpl :
  forall D f, increasing_in D f ->
  forall x y, D x -> D y -> x <= y -> Rmin (f x) (f y) = f x.
Proof.
intros D f f_inc x y Dx Dy Hxy ;
 assert (flb_lt_fub : f x <= f y) by (apply f_inc ; assumption) ;
 unfold Rmin ; destruct (Rle_dec (f x) (f y)) ; intuition.
Qed.

Lemma increasing_in_Rmax_simpl :
  forall D f, increasing_in D f ->
  forall x y, D x -> D y -> x <= y -> Rmax (f x) (f y) = f y.
Proof.
intros D f f_inc x y Dx Dy Hxy ;
 assert (flb_lt_fub : f x <= f y) by (apply f_inc ; assumption) ;
 unfold Rmax ; destruct (Rle_dec (f x) (f y)) ; intuition.
Qed.

Lemma decreasing_in_Rmin_simpl :
  forall D f, decreasing_in D f ->
  forall x y, D x -> D y -> x <= y -> Rmin (f x) (f y) = f y.
Proof.
intros D f f_dec x y Dx Dy Hxy ;
 assert (flb_lt_fub : f y <= f x) by (apply f_dec ; assumption) ;
 unfold Rmin ; destruct (Rle_dec (f x) (f y)) ; intuition.
Qed.

Lemma decreasing_in_Rmax_simpl :
  forall D f, decreasing_in D f ->
  forall x y, D x -> D y -> x <= y -> Rmax (f x) (f y) = f x.
Proof.
intros D f f_dec x y Dx Dy Hxy ;
 assert (flb_lt_fub : f y <= f x) by (apply f_dec ; assumption) ;
 unfold Rmax ; destruct (Rle_dec (f x) (f y)) ; intuition.
Qed.

(** Image of an interval throught a monotonous function *)

Lemma increasing_interval_image : forall f lb ub x,
  increasing_interval lb ub f -> interval lb ub x ->
  interval (f lb) (f ub) (f x).
Proof.
intros f lb ub x Hf x_in ; assert (lb_le_ub : lb <= ub) by
 (eapply interval_inhabited ; eassumption) ; split ; apply Hf.
 apply interval_l ; assumption.
 assumption.
 apply x_in.
 assumption.
 apply interval_r ; assumption.
 apply x_in.
Qed.

Lemma decreasing_interval_image : forall f lb ub x,
  decreasing_interval lb ub f -> interval lb ub x ->
  interval (f ub) (f lb) (f x).
Proof.
intros f lb ub x Hf x_in ; assert (lb_le_ub : lb <= ub) by
 (eapply interval_inhabited ; eassumption) ; split ; apply Hf.
 assumption.
 apply interval_r ; assumption.
 apply x_in.
 apply interval_l ; assumption.
 assumption.
 apply x_in.
Qed.

Lemma monotonous_interval_image : forall f lb ub x,
  monotonous_interval lb ub f -> interval lb ub x ->
  interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) (f x).
Proof.
intros f lb ub x [f_dec | f_inc] x_in ;
 assert (lbub : lb <= ub) by (eapply interval_inhabited, x_in).
 erewrite decreasing_in_Rmax_simpl, decreasing_in_Rmin_simpl ; try eassumption.
  apply decreasing_interval_image ; assumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
 erewrite increasing_in_Rmax_simpl, increasing_in_Rmin_simpl ; try eassumption.
  apply increasing_interval_image ; assumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
Qed.

Lemma strictly_increasing_interval_image : forall f lb ub x,
  strictly_increasing_interval lb ub f -> open_interval lb ub x ->
  open_interval (f lb) (f ub) (f x).
Proof.
intros f lb ub x Hf x_in ; assert (lb_le_ub : lb <= ub) by
 (left ; eapply open_interval_inhabited ; eassumption) ; split ; apply Hf.
 apply interval_l ; assumption.
 apply open_interval_interval ; assumption.
 apply x_in.
 apply open_interval_interval ; assumption.
 apply interval_r ; assumption.
 apply x_in.
Qed.

Lemma strictly_decreasing_interval_image : forall f lb ub x,
  strictly_decreasing_interval lb ub f -> open_interval lb ub x ->
  open_interval (f ub) (f lb) (f x).
Proof.
intros f lb ub x Hf x_in ; assert (lb_le_ub : lb <= ub) by
 (left ; eapply open_interval_inhabited ; eassumption) ; split ; apply Hf.
 apply open_interval_interval ; assumption.
 apply interval_r ; assumption.
 apply x_in.
 apply interval_l ; assumption.
 apply open_interval_interval ; assumption.
 apply x_in.
Qed.

Lemma strictly_monotonous_interval_image : forall f lb ub x,
  strictly_monotonous_interval lb ub f -> open_interval lb ub x ->
  open_interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) (f x).
Proof.
intros f lb ub x [f_dec | f_inc] x_in ;
 assert (lbub : lb <= ub) by (left ; eapply open_interval_inhabited, x_in).
 erewrite decreasing_in_Rmax_simpl, decreasing_in_Rmin_simpl.
  apply strictly_decreasing_interval_image ; assumption.
  apply strictly_decreasing_in_decreasing_in ; eassumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  assumption.
  apply strictly_decreasing_in_decreasing_in ; eassumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  assumption.
 erewrite increasing_in_Rmax_simpl, increasing_in_Rmin_simpl.
  apply strictly_increasing_interval_image ; assumption.
  apply strictly_increasing_in_increasing_in ; eassumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  assumption.
  apply strictly_increasing_in_increasing_in ; eassumption.
  apply interval_l ; assumption.
  apply interval_r ; assumption.
  assumption.
Qed.

(** Compatibility of variations with operations *)

Lemma increasing_in_opp : forall D f,
  increasing_in D f -> decreasing_in D (-f)%F.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_le_contravar, Hf ; assumption.
Qed.

Lemma increasing_in_opp_rev : forall D f,
  increasing_in D (- f)%F -> decreasing_in D f.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_le_cancel, Hf ; assumption.
Qed.

Lemma strictly_increasing_in_opp : forall D f,
  strictly_increasing_in D f -> strictly_decreasing_in D (-f)%F.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_lt_contravar, Hf ; assumption.
Qed.

Lemma strictly_increasing_in_opp_rev : forall D f,
  strictly_increasing_in D (- f)%F -> strictly_decreasing_in D f.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_lt_cancel, Hf ; assumption.
Qed.

Lemma decreasing_in_opp : forall D f,
  decreasing_in D f -> increasing_in D (-f)%F.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_le_contravar, Hf ; assumption.
Qed.

Lemma decreasing_in_opp_rev : forall D f,
  decreasing_in D (- f)%F -> increasing_in D f.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_le_cancel, Hf ; assumption.
Qed.

Lemma strictly_decreasing_in_opp : forall D f,
  strictly_decreasing_in D f -> strictly_increasing_in D (-f)%F.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_lt_contravar, Hf ; assumption.
Qed.

Lemma strictly_decreasing_in_opp_rev : forall D f,
  strictly_decreasing_in D (- f)%F -> strictly_increasing_in D f.
Proof.
intros D f Hf x y Dx Dy Hxy ; unfold opp_fct ;
 apply Ropp_lt_cancel, Hf ; assumption.
Qed.

(* TODO: more generic lemmas like these ones *)

Lemma increasing_in_plus : forall D f g,
  increasing_in D f -> increasing_in D g -> increasing_in D (f + g)%F.
Proof.
intros D f g Hf Hg x y Dx Dy Hxy ; unfold plus_fct ;
 apply Rplus_le_compat ; [apply Hf | apply Hg] ; assumption.
Qed.

Lemma increasing_in_minus : forall D f g,
  increasing_in D f -> decreasing_in D g -> increasing_in D (f - g)%F.
Proof.
intros D f g Hf Hg x y Dx Dy Hxy ; unfold plus_fct ;
 apply Rplus_le_compat ; [apply Hf | apply Ropp_le_contravar, Hg] ; assumption.
Qed.

Lemma strictly_increasing_strictly_decreasing_interval2 : forall f lb ub,
  strictly_increasing_interval lb ub f ->
  strictly_decreasing_interval (- ub) (- lb) (fun x => f(-x)).
Proof.
intros f c r f_incr ; intros x y x_in_B y_in_B x_lt_y.
 apply f_incr ; unfold interval in * ; try split ; intuition ; lra.
Qed.

Lemma strictly_decreasing_strictly_increasing_interval2 : forall f lb ub,
  strictly_decreasing_interval lb ub f ->
  strictly_increasing_interval (-ub) (-lb) (fun x => f(-x)).
Proof.
intros f c r f_decr ; intros x y x_in_B y_in_B x_lt_y.
 apply f_decr ; unfold interval in * ; try split ; intuition ; lra.
Qed.

Lemma strictly_increasing_reciprocal_interval_compat : forall f g lb ub,
  strictly_increasing_interval lb ub f ->
  reciprocal_interval (f lb) (f ub) f g ->
  (forall x, interval (f lb) (f ub) x -> interval lb ub (g x)) ->
  strictly_increasing_interval (f lb) (f ub) g.
Proof.
intros f g lb ub f_incr f_recip_g g_ok x y x_in_I y_in_I x_lt_y.
 destruct (Rlt_le_dec (g x) (g y)) as [T | F].
  assumption.
  destruct F as [F | F].
   assert (Hf : y < x).
    unfold reciprocal_interval, id in f_recip_g ; rewrite <- f_recip_g.
    apply Rgt_lt ; rewrite <- f_recip_g.
    unfold comp ; apply f_incr ; [apply g_ok | apply g_ok |] ; assumption.
    assumption.
    assumption.
   apply False_ind ; apply Rlt_irrefl with x ; apply Rlt_trans with y ; assumption.
   assert (Hf : x = y).
    unfold reciprocal_interval, id in f_recip_g ; rewrite <- f_recip_g.
    symmetry ; rewrite <- f_recip_g.
    unfold comp ; rewrite F ; reflexivity.
    assumption.
    assumption.
   rewrite Hf in x_lt_y ; elim (Rlt_irrefl _ x_lt_y).
Qed.

Lemma strictly_increasing_reciprocal_interval_comm: forall f g lb ub,
  (forall x, interval (f lb) (f ub) x -> interval lb ub (g x)) ->
  strictly_increasing_interval lb ub f ->
  reciprocal_interval (f lb) (f ub) f g ->
  reciprocal_interval lb ub g f.
Proof.
intros f g lb ub g_ok f_sinc Hfg x x_in ;
 assert (f_inc : increasing_interval lb ub f).
  apply strictly_increasing_in_increasing_in ; assumption.
 destruct (Req_dec (g (f x)) x) as [Heq | Hneq].
  assumption.
  destruct (Rlt_irrefl (f x)).
  destruct (Rdichotomy _ _ Hneq) as [Hlt | Hlt].
  apply Rle_lt_trans with (f (g (f x))).
   right ; rewrite Hfg.
    reflexivity.
    apply increasing_interval_image ; [apply strictly_increasing_in_increasing_in |] ; assumption.
   apply f_sinc ; [apply g_ok, increasing_interval_image | |] ; assumption.
  apply Rlt_le_trans with (f (g (f x))).
   apply f_sinc ; [| apply g_ok, increasing_interval_image |] ; assumption.
  right ; rewrite Hfg.
   reflexivity.
   apply increasing_interval_image ; assumption.
Qed.

Lemma strictly_decreasing_reciprocal_interval_comm: forall f g lb ub,
  (forall x, interval (f ub) (f lb) x -> interval lb ub (g x)) ->
  strictly_decreasing_interval lb ub f ->
  reciprocal_interval (f ub) (f lb) f g ->
  reciprocal_interval lb ub g f.
Proof.
intros f g lb ub g_ok f_sdec Hfg x x_in ;
 assert (f_dec : decreasing_interval lb ub f).
  apply strictly_decreasing_in_decreasing_in ; assumption.
 destruct (Req_dec (g (f x)) x) as [Heq | Hneq].
  assumption.
  destruct (Rlt_irrefl (f x)).
  destruct (Rdichotomy _ _ Hneq) as [Hlt | Hlt].
  apply Rlt_le_trans with (f (g (f x))).
   apply f_sdec ; [apply g_ok, decreasing_interval_image | |] ; assumption.
  right ; rewrite Hfg.
   reflexivity.
   apply decreasing_interval_image ; assumption.
  apply Rle_lt_trans with (f (g (f x))).
   right ; rewrite Hfg.
    reflexivity.
    apply decreasing_interval_image ; assumption.
   apply f_sdec ; [| apply g_ok, decreasing_interval_image |] ; assumption.
Qed.

(** Knowing f's variations and the ordering of f a and f b we can deduce a and b's ordering *)

Lemma strictly_increasing_open_interval_order : forall f lb ub a b,
  open_interval lb ub a -> open_interval lb ub b ->
  strictly_increasing_open_interval lb ub f ->
  f a < f b -> a < b.
Proof.
intros f lb ub a b a_in b_in Hf Hfafb ; destruct (Rlt_le_dec a b) as [altb | blea].
 assumption.
 destruct blea as [blta | beqa].
  destruct (Rlt_irrefl (f a)) ; transitivity (f b).
   assumption.
   apply Hf ; assumption.
  rewrite beqa in Hfafb ; destruct (Rlt_irrefl _ Hfafb).
Qed.

Lemma strictly_increasing_interval_order : forall f lb ub a b,
  open_interval lb ub a -> open_interval lb ub b ->
  strictly_increasing_open_interval lb ub f ->
  f a <= f b -> a <= b.
Proof.
intros f lb ub a b a_in b_in Hf Hfafb ; destruct (Rle_lt_dec a b) as [aleb | blta].
 assumption.
 destruct (Rlt_irrefl (f a)) ; apply Rle_lt_trans with (f b).
  assumption.
  apply Hf ; assumption.
Qed.


From Hammer Require Import Hammer.

Require Import PeanoNat.

Local Open Scope nat_scope.
Implicit Types m n p : nat.

Notation min := Nat.min (only parsing).

Definition min_0_l := Nat.min_0_l.
Definition min_0_r := Nat.min_0_r.
Definition succ_min_distr := Nat.succ_min_distr.
Definition plus_min_distr_l := Nat.add_min_distr_l.
Definition plus_min_distr_r := Nat.add_min_distr_r.
Definition min_case_strong := Nat.min_case_strong.
Definition min_spec := Nat.min_spec.
Definition min_dec := Nat.min_dec.
Definition min_case := Nat.min_case.
Definition min_idempotent := Nat.min_id.
Definition min_assoc := Nat.min_assoc.
Definition min_comm := Nat.min_comm.
Definition min_l := Nat.min_l.
Definition min_r := Nat.min_r.
Definition le_min_l := Nat.le_min_l.
Definition le_min_r := Nat.le_min_r.
Definition min_glb_l := Nat.min_glb_l.
Definition min_glb_r := Nat.min_glb_r.
Definition min_glb := Nat.min_glb.

Notation min_case2 := min_case (only parsing).
Notation min_SS := Nat.succ_min_distr (only parsing).


Require Import Mem.
Require Import List Omega Ring Word Pred Prog Hoare SepAuto BasicProg Array.
Require Import FunctionalExtensionality.

Set Implicit Arguments.
Set Default Proof Using "Type".

(* bijection on restricted domain *)

Section COND_BIJECTION.

  Variables A B : Type.
  Variable f : A -> B.
  Variable PA : A -> Prop.
  Variable PB : B -> Prop.

  Definition cond_injective :=
    forall x y : A, PA x -> PA y -> f x = f y -> x = y.

  Definition cond_surjective :=
    forall y : B, PB y -> {x : A | PA x /\ f x = y}.

  Inductive cond_bijective : Prop :=
    CondBijective : cond_injective -> cond_surjective -> cond_bijective.

  Section BIJECTION_INVERSION.

    Variable f' : B -> A.

    Definition cond_left_inverse :=
      forall x : A, PA x -> PB (f x) /\ f' (f x) = x.

    Definition cond_right_inverse :=
      forall y : B, PB y -> PA (f' y) /\ f (f' y) = y.

    Definition cond_inverse :=
      cond_left_inverse /\ cond_right_inverse.

    Lemma cond_left_inv_inj : cond_left_inverse -> cond_injective.
    Proof.
      intros H x y P1 P2 H0.
      pose proof (H x P1) as [P3 P4].
      rewrite <- P4.
      rewrite H0.
      apply H.
      auto.
    Qed.

    Lemma cond_right_inv_surj : cond_right_inverse -> cond_surjective.
    Proof.
      intros H y P1.
      pose proof (H y P1) as [P2 P3].
      rewrite <- P3.
      exists (f' y); intuition.
    Qed.

    Lemma cond_inv2bij : cond_inverse -> cond_bijective.
    Proof.
      intros [H1 H2].
      constructor.
      eapply cond_left_inv_inj; eauto.
      eapply cond_right_inv_surj; eauto.
    Qed.

    Lemma cond_inv_rewrite_right : forall y,
      cond_inverse -> PB y -> f (f' y) = y.
    Proof.
      intros; apply H; auto.
    Qed.

    Lemma cond_inv_rewrite_left : forall x,
      cond_inverse -> PA x -> f' (f x) = x.
    Proof.
      intros; apply H; auto.
    Qed.

    Lemma cond_inv_domain_right : forall y,
      cond_inverse -> PB y -> PA (f' y).
    Proof.
      intros; apply H; auto.
    Qed.

    Lemma cond_inv_domain_left : forall x,
      cond_inverse -> PA x -> PB (f x).
    Proof.
      intros; apply H; auto.
    Qed.

  End BIJECTION_INVERSION.

End COND_BIJECTION.

Theorem cond_inverse_sym : forall A B PA PB (f : A -> B) (f' : B -> A),
  cond_inverse f PA PB f'
  -> cond_inverse f' PB PA f.
Proof.
  firstorder.
Qed.

Theorem cond_inv2bij_inv : forall A B PA PB (f : A -> B) (f' : B -> A),
  cond_inverse f PA PB f'
  -> cond_bijective f' PB PA.
Proof.
  intros.
  eapply cond_inv2bij.
  apply cond_inverse_sym; eauto.
Qed.

Section MEMMATCH.

  Variable AT1 : Type.
  Variable AT2 : Type.
  Variable atrans : AT1 -> AT2.

  Variable AEQ1 : EqDec AT1.
  Variable AEQ2 : EqDec AT2.
  Variable V : Type.
  Variable m1 : @mem AT1 AEQ1 V.
  Variable m2 : @mem AT2 AEQ2 V.

  (* restrictions on atrans' domain and codomain *)
  Variable AP1 : AT1 -> Prop.
  Variable AP2 : AT2 -> Prop.

  (* decidablity of subdomain *)
  Variable AP1_dec : forall a1, AP1 a1 \/ ~ AP1 a1.
  Variable AP2_dec : forall a2, AP2 a2 \/ ~ AP2 a2.

  (* well-formedness of memory addresses *)
  Variable AP1_ok : forall a1, indomain a1 m1 -> AP1 a1.
  Variable AP2_ok : forall a2, indomain a2 m2 -> AP2 a2.

  Definition mem_atrans AT1 AEQ1 V AT2 AEQ2
    f (m : @mem AT1 AEQ1 V) (m' : @mem AT2 AEQ2 V) (P : AT1 -> Prop) :=
    forall a, P a -> m a = m' (f a).

  Variable MTrans : mem_atrans atrans m1 m2 AP1.

  Lemma mem_atrans_indomain : forall a1 x,
    indomain a1 m1 ->
    m1 a1 = x -> m2 (atrans a1) = x.
  Proof using MTrans AP1_ok.
    intros.
    apply AP1_ok in H.
    rewrite <- (MTrans H); auto.
  Qed.

  Lemma mem_atrans_mem_except : forall a (ap : AP1 a),
    cond_bijective atrans AP1 AP2 ->
    mem_atrans atrans (mem_except m1 a) (mem_except m2 (atrans a)) AP1.
  Proof using MTrans AP1_ok.
    intros; unfold mem_atrans, mem_except; intro x.
    destruct (AEQ1 x a); destruct (AEQ2 (atrans x) (atrans a));
      subst; auto; try tauto.
    destruct (indomain_dec x m1); auto.
    contradict n.
    apply H; auto.
  Qed.

  Section MEMMATCH_INVERSION.

    Variable ainv : AT2 -> AT1.
    Variable HInv : cond_inverse atrans AP1 AP2 ainv.

    Lemma mem_ainv_any : forall a (ap : AP2 a) x,
      m1 (ainv a) = x -> m2 a = x.
    Proof using MTrans HInv.
      intros.
      replace a with (atrans (ainv a)) by (apply HInv; auto).
      assert (AP1 (ainv a)) as Hx by (apply HInv; auto).
      rewrite <- (MTrans Hx); auto.
    Qed.

    Lemma mem_atrans_inv_ptsto : forall a (ap : AP2 a) F v,
      (F * (ainv a) |-> v)%pred m1
      -> (any * a |-> v)%pred m2.
    Proof using MTrans HInv.
      intros.
      apply any_sep_star_ptsto.
      eapply mem_ainv_any; eauto.
      eapply ptsto_valid'; eauto.
    Qed.

    Lemma mem_atrans_inv_notindomain : forall a (ap : AP2 a),
      notindomain (ainv a) m1 -> notindomain a m2.
    Proof using MTrans HInv.
      unfold notindomain; intros.
      eapply mem_ainv_any; eauto.
    Qed.

    Lemma mem_atrans_inv_indomain : forall a (ap : AP2 a),
      indomain (ainv a) m1 -> indomain a m2.
    Proof using MTrans HInv.
      unfold indomain; intros.
      destruct H; eexists.
      eapply mem_ainv_any; eauto.
    Qed.

    Lemma mem_atrans_emp :
      emp m1 -> emp m2.
    Proof using MTrans HInv AP2_ok AP2_dec.
      unfold emp; intros.
      destruct (AP2_dec a).

      replace a with (atrans (ainv a)).
      apply mem_ainv_any; auto.
      replace (atrans (ainv a)) with a; auto.
      apply eq_sym; apply HInv; auto.
      apply HInv; auto.

      destruct (indomain_dec a m2); auto.
      contradict H0.
      apply AP2_ok; auto.
    Qed.

    Lemma mem_ainv_mem_except : forall a (ap : AP2 a),
      mem_atrans atrans (mem_except m1 (ainv a)) (mem_except m2 a) AP1.
    Proof using MTrans HInv AP1_ok.
      intros; unfold mem_atrans, mem_except; intro x.
      destruct (AEQ1 x (ainv a)); destruct (AEQ2 (atrans x) a);
        try subst; auto; try tauto.

      contradict n.
      apply HInv; auto.
      destruct (indomain_dec x m1); auto.
      contradict n.
      apply eq_sym.
      apply HInv; auto.
    Qed.

    Lemma mem_ainv_mem_upd : forall a v (ap : AP2 a),
      mem_atrans atrans (Mem.upd m1 (ainv a) v) (Mem.upd m2 a v) AP1.
    Proof using MTrans HInv.
      intros; unfold mem_atrans, Mem.upd; intro x.
      destruct (AEQ1 x (ainv a)); destruct (AEQ2 (atrans x) a); auto.
      contradict n; subst.
      apply HInv; auto.

      intros; subst.
      contradict n.
      erewrite cond_inv_rewrite_left; eauto.
    Qed.

    Lemma mem_atrans_cond_inv : mem_atrans ainv m2 m1 AP2.
    Proof using HInv MTrans.
      cbv [mem_atrans cond_inverse cond_left_inverse cond_right_inverse] in *.
      destruct HInv as [_ H'].
      intros a ?; specialize (H' a).
      rewrite MTrans by intuition.
      f_equal. intuition.
    Qed.

  End MEMMATCH_INVERSION.

End MEMMATCH.


(******************************************************************************)
(* Dr Daniel Kirk (c) 2021                                                    *)
(******************************************************************************)
(* ringIBN.axiom R == for a ring R, a proposition that:                       *)
(*                    forall n m : nat,                                       *)
(*                       lmodIsomType R\lmod^n R\lmod^m -> n == m             *)
(* ringIBNType     == a record consisting of a ringType 'sort' and a proof    *)
(*                    that (ringIBN.axiom sort holds).                        *)
(*                    R : ringIBN coerces to ringType                         *)
(******************************************************************************)
(* IBN_equiv_equal_basis_nums == proof that all bases of M have the same size *)
(******************************************************************************)
(* Let R : ringIBNType, and let A, B : fdFreeLmodType R                       *)
(******************************************************************************)
(* \dim(A)         == the unique basis number of M                            *)
(* dim_of_oplus    == proof that \dim(A \oplus B) = \dim(A) + \dim(B)         *)
(******************************************************************************)
(* Let I : linIsomType A B                                                    *)
(******************************************************************************)
(* dim_of_isom I   == proof that \dim(A) = \dim(B)                            *)
(******************************************************************************)
(* Let F : finType and I : F -> fdFreeLmodType R                              *)
(******************************************************************************)
(* dim_of_bigoplus == proof that \dim(\bigoplus_F I) = \sum_(f : F)\dim(I f)  *)
(******************************************************************************)

From Coq.Logic Require Import ProofIrrelevance FunctionalExtensionality.
Require Import Coq.Init.Datatypes.
From mathcomp Require Import ssreflect ssrfun eqtype seq fintype bigop.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool ssrnat.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
  From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Set Implicit Arguments.
Unset Strict Implicit.

Require Import Modules Linears lmodLC DirectSum Basis FreeModules.

Open Scope lmod_scope.
Open Scope ring_scope.
Module ringIBN.
  Section Def.
    Definition axiom (R : ringType) :=
      forall n m : nat,
        (linIsomType (R\lmod^n) (R\lmod^m)) -> n == m.

    Record mixin (R : ringType) := Mixin { _ : axiom R; }.
    Record type := Pack { sort : _;  class_of : mixin sort; }.
  End Def.
  Section Result.
    Variable (R : ringType).
    Theorem IBN_equiv_equal_basis_nums : axiom R <->
      forall (M : fdFreeLmodType R) (B1 B2 : lmodFinBasisType M),
      (basis_number B1) == (basis_number B2).
    Proof.
      split; rewrite/axiom=>H.
        move=>M B1 B2.
        move: (H (basis_number B1) (basis_number B2))=>H2.
        have N1 : (basis_number B1) = size (enum (to_FinType (fdBasis (fdFreeLmodPack B1)))) by rewrite -cardT.
        have N2 : (basis_number B2) = size (enum (to_FinType (fdBasis (fdFreeLmodPack B2)))) by rewrite -cardT.
        apply (H _ _ (linIsomConcat (linIsomInvert (freeLinear.to_row N1)) (freeLinear.to_row N2))).

        move=>n m f.
        move: (H (fdFreeLmod_vector R m)
          (fdBasis (fdFreeLmod_vector R m))
          (@lmodBasis_to_finLmodBasis _ _
            (lmodBasis.isomorphicBasis f (lmodFinBasis_to_lmodBasis (fdBasis (fdFreeLmod_vector R n))))
            (Finite.class (ordinal_finType n))
          )).
      by rewrite /basis_number card_ord card_ord eq_sym.
    Qed.
  End Result.

  Module Exports.
    Notation "'\' 'dim' '(' M ')'" := (basis_number (fdBasis M)) (at level 0, format "'\' 'dim' '(' M ')'") : lmod_scope.
    Notation ringIBNType := type.
    Coercion sort : type >-> ringType.
    Coercion class_of : type >-> mixin.
  End Exports.

  Section Results.
    Variable (R : type).
    Export Exports.
    Open Scope nat_scope.
    Lemma dim_of_oplus : forall (M1 M2 : fdFreeLmodType R),
    \dim(M1 \foplus M2) = \dim(M1) + \dim(M2).
    Proof. move=> M1 M2.
      by rewrite /dsFdFreeLmod.Pair.fdFreeLmod/lmodFinBasis.basis_number card_sum.
    Qed.

    Lemma dim_of_bigoplus : forall {F : finType} (I : F -> fdFreeLmodType R),
      \dim(\fbigoplus I) = \sum_f (\dim(I f)).
    Proof. move => F I.
      rewrite /dsFdFreeLmod.type/dsFdFreeLmod.Seq.fdFreeLmod -big_enum enumT =>/=.
      induction(Finite.enum F); by [
      rewrite /lmodFinBasis.basis_number big_nil card_void|
      rewrite big_cons -IHl -dim_of_oplus /dsFdFreeLmod.Pair.fdFreeLmod/dsFdFreeLmod.Seq.basis].
    Qed.

    Lemma dim_of_isom : forall (M1 M2 : fdFreeLmodType R) (I : linIsomType M1 M2),
      \dim(M1) = \dim(M2).
    Proof. move=>M1 M2 I.
      move:(linIsom.Concat (linIsom.Concat (linIsom.Invert (freeLinear.to_row (fdFreeLmod.erefl M1))) I) (freeLinear.to_row (fdFreeLmod.erefl M2)))=>II.
      destruct R as [R' [A]].
      move:(A _ _ II)=>B; move/eqP in B.
      by rewrite /basis_number !cardT.
    Qed.

    Close Scope nat_scope.
  End Results.
End ringIBN.
Export ringIBN.Exports.

Close Scope ring_scope.
Close Scope lmod_scope.