From Hammer Require Import Hammer.

Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Relations_2.

Theorem Rstar_reflexive :
forall (U:Type) (R:Relation U), Reflexive U (Rstar U R).
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Rstar_reflexive".
auto with sets.
Qed.

Theorem Rplus_contains_R :
forall (U:Type) (R:Relation U), contains U (Rplus U R) R.
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Rplus_contains_R".
auto with sets.
Qed.

Theorem Rstar_contains_R :
forall (U:Type) (R:Relation U), contains U (Rstar U R) R.
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Rstar_contains_R".
intros U R; red; intros x y H'; apply Rstar_n with y; auto with sets.
Qed.

Theorem Rstar_contains_Rplus :
forall (U:Type) (R:Relation U), contains U (Rstar U R) (Rplus U R).
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Rstar_contains_Rplus".
intros U R; red.
intros x y H'; elim H'.
generalize Rstar_contains_R; intro T; red in T; auto with sets.
intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets.
Qed.

Theorem Rstar_transitive :
forall (U:Type) (R:Relation U), Transitive U (Rstar U R).
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Rstar_transitive".
intros U R; red.
intros x y z H'; elim H'; auto with sets.
intros x0 y0 z0 H'0 H'1 H'2 H'3; apply Rstar_n with y0; auto with sets.
Qed.

Theorem Rstar_cases :
forall (U:Type) (R:Relation U) (x y:U),
Rstar U R x y -> x = y \/ (exists u : _, R x u /\ Rstar U R u y).
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Rstar_cases".
intros U R x y H'; elim H'; auto with sets.
intros x0 y0 z H'0 H'1 H'2; right; exists y0; auto with sets.
Qed.

Theorem Rstar_equiv_Rstar1 :
forall (U:Type) (R:Relation U), same_relation U (Rstar U R) (Rstar1 U R).
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Rstar_equiv_Rstar1".
generalize Rstar_contains_R; intro T; red in T.
intros U R; unfold same_relation, contains.
split; intros x y H'; elim H'; auto with sets.
generalize Rstar_transitive; intro T1; red in T1.
intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets.
intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets.
Qed.

Theorem Rsym_imp_Rstarsym :
forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Rstar U R).
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Rsym_imp_Rstarsym".
intros U R H'; red.
intros x y H'0; elim H'0; auto with sets.
intros x0 y0 z H'1 H'2 H'3.
generalize Rstar_transitive; intro T1; red in T1.
apply T1 with y0; auto with sets.
apply Rstar_n with x0; auto with sets.
Qed.

Theorem Sstar_contains_Rstar :
forall (U:Type) (R S:Relation U),
contains U (Rstar U S) R -> contains U (Rstar U S) (Rstar U R).
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Sstar_contains_Rstar".
unfold contains.
intros U R S H' x y H'0; elim H'0; auto with sets.
generalize Rstar_transitive; intro T1; red in T1.
intros x0 y0 z H'1 H'2 H'3; apply T1 with y0; auto with sets.
Qed.

Theorem star_monotone :
forall (U:Type) (R S:Relation U),
contains U S R -> contains U (Rstar U S) (Rstar U R).
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.star_monotone".
intros U R S H'.
apply Sstar_contains_Rstar; auto with sets.
generalize (Rstar_contains_R U S); auto with sets.
Qed.

Theorem RstarRplus_RRstar :
forall (U:Type) (R:Relation U) (x y z:U),
Rstar U R x y -> Rplus U R y z ->  exists u : _, R x u /\ Rstar U R u z.
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.RstarRplus_RRstar".
generalize Rstar_contains_Rplus; intro T; red in T.
generalize Rstar_transitive; intro T1; red in T1.
intros U R x y z H'; elim H'.
intros x0 H'0; elim H'0.
intros x1 y0 H'1; exists y0; auto with sets.
intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets.
intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0.
split; [ try assumption | idtac ].
apply T1 with z0; auto with sets.
Qed.

Theorem Lemma1 :
forall (U:Type) (R:Relation U),
Strongly_confluent U R ->
forall x b:U,
Rstar U R x b ->
forall a:U, R x a ->  exists z : _, Rstar U R a z /\ R b z.
Proof. hammer_hook "Relations_2_facts" "Relations_2_facts.Lemma1".
intros U R H' x b H'0; elim H'0.
intros x0 a H'1; exists a; auto with sets.
intros x0 y z H'1 H'2 H'3 a H'4.
red in H'.
specialize H' with (x := x0) (a := a) (b := y); lapply H';
[ intro H'8; lapply H'8;
[ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ]
| clear H' ]; auto with sets.
elim H'9.
intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5.
elim (H'3 t); auto with sets.
intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5.
exists z1; split; [ idtac | assumption ].
apply Rstar_n with t; auto with sets.
Qed.


Require Import VST.floyd.proofauto. (* Import the Verifiable C system *)
Require Import VST.progs.bin_search. (* Import the AST of this C program *)

(* The next line is "boilerplate", always required after importing an AST. *)
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Fixpoint sorted (l : list Z) : Prop :=
  match l with
  | [] => True
  | x::rest =>
    match rest with [] => True | y::_ =>  x <= y /\ sorted rest end
  end.

(* Beginning of the API spec for the bin_search.c program *)
Definition search_spec :=
 DECLARE _search
  WITH a: val, sh : share, contents : list Z, tgt : Z, lo : Z, hi : Z
  PRE [ tptr tint, tint, tint, tint ]
            PROP  (readable_share sh;
                     0 <= lo <= Int.max_signed;
                     hi <= Zlength contents <= Int.max_signed;
                     Int.min_signed <= hi <= Int.max_signed / 2;
                     sorted contents;
                     Forall (fun x => Int.min_signed <= x <= Int.max_signed) contents;
                     Int.min_signed <= tgt <= Int.max_signed)
                  PARAMS (a; Vint (Int.repr tgt); Vint (Int.repr lo); Vint (Int.repr hi))
          SEP   (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a)
  POST [ tint ]
    EX i:Z,
         PROP (if in_dec Z.eq_dec tgt (sublist lo hi contents) then Znth i contents = tgt else i = -1)
          RETURN (Vint (Int.repr i))
           SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a).

(* The spec of "int main(void){}" always looks like this. *)
Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

(* Packaging the API spec all together. *)
Definition Gprog : funspecs :=
        ltac:(with_library prog [search_spec; main_spec]).

Lemma sublist_nil1 : forall A i j (l : list A), j <= i -> sublist i j l = [].
Proof.
  intros *.
  apply sublist_nil_gen.
Qed.

Lemma Znth_In : forall A (d: Inhabitant A) i (l : list A) x (Hrange : 0 <= i < Zlength l)
                       (Hnth : Znth i l = x), In x l.
Proof.
  unfold Znth; intros.
  destruct (Z_lt_dec i 0); [lia|].
  subst; apply nth_In.
  rewrite Zlength_correct in Hrange; auto.
  rep_lia.
Qed.

Lemma In_Znth : forall A (d: Inhabitant A) (l : list A) x,
    In x l ->
    exists i, 0 <= i < Zlength l /\ Znth i l = x.
Proof.
  unfold Znth; intros.
  apply In_nth with (d := d) in H; destruct H as (n & ? & ?).
  exists (Z.of_nat n); split.
  - rewrite Zlength_correct; lia.
  - destruct (Z_lt_dec (Z.of_nat n) 0); [lia|].
    rewrite Nat2Z.id; auto.
Qed.

Lemma sublist_of_nil : forall A i j, sublist i j (nil : list A) = [].
Proof.
  intros; unfold sublist.
  rewrite firstn_nil, skipn_nil; auto.
Qed.

Fixpoint sorted2 l :=
  match l with
  | [] => True
  | x :: rest => Forall (fun y => x <= y) rest /\ sorted2 rest
  end.

Lemma sorted_equiv : forall l, sorted l <-> sorted2 l.
Proof.
  induction l; simpl.
  - reflexivity.
  - destruct l.
    + simpl; split; auto.
    + rewrite IHl; simpl; split; intros (? & Hall & ?); split3; auto.
       * constructor; auto.
          rewrite Forall_forall in *; intros ? Hin.
          specialize (Hall _ Hin); lia.
       * inversion H. auto.
Qed.

Lemma sorted_mono : forall l i j (Hsort : sorted l) (Hi : 0 <= i <= j)
                           (Hj : j < Zlength l),
    Znth i l <= Znth j l.
Proof.
induction l; intros.
* rewrite !Znth_nil. lia.
*
 rewrite sorted_equiv in Hsort. destruct Hsort as [H9 Hsort].
 rewrite <- sorted_equiv in Hsort. rewrite Forall_forall in H9.
 rewrite Zlength_cons in Hj.
 destruct (zeq i 0).
 +
   subst i; rewrite Znth_0_cons.
   destruct (zeq j 0).
   - subst j. rewrite Znth_0_cons. lia.
   - rewrite Znth_pos_cons by lia.
      apply H9.
      eapply Znth_In; [ | reflexivity]; lia.
 +
    rewrite !Znth_pos_cons by lia.
    apply IHl; auto; lia.
Qed.

Lemma In_sorted_range : forall lo hi x l (Hsort : sorted l) (Hlo : 0 <= lo <= hi)
                              (Hhi : hi <= Zlength l)
                              (Hin : In x (sublist lo hi l)),
    Znth lo l <= x <= Znth (hi - 1) l.
Proof.
  intros.
  generalize (In_Znth _ _ _ _ Hin); intros (i & Hrange & Hi).
  rewrite Zlength_sublist in Hrange by auto.
  rewrite Znth_sublist in Hi by lia.
  subst; split; apply sorted_mono; auto; lia.
Qed.

Lemma In_sorted_gt : forall x i n l lo hi (Hsort : sorted l) (Hlo : lo >= 0)
                            (Hhi : hi <= Zlength l)
                            (Hin : In x (sublist lo hi l))
                            (Hi : lo <= i < hi) (Hn : Znth i l = n)
                            (Hgt : n < x),
    In x (sublist (i + 1) hi l).
Proof.
  intros.
  rewrite sublist_split with (mid := i + 1) in Hin; try lia.
  rewrite in_app in Hin; destruct Hin; auto.
  generalize (In_sorted_range lo (i + 1) x _ Hsort); intro X.
  repeat (lapply X; [clear X; intro X | lia]).
  replace (i + 1 - 1) with i in X by lia.
  specialize (X H); subst; lia.
Qed.

Lemma In_sorted_lt : forall x i n l lo hi (Hsort : sorted l) (Hlo : lo >= 0)
                            (Hhi : hi <= Zlength l)
                            (Hin : In x (sublist lo hi l))
                            (Hi : lo <= i < hi) (Hn : Znth i l = n)
                            (Hgt : x < n),
    In x (sublist lo i l).
Proof.
  intros.
  rewrite sublist_split with (mid := i) in Hin; try lia.
  rewrite in_app in Hin; destruct Hin; auto.
  generalize (In_sorted_range i hi x _ Hsort); intro X.
  repeat (lapply X; [clear X; intro X | lia]).
  specialize (X H); subst; lia.
Qed.

Lemma Znth_In_sublist : forall A (d: Inhabitant A) i (l : list A) lo hi
  (Hlo : 0 <= lo <= i) (Hhi : i < hi <= Zlength l),
  In (Znth i l) (sublist lo hi l).
Proof.
  intros.
  apply Znth_In with (i := i - lo)(d := d).
  - rewrite Zlength_sublist; lia.
  - rewrite <- (Z.sub_simpl_r i lo) at 2.
    apply Znth_sublist; lia.
Qed.

Lemma sublist_In_sublist : forall A (l : list A) x lo hi lo' hi' (Hlo : 0 <= lo <= lo')
  (Hhi : hi' <= hi), In x (sublist lo' hi' l) -> In x (sublist lo hi l).
Proof.
  intros.
  apply @sublist_In with (lo := lo' - lo) (hi := hi' - lo); rewrite sublist_sublist;
    try split; try lia.
  - repeat rewrite Z.sub_simpl_r; auto.
  - destruct (Z_le_dec hi' lo'); try lia.
    rewrite sublist_nil1 in *; auto; simpl in *; contradiction.
Qed.

Lemma body_search: semax_body Vprog Gprog f_search search_spec.
Proof.
 start_function.
 destruct H0.
 assert (H6 := Int.min_signed_neg).
 forward_while (EX lo' : Z, EX hi' : Z,
    PROP  (0 <= lo' <= Int.max_signed;
           Int.min_signed <= hi' <= Int.max_signed / 2;
           hi' <= Zlength contents;
           In tgt (sublist lo hi contents) <-> In tgt (sublist lo' hi' contents))
    LOCAL (temp _a a; temp _tgt (Vint (Int.repr tgt));
           temp _lo (Vint (Int.repr lo')); temp _hi (Vint (Int.repr hi')))
    SEP   (data_at sh (tarray tint (Zlength contents))
                   (map Vint (map Int.repr contents)) a)).
 * Exists lo; Exists hi; entailer!!.
 * entailer!!.
 *
  match goal with H : _ <-> _ |- _ => rename H into H_tgt_sublist end.
  forward.  (* mid =  (lo + hi) >> 1; *) {
   entailer!!.
   clear - H8 HRE H7.
   set (j := Int.max_signed / 2) in *; compute in j; subst j.
   set (j := Int.max_signed) in *; compute in j; subst j.
   set (j := Int.min_signed) in *; compute in j; subst j.
   lia.
 }
  rewrite add_repr, Int.shr_div_two_p.
  change (two_p (Int.unsigned (Int.repr 1))) with 2.
  assert (Hlo'hi':  lo' + hi' <= Int.max_signed). {
   transitivity (Int.max_signed / 2 + Int.max_signed / 2).
   - apply Zplus_le_compat; lia.
   - rewrite Zplus_diag_eq_mult_2, Z.mul_comm. apply Z_mult_div_ge; lia.
  }
  rewrite !Int.signed_repr by lia.
  set (mid := (lo' + hi') / 2) in *.
  assert (H13: 0 <= mid < Zlength contents)
    by (subst; split; [apply Z_div_pos | apply Zdiv_lt_upper_bound]; lia).
  assert (H15: lo' <= mid < hi')
    by (split; [apply Zdiv_le_lower_bound | apply Zdiv_lt_upper_bound]; lia).
  assert (H16: Int.min_signed <= Znth mid contents <= Int.max_signed)
    by (rewrite Forall_forall in H3; apply H3; eapply Znth_In; eauto).
  clear H3 Hlo'hi' H H0 H1.
  clearbody mid.
  forward. (* val = a[mid]; *)
  autorewrite with sublist.
  forward_if.
  - forward. (* return mid; *)
    Exists mid; entailer!!.
    rewrite if_true; auto.
    rewrite H_tgt_sublist.
    apply Znth_In_sublist; lia.
  - forward_if.
    + forward. (*  lo = mid + 1; *)
      Exists ((mid + 1), hi'); simpl fst; simpl snd; entailer!!.
      rewrite H_tgt_sublist.
      split; intro Hin'.
      eapply In_sorted_gt; eauto; lia.
      eapply sublist_In_sublist; try apply Hin'; lia.
    + forward. (* hi=mid; *)
      Exists (lo',mid). simpl fst. simpl snd. entailer!.
      rewrite H_tgt_sublist.
      split; intro Hin'.
      eapply In_sorted_lt; eauto; lia.
      eapply sublist_In_sublist; try apply Hin'; lia.
 *
    forward.  (* return -1; *)
    Exists (-1); entailer!.
    rewrite if_false; auto.
    match goal with H : _ <-> _ |- _ => rewrite H end.
    rewrite sublist_nil1 by lia.
    clear; simpl; tauto.
Qed.

(* Contents of the extern global initialized array "_four" *)
Definition four_contents := [1; 2; 3; 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  forward_call (gv _four,Ews,four_contents,3,0,4).
  { change (Zlength four_contents) with 4.
    repeat constructor; computable.
  }
  Intro r; forward.
Qed.

#[export] Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_search.
semax_func_cons body_main.
Qed.


(*Require Import Arith.*)
Require Import List.
(*Require Import Streams.*)

Add LoadPath "Cpdt".

Require Import List.

Require Import CpdtTactics.

Definition bad : unit := tt.

Set Implicit Arguments.

Set Asymmetric Patterns.

Section stream.
  Variable A : Type.

  CoInductive stream : Type :=
  | Cons : A -> stream -> stream.
End stream.

CoFixpoint zeroes : stream nat := Cons 0 zeroes.

CoFixpoint trues_falses : stream bool := Cons true falses_trues
with falses_trues : stream bool := Cons false trues_falses.

Fixpoint approx A (s : stream A) (n : nat) : list A :=
  match n with
    | O => nil
    | S n' =>
      match s with
        | Cons h t => h :: approx t n'
      end
  end.

Eval simpl in approx zeroes 10.

Eval simpl in approx trues_falses 10.

Section map.
  Variables A B : Type.
  Variables f : A -> B.

  CoFixpoint map (s : stream A) : stream B :=
    match s with
    | Cons h t => Cons (f h) (map t)
    end.
End map.

Section interleave.
  Variable A : Type.

  CoFixpoint interleave (s1 s2 : stream A) : stream A :=
    match s1, s2 with
    | Cons h1 t1, Cons h2 t2 => Cons h1 (Cons h2 (interleave t1 t2))
    end.
End interleave.
(*
Section map'.
  Variables A B : Type.
  Variable f : A -> B.
  CoFixpoint map' (s : stream A) : stream B :=
    match s with
      | Cons h t => interleave (Cons (f h) (map' t)) (Cons (f h) (map' t))
    end.
End map'.
 *)

Definition tl A (s : stream A) : stream A :=
  match s with
  | Cons _ s' => s'
  end.

(*CoFixpoint bad : stream nat := bad.
 *)

CoFixpoint ones : stream nat := Cons 1 ones.

Definition ones' := map S zeroes.

Theorem ones_eq : ones = ones'.
Abort.

Section stream_eq.
  Variable A : Type.

  CoInductive stream_eq : stream A -> stream A -> Prop :=
  | Stream_eq : forall h t1 t2,
      stream_eq t1 t2
      -> stream_eq (Cons h t1) (Cons h t2).
End stream_eq.

Theorem ones_eq : stream_eq ones ones'.
Proof.
  cofix ones_eq.
  assumption.
  Undo.
  simpl.
Abort.

Definition frob A (s : stream A) : stream A :=
  match s with
  | Cons h t => Cons h t
  end.

Theorem frob_eq : forall A (s : stream A), s = frob s.
  destruct s; reflexivity.
Qed.

Theorem ones_eq : stream_eq ones ones'.
  cofix ones_eq.
  rewrite (frob_eq ones).
  rewrite (frob_eq ones').
  simpl.
  constructor.


Require Import Logic.JMeq.
Set Universe Polymorphism.
Lemma JMeq_projT2 : forall (A : Type) (P : A -> Type) (a b : sigT P), a = b -> JMeq (projT2 a) (projT2 b).
Proof.
  intros A P a b H.
  rewrite H.
  auto.
Qed.

Inductive V : Type :=
  mk_V : forall (T : Type), (T -> V) -> V.
Definition proj1_V (x : V) : Type := match x with
  | mk_V T F => T
  end.

Definition proj2_V (x : V) : proj1_V x -> V := match x with
  | mk_V T F => F
  end.

Inductive equiv_V : V -> V -> Prop :=
  bisim_V : forall (T : Type) (S : Type) (RT : T -> V) (RS : S -> V) (R : T -> S -> Prop),
    (forall x, exists y, R x y)
    -> (forall y, exists x, R x y)
    -> (forall x y, R x y -> equiv_V (RT x) (RS y))
    -> equiv_V (mk_V T RT) (mk_V S RS).

Lemma equiv_V_rep : forall (T S : Type) (RT : T -> V) (RS : S -> V), equiv_V (mk_V T RT) (mk_V S RS) ->
  exists R, (forall x, exists y, R x y) /\ (forall y, exists x, R x y) /\ (forall x y, R x y -> equiv_V (RT x) (RS y)) /\ equiv_V (mk_V T RT) (mk_V S RS).
Proof.
  intros T S RT RS H.
  inversion H.
  exists R; split; try split; try split; auto.
  intros x y H7.
  apply JMeq_projT2 in H1.
  simpl in H1. apply JMeq_eq in H1.
  apply JMeq_projT2 in H3.
  simpl in H3. apply JMeq_eq in H3.
  rewrite <- H1. rewrite <- H3; auto.
Qed.

Theorem reflexive_equiv_V : forall (s : V), equiv_V s s.
Proof.
  intros s.
  induction s.
  apply bisim_V with (fun x => fun y => x = y); auto.
  intros x. exists x. auto.
  intros y. exists y. auto.
  intros x y H0. rewrite H0. apply H; auto.
Qed.

Theorem symmetric_equiv_V : forall (s t : V), equiv_V s t -> equiv_V t s.
Proof.
  intros s t H.
  induction H.
  apply bisim_V with (fun x => fun y => R y x); firstorder.
Qed.

Theorem transitive_equiv_V : forall s t u, equiv_V s u -> equiv_V u t -> equiv_V s t.
Proof.
  intros s t u H H0.
  generalize dependent t.
  induction H.
  intros t H3.
  destruct t as (U,RU).
  apply equiv_V_rep in H3.
  destruct H3 as (R2,(H3,(H4,(H5,H6)))).
  apply bisim_V with (fun x y => exists z, R x z /\ R2 z y).
  intros x. specialize H with x. destruct H as (z,H).
  specialize H3 with z. destruct H3 as (y,H3).
  firstorder.
  intros y. specialize H4 with y. destruct H4 as (x,R4).
  specialize H0 with x. destruct H0 as (z,H0).
  firstorder.
  firstorder.
Qed.

Require Export Setoid.
(* Require Export SetoidClass. *)

Lemma transitive_equiv_V' : transitive V equiv_V.
Proof.
  unfold transitive.
  intros x y z H H0.
  apply transitive_equiv_V with y; auto.
Qed.

Add Parametric Relation : V equiv_V
  reflexivity proved by reflexive_equiv_V
  symmetry proved by symmetric_equiv_V
  transitivity proved by transitive_equiv_V'
  as V_rel.

Inductive elem (x : V) : V -> Prop :=
  is_elem : forall T F (t : T), equiv_V (F t) x -> elem x (mk_V T F).

Theorem elem_rep : forall T F s, elem s (mk_V T F) -> exists b, equiv_V (F b) s.
Proof.
  intros T F s H.
  inversion H as (T0,F0,b,H0,H1).
  exists b; auto.
Qed.

Theorem elem_exten_r : forall a b s, equiv_V a b -> elem s a -> elem s b.
Proof.
  intros a b s H H0.
  inversion H0 as (T,F,t,H1,H2).
  rewrite <- H2 in H.
  destruct b as (S,G).
  apply equiv_V_rep in H.
  destruct H as (R,(H3,(H4,(H5,H6)))).
  specialize H3 with t. destruct H3 as (t',H3).
  apply is_elem with t'.
  apply transitive_equiv_V with (F t); auto.
  apply symmetric_equiv_V; auto.
Qed.

Theorem elem_exten_l : forall s s' a, equiv_V s s' -> elem s a -> elem s' a.
Proof.
  intros s s' a H H0.
  inversion H0 as (T,F,t,H1,H2).
  apply is_elem with t.
  apply transitive_equiv_V with s; auto.
Qed.
(*
Add Parametric Morphism : elem with
  signature equiv_V ==> equiv_V ==> iff as elem_mor.
Proof.
  intros x y H x0 y0 H0.
  split; intros H1.
  apply elem_exten_l with x; auto.
  apply elem_exten_r with x0; auto.
  apply elem_exten_l with y. symmetry; auto.
  apply elem_exten_r with y0; auto. symmetry; auto.
Qed.
*)
Theorem extensionality : forall (a b : V), (forall s, elem s a <-> elem s b) -> equiv_V a b.
Proof.
  intros a b H.
  destruct a as (T,F).
  destruct b as (S,G).
  apply bisim_V with (fun x y => equiv_V (F x) (G y)).
  intros x.
    assert (H0 : elem (F x) (mk_V S G)). apply H.
    apply is_elem with x. apply reflexive_equiv_V.
    inversion H0 as (T0,F0,t,H1,H2).
    exists t. apply symmetric_equiv_V; auto.
  intros y.
    assert (H0 : elem (G y) (mk_V T F)). apply H.
    apply is_elem with y. apply reflexive_equiv_V.
    inversion H0 as (T0,F0,t,H1,H2).
    exists t. auto.
  auto.
Qed.

Definition subset s t := forall a, elem a s -> elem a t.

Theorem subset_exten : forall s s' t t', equiv_V s s' -> equiv_V t t' -> subset s t -> subset s' t'.
Proof.
  intros s s' t t' H H0 H1 a H2.
  unfold subset in H1.
  specialize H1 with a.
  apply elem_exten_r with t; auto.
  apply H1.
  apply elem_exten_r with s'; auto.
  apply symmetric_equiv_V; auto.
Qed.

Definition powerset (x : V) : V := match x with
  | mk_V T F => mk_V (T -> Prop) (fun P => mk_V {y : T | P y} (fun r => F (proj1_sig r)))
  end.

Theorem powerset_is_powerset : forall s t, elem t (powerset s) <-> subset t s.
Proof.
  intros s t.
  split.
  intros H.  destruct s as (T,F). simpl in H.
  inversion H as (S,G,x,H0,H1).
  apply JMeq_projT2 in H2. simpl in H2. apply JMeq_eq in H2.
  intros a H3.
  assert (H4 : elem a (G x)). apply elem_exten_r with t; auto.
    apply symmetric_equiv_V. auto.
  clear H3.
  rewrite H2 in H4.
  inversion H4 as (U,FU,z,H3,H5).
  apply JMeq_projT2 in H6. simpl in H6. apply JMeq_eq in H6.
  destruct z as (z,Hz).
  apply is_elem with z.
  rewrite H6 in H3. simpl in H3. auto.
  intros H.
  unfold subset in H.
  destruct s as (S,G).
  simpl.
  destruct t as (T,F).
  apply is_elem with (fun s => exists t, equiv_V (G s) (F t)).
  apply bisim_V with (fun x y => equiv_V (G (proj1_sig x)) (F y)); try firstorder.
  destruct x as (x,H0). auto.
  assert (H1 : elem (F y) (mk_V S G)). apply H.
  apply is_elem with y. apply reflexive_equiv_V.
  inversion H1 as (T0, F0, y0, H0, H2).
  assert (H4 : exists t : T, equiv_V (F0 y0) (F t)). exists y; auto.
  set (x := exist (fun y1 => exists t : T, equiv_V (F0 y1) (F t)) y0 H4).
  exists x.
  auto.
Qed.

Theorem powerset_exten : forall s s', equiv_V s s' -> equiv_V (powerset s) (powerset s').
Proof.
  intros s s' H.
  apply extensionality.
  intros s0.
  split.
  intros H0.
  apply powerset_is_powerset.
  apply subset_exten with s0 s. reflexivity. auto.
  apply powerset_is_powerset; auto.
  intros H0.
  apply powerset_is_powerset.
  apply subset_exten with s0 s'. reflexivity. symmetry; auto.
  apply powerset_is_powerset; auto.
Qed.

Definition emptyset : V := mk_V Empty_set (Empty_set_rect (fun x => V)).

Lemma emptyset_is_empty : forall x, ~ elem x emptyset.
Proof.
  intros x H.
  inversion H as (T,F,t,H0,H1).
  inversion t.
Qed.

Theorem epsilon_induction : forall (P : V -> Prop), (forall x y, equiv_V x y -> P x -> P y) -> (forall x, (forall y, elem y x -> P y) -> P x) -> forall x, P x.
Proof.
  intros P E H x.
  induction x.
  apply H.
  intros y H1.
  inversion H1.
  apply E with (F0 t); auto.
  apply JMeq_projT2 in H4.
  apply JMeq_eq in H4.
  simpl in H4.
  rewrite H4. auto.
Qed.

Definition singleton (x : V) : V := mk_V unit (fun y => x).

Theorem singleton_exten : forall x x', equiv_V x x' -> equiv_V (singleton x) (singleton x').
  intros x x' H.
  unfold singleton.
  apply bisim_V with (fun a b => True); firstorder.
Qed.

Theorem signleton_single : forall x, elem x (singleton x) /\ forall y, elem y (singleton x) -> equiv_V x y.
Proof.
  intros x. split.
  unfold singleton.
  apply is_elem; auto.
  apply tt.
  apply reflexive_equiv_V.
  intros y H.
  unfold singleton in H.
  inversion H.
  apply JMeq_projT2 in H2.
  apply JMeq_eq in H2.
  simpl in H2.
  rewrite H2 in H1.
  auto.
Qed.

Definition pair (a : V) (b : V) : V := mk_V bool (fun x => if x then a else b).

Theorem pair_extens : forall a a' b b', equiv_V a a' -> equiv_V b b' -> equiv_V (pair a b) (pair a' b').
Proof.
  intros a a' b b' H H0.
  apply bisim_V with (fun x y => x = y); auto; try (
  intros x; exists x; auto).
  intros x y H1. induction x; rewrite <- H1; auto.
Qed.

Theorem pair_pair : forall a b c, elem c (pair a b) <-> equiv_V a c \/ equiv_V b c.
Proof.
  intros a b c.
  unfold pair.
  split.
  intros H. inversion H as (T,F,x,H1,H2).
  apply JMeq_projT2 in H0.  apply JMeq_eq in H0. simpl in H0.
  rewrite -> H0 in H1.
  induction x; auto.
  intros H.
  destruct H.
  apply is_elem with true; auto.
  apply is_elem with false; auto.
Qed.

Definition union (x : V) : V := match x with
  | mk_V T F => mk_V {x : T & proj1_V (F x)} (
     fun (y : {x : T & proj1_V (F x)}) =>
       let (x, y0) := y
       in proj2_V (F x) y0
     )
  end.

Theorem union_is_union : forall x, forall a, (exists b, elem a b /\ elem b x) <-> elem a (union x).
Proof.
  intros x a.
  split.
  intros H. destruct H as (b,(H,H0)).
  inversion H0 as (T,F,t,H1,H2).
  assert (H3 : elem a (F t)). apply elem_exten_r with b; auto.
  apply symmetric_equiv_V. auto.
  inversion H3 as (S,G,s,H4,H5).
  simpl.
  assert (H6 : proj1_V (mk_V S G) = proj1_V (F t)). rewrite H5. auto.
  simpl in H6.
  assert (H7 : exists (G : proj1_V (F t) -> V) (s : proj1_V (F t)), mk_V (proj1_V (F t)) G = F t /\ equiv_V (G s) a).
  rewrite <- H6. exists G. exists s. auto.
  clear H4. clear H5.  clear H6. clear s. clear G. clear S.
  destruct H7 as (G,(s,(H4,H5))).
  assert (H6 : JMeq (proj2_V (mk_V (proj1_V (F t)) G)) (proj2_V (F t))).
  rewrite H4. auto.
  simpl in H6.
  apply JMeq_eq in H6.
  rewrite H6 in H5.
  apply is_elem with (existT (fun r => proj1_V (F r)) t s); auto.
  destruct x as (T,F).
  simpl.
  intros H.
  inversion H as (T0,G,t,H0,H1). clear H1. clear T0.
  apply JMeq_projT2 in H2. apply JMeq_eq in H2. simpl in H2.
  rewrite H2 in H0. clear H2. clear G.
  destruct t as (x,s).
  assert (R : F x = mk_V (proj1_V (F x)) (proj2_V (F x))).
  assert (H1 : exists y, y = F x). exists (F x); auto.
  destruct H1 as (y,H1). rewrite <- H1.
  induction y; auto.
  assert (H1 : exists s, equiv_V (proj2_V (mk_V (proj1_V (F x)) (proj2_V (F x))) s) a). rewrite <- R. exists s; auto.
  clear H0. clear s. destruct H1 as (s,H0).
  exists (mk_V (proj1_V (F x)) (proj2_V (F x))).
  split.
  apply is_elem with s. simpl in H0. auto.
  apply is_elem with x. rewrite <- R. apply reflexive_equiv_V.
Qed.

Fixpoint encode_nat (n : nat) : V := match n with
  | 0 => emptyset
  | S m => singleton (encode_nat m)
end.

Lemma encoded_s_zero_differ : forall n, ~ equiv_V (encode_nat (S n)) (encode_nat 0).
Proof.
  intros n H.
  simpl in H.
  assert (H0 : elem (encode_nat n) emptyset).
  apply elem_exten_r with (encode_nat (S n)); simpl; auto.
  unfold singleton. apply is_elem with tt; auto. apply reflexive_equiv_V.
  unfold emptyset in H0.
  inversion H0 as (T,F,t,H1,H2).
  inversion t.
Qed.

Theorem same_encoded_nat : forall n m, equiv_V (encode_nat n) (encode_nat m) -> n = m.
Proof.
  intros n.
  induction n.
  intros m H.  destruct m; auto.
  apply symmetric_equiv_V in H.
  apply encoded_s_zero_differ in H. inversion H.
  intros m H.
  destruct m.
  apply encoded_s_zero_differ in H. inversion H.
  simpl in H.
  unfold singleton in H.
  apply equiv_V_rep in H.
  destruct H as (R,(H0,(H1,(H2,H3)))).
  assert (H4 : forall x y, R x y -> x = y).
  intros x y H. induction x. induction y; auto.
  assert (H5 : forall x y, R x y). intros x y. induction x. specialize H0 with tt.
  destruct H0 as (z,H0). induction z. induction y. auto.
  assert (H6 : n = m). apply IHn.
  apply H2 with tt tt. auto.
  auto.
Qed.

Definition naturals := mk_V nat encode_nat.

Theorem natural_equiv_encode_nat : forall v, elem v naturals <-> exists n, equiv_V v (encode_nat n).
Proof.
  intros v.
  split.
  unfold naturals.
  intros H.
  inversion H as (T,F,t,H0,H1).
  exists t. apply symmetric_equiv_V. auto.
  intros H.
  destruct H as (n,H).
  apply is_elem with n.
  apply symmetric_equiv_V; auto.
Qed.

Lemma encode_nat_in_naturals  : forall n, elem (encode_nat n) naturals.
Proof.
  intros n.
  apply natural_equiv_encode_nat.
  exists n; apply reflexive_equiv_V.
Qed.

Theorem set_cannot_contain_self : forall v, ~elem v v.
Proof.
  apply epsilon_induction.
  intros x y H H0 H1.
  apply H0. apply elem_exten_r with y. apply symmetric_equiv_V; auto.
  apply elem_exten_l with y. apply symmetric_equiv_V; auto.
  auto.
  intros x H H0.
  apply H with x; auto.
Qed.

Definition specification (s : V) (P : V -> Prop) :=
  match s with
  | mk_V T F => mk_V {x : T | P (F x)} (fun y => F (proj1_sig y))
  end.

Theorem specification_ext : forall s s' (P : V -> Prop), (forall x x', equiv_V x x' -> P x -> P x')
  -> equiv_V s s' -> equiv_V (specification s P) (specification s' P).
Proof.
  intros s s' P H H0.
  destruct s as (T,F).
  destruct s' as (S,G).
  simpl.
  apply equiv_V_rep in H0.
  destruct H0 as (R,(H1,(H2,(H3,H4)))).
  apply bisim_V with (fun a b => R (proj1_sig a) (proj1_sig b)).
  intros x.
  destruct x as (x,Hx).
  specialize H1 with x. destruct H1 as (y,Rxy).
  assert (Hy : P (G y)). apply H with (F x); auto.
  exists (exist (fun r => P (G r)) y Hy). auto.
  intros y. destruct y as (y,Hy).
  specialize H2 with y. destruct H2 as (x,Rxy).
  assert (Hx : P (F x)). apply H with (G y); auto.
  apply symmetric_equiv_V. apply H3; auto.
  exists (exist (fun r => P (F r)) x Hx); auto.
  auto.
Qed.

Theorem specification_spec : forall a s (P : V -> Prop), (forall x x', equiv_V x x' -> P x -> P x') -> elem a (specification s P) <-> elem a s /\ P a.
Proof.
  intros a s P H.
  split.
  intros H0.
  destruct s as (T,F). inversion H0 as (T0,F0,t,H1,H2).
  apply JMeq_projT2 in H3. apply JMeq_eq in H3. simpl in H3.
  rewrite H3  in H1.
  destruct t as (x,PFx).
  simpl in H1.
  split.
  apply is_elem with x; auto.
  apply H with (F x); auto.
  intros H0.
  destruct H0 as (H0,H1).
  inversion H0 as (T,F,t,H2,H3).
  simpl.
  assert (H4 : P (F t)). apply H with a; auto. apply symmetric_equiv_V; auto.
  apply is_elem with (exist (fun r => P (F r)) t H4).
  auto.
Qed.

Definition replacement (f : V -> V) (u : V) := match u with
  | mk_V T F => mk_V T (fun x => f (F x))
end.

Theorem replacement_exten : forall f g u u', (forall s s', equiv_V s s' -> equiv_V (f s) (g s'))
  -> (forall s, equiv_V (f s) (g s)) -> equiv_V u u' -> equiv_V (replacement f u) (replacement g u').
Proof.
  intros f g u u' H H0 H1.
  destruct u as (T,F).
  destruct u' as (S,G).
  apply equiv_V_rep in H1.
  destruct H1 as (R,(H2,(H3,(H4,H5)))).
  simpl.
  apply bisim_V with R; auto.
Qed.

Theorem replacement_replaces : forall f u b, (forall s s', equiv_V s s' -> equiv_V (f s) (f s')) -> (exists a, elem a u /\ equiv_V b (f a)) <-> elem b (replacement f u).
Proof.
  intros f u b H.
  destruct u as (T,F). simpl.
  split.
  intros H0. destruct H0 as (a,(H0,H1)).
  apply elem_rep in H0. destruct H0 as (t, H0).
  apply is_elem with t.
  apply transitive_equiv_V with (f a); auto.
  apply symmetric_equiv_V; auto.
  intros H0.
  apply elem_rep in H0. destruct H0 as (t,H0).
  exists (F t). split.
  apply is_elem with t; auto. apply reflexive_equiv_V.
  apply symmetric_equiv_V; auto.
Qed.

Section promoteV.
Universe less.
Universe more.
Constraint less < more.
Definition promoteT (t : Type@{less}) : Type@{more} := t.

Definition promote (x : V@{less}) : V@{more} := V_rect (fun x => V) (fun T v rec => mk_V (promoteT T) rec) x.
End promoteV.

Lemma promote_elem : forall a b, elem a (promote b) -> exists c, equiv_V a (promote c).
Proof.
  intros a b. generalize dependent a.
  induction b.
  intros a H0.
  apply elem_rep in H0.
  destruct H0 as (b, H0).
  unfold promoteT in *.
  exists (v b). symmetry. auto.
Qed.

Definition U : V := mk_V V promote.

Definition transitive_set s : Prop := forall a b, elem a b -> elem b s -> elem a s.
Definition pairclosed_set s : Prop := forall a b, elem a s -> elem b s -> elem (pair a b) s.
Definition powersetclosed_set s : Prop := forall a, elem a s -> elem (powerset a) s.
Definition familyclosed_set s : Prop := forall T F, (forall (t : T), elem (F t) s) -> elem (mk_V T F) s.

Definition Grothendieck_universe s : Prop := transitive_set s
                                             /\ pairclosed_set s
                                             /\ powersetclosed_set s
                                             /\ familyclosed_set s.

Lemma U_transitive : transitive_set U.
Proof.
  unfold U.
  unfold transitive_set.
  intros a b H H0.
  apply elem_rep in H0.
  destruct H0 as (t,H0).
  assert (H1: elem a (promote t)). apply elem_exten_r with b; auto. symmetry; auto.
  apply promote_elem in H1.
  destruct H1 as (c,H1).
  apply elem_exten_l with (promote c). symmetry; auto.
  apply is_elem with c. reflexivity.
Qed.

Lemma U_pairclosed : pairclosed_set U.
Proof.
  unfold U.
  unfold pairclosed_set.
  intros a b H H0.
  apply elem_rep in H.
  destruct H as (t,H).
  apply elem_rep in H0.
  destruct H0 as (s,H0).
  apply is_elem with (mk_V bool (fun x => if x then t else s)).
  unfold pair.
  simpl. unfold promoteT.
  apply bisim_V with (fun a b => a = b).
  intros x. exists x; auto.
  intros x. exists x; auto.
  intros x y H1. rewrite H1. induction y; auto.
Qed.

Lemma promotion_equiv : forall s, equiv_V (promote s) s.
Proof.
  intros s.
  induction s.
  simpl. unfold promoteT.
  apply bisim_V with (fun a b => a = b).
  intros x. exists x. auto.
  intros x. exists x. auto.
  intros x y H0. rewrite H0. apply H.
Qed.

Lemma U_familyclosed : familyclosed_set U.
Proof.
  unfold familyclosed_set.
  intros T F H.
  apply is_elem with (mk_V T F).
  apply promotion_equiv.
Qed.

Lemma U_powersetclosed : powersetclosed_set U.
Proof.
  Admitted.
(*
  unfold powersetclosed_set. unfold U.
  intros a H.
  apply elem_rep in H.
  destruct H as (b,H).
  apply is_elem with (powerset b).
  apply transitive_equiv_V with (powerset (promote b)).
  destruct b as (T,F).
  simpl.
  apply reflexive_equiv_V.
*)

Set Printing Universes.
Check U_powersetclosed.

Theorem U_universe : Grothendieck_universe U.
Proof.
  repeat split.
  apply U_transitive.
  apply U_pairclosed.
  apply U_powersetclosed.
  apply U_familyclosed.
Qed.


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

(* ** FRACTRAN termination is Diophantine *)

(* Require Import dio_expr dio_logic dio_elem dio_poly. *)

Require Import List Arith.

From Undecidability.Shared.Libs
  Require Import utils_tac utils_list sums rel_iter gcd pos vec.

From Undecidability.FRACTRAN
  Require Import FRACTRAN fractran_utils prime_seq.

From Undecidability.H10.Dio
  Require Import dio_logic dio_bounded dio_rt_closure dio_single dio_expo.

Set Implicit Arguments.

Section fractran_dio.

  Notation "l /F/ x → y" := (fractran_step l x y) (at level 70, no associativity).

  (* Fractran step is a diophantine relation, by induction on l *)

  Lemma dio_rel_fractran_step l x y : 𝔻F x -> 𝔻F y -> 𝔻R (fun ν => l /F/ x ν → y ν).
  Proof.
    intros Hx Hy.
    induction l as [ | (p,q) l IHl ].
    + by dio equiv (fun _ => False).
      abstract (intros v; rewrite fractran_step_nil_inv; split; tauto).
    + dio by lemma (fun v => fractran_step_cons_inv p q l (x v) (y v)).
  Defined.

  Hint Resolve dio_rel_fractran_step : dio_rel_db.

  (* Hence Fractan step* (refl. trans. closure) is diophantine *)

  Corollary dio_rel_fractran_rt l x y :
                     𝔻F x -> 𝔻F y -> 𝔻R (fun ν => fractran_compute l (x ν) (y ν)).
  Proof. intros; apply dio_rel_rt; dio auto. Defined.

  (* Fractran stop is a diophantine relation *)

  Lemma dio_rel_fractran_stop l x : 𝔻F x -> 𝔻R (fun ν => fractran_stop l (x ν)).
  Proof.
    intros Hx.
    induction l as [ | (p,q) l IHl ].
    + by dio equiv (fun _ => True).
      abstract(intro v; split; auto; intros _ ?; rewrite fractran_step_nil_inv; auto).
    + dio by lemma (fun v => fractan_stop_cons_inv p q l (x v)).
  Defined.

  Definition fractran_eval_old P n m := fractran_compute P n m /\ fractran_stop P m.

  Hint Resolve dio_rel_fractran_rt dio_rel_fractran_stop : dio_rel_db.

  Lemma dio_rel_fractran_eval l x y :
      𝔻F x -> 𝔻F y -> 𝔻R (fun ν => fractran_eval_old l (x ν) (y ν)).
  Proof.
    intros Hx Hy.  unfold fractran_eval_old.
    dio auto.
  Defined.

  (* We start with the case of regular Fractran programs that do not
     contain (_,0) "fractions" *)

  (* Hence Halting from the value x is diophantine *)

  Theorem FRACTRAN_HALTING_on_diophantine ll x :
                      𝔻F x -> 𝔻R (fun ν => FRACTRAN_HALTING (ll,x ν)).
  Proof. intros; dio auto. Defined.

End fractran_dio.

Corollary FRACTRAN_HALTING_diophantine_0 ll : 𝔻R (fun ν => FRACTRAN_HALTING (ll,ν 0)).
Proof. intros; apply FRACTRAN_HALTING_on_diophantine; dio auto. Defined.

Corollary FRACTRAN_HALTING_diophantine l x : 𝔻R (fun _ => FRACTRAN_HALTING (l,x)).
Proof. apply FRACTRAN_HALTING_on_diophantine; dio auto. Defined.

Section exp_diophantine.

  Notation power := (mscal mult 1).

  Fact power_expo x y : power x y = y^x.
  Proof.
    induction x as [ | x IHx ]; simpl.
    + rewrite power_0; auto.
    + rewrite power_S; f_equal; auto.
  Qed.

  (* for fixed n i j, the function v => exp i <v(j),...,v(n-1+j)> has a diophantine representation *)

  Let exp_dio n i j : 𝔻F (fun v => exp i (fun2vec j n v)).
  Proof.
    revert j i; induction n as [ | n IHn ]; intros j i.
    + simpl; dio auto.
    + by dio equiv (fun v => power (v j) (qs i) * exp (S i) (fun2vec (S j) n v)).
      abstract (intros v; simpl fun2vec; rewrite exp_cons, power_expo; auto).
  Defined.

  Let exp_dio_lift n i j : 𝔻F (fun v => exp i (fun2vec j n v⭳)).
  Proof.
    revert j i; induction n as [ | n IHn ]; intros j i.
    + simpl; dio auto.
    + by dio equiv (fun v => power (v (S j)) (qs i) * exp (S i) (fun2vec (S j) n v⭳)).
      abstract (intros v; simpl fun2vec; rewrite exp_cons, power_expo; auto).
  Qed.

  (* for a fixed n, the relation

         ν 0 = ps 1 * (qs 1)^(ν 1) * ... * (qs n)^(ν n)

     has a diophantine representation *)

  Fact fractran_exp_diophantine n : 𝔻F (fun ν => ps 1 * exp 1 (fun2vec 0 n ν)).
  Proof. dio auto. Show Proof. Defined.

  Fact fractran_exp_diophantine' n : 𝔻F (fun ν => ps 1 * exp 2 (fun2vec 1 n ν⭳)).
  Proof. eapply dio_fun_mult. dio auto. eapply exp_dio_lift. Qed.

  Fact fractran_exp_diophantine'' : 𝔻F (fun ν => ν 1 * qs 1 ^ ν 2).
  Proof.
    by dio equiv (fun ν => ν 1 * power  (ν 2) (qs 1)).
    intros. now rewrite power_expo.
  Qed.

End exp_diophantine.

#[export] Hint Resolve fractran_exp_diophantine fractran_exp_diophantine' fractran_exp_diophantine'' : dio_fun_db.

Theorem FRACTRAN_HALTING_on_exp_diophantine n l :
                     𝔻R (fun ν => l /F/ ps 1 * exp 1 (fun2vec 0 n ν) ↓).
Proof.
  apply dio_rel_compose with (R := fun x v => l /F/ x ↓); [ dio auto | ].
  apply FRACTRAN_HALTING_on_diophantine; dio auto.
Qed.

Theorem fractran_eval_old_diophantine n l :
                     𝔻R (fun ν => fractran_eval_old l (ps 1 * exp 2 (fun2vec 1 n ν⭳)) (ν 0 * qs 1 ^ (ν 1))).
Proof.
  apply dio_rel_compose with (R := fun x v => fractran_eval_old l x _); [ dio auto | ].
  apply dio_rel_compose with (R := fun x v => fractran_eval_old l _ x); [ dio auto | ].
  apply dio_rel_fractran_eval; dio auto.
Qed.

Theorem fractran_eval_diophantine n l :
                     𝔻R (fun ν => fractran_eval l (ps 1 * exp 2 (fun2vec 1 n ν⭳)) (ν 0 * qs 1 ^ (ν 1))).
Proof.
  edestruct fractran_eval_old_diophantine as [? H].
  eexists. setoid_rewrite FRACTRAN_sss.eval_iff. exact H.
Qed.

Theorem fractran_computable_diophantine n l :
                     𝔻R (fun ν => exists j, fractran_eval l (ps 1 * exp 2 (fun2vec 1 n ν)) (j * qs 1 ^ (ν 0)) /\ ~ divides (qs 1) j).
Proof.
  dio auto. eapply fractran_eval_diophantine.
Qed.

Theorem FRACTRAN_HALTING_dio_single E l x : { e : dio_single nat E | l /F/ x ↓ <-> dio_single_pred e (fun _ => 0) }.
Proof.
  generalize (@FRACTRAN_HALTING_on_diophantine l (fun _ => x)); intros H1.
  spec in H1; dio_rel_auto.
  destruct dio_rel_single with (1 := H1) as ((p,q) & He).
  unfold FRACTRAN_HALTING in He.
  exists (dp_inst_par E (fun _ => 0) p, dp_inst_par E (fun _ => 0) q).
  rewrite He with (ν := fun _ => 0).
  unfold dio_single_pred; simpl.
  split; intros (phi & Hphi); exists phi; revert Hphi;
    repeat rewrite dp_inst_par_eval; auto.
Qed.


(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses>                       *)
(************************************************************************)

Require Import digits.
Require Import Raxioms.
Require Import RIneq.
 Require Import R_addenda.
Require Import Fourier_solvable_ineqs.
Require Import Bounded_M.

(** Properties of the emission condition for Moebius maps. *)

Open Scope Z_scope.
Open Scope Q_scope.

Lemma Incl_M_L_unfolded_auxiliary_51: forall (a b c d:Q), 0 < d - c  ->
                (d-c)*((d - c) * (-1 / 2 - 1 / 2)) <= (d-c)*((b - a) * ((2 + 1) / 2 - 1 / 2)) ->
                 -1 <= (b - a) / (d - c).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (-1/2 - 1/2) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace ((2+1)/2 - 1/2) with Qone; [|qZ_numerals; field; auto];
 intros H_mult;
 apply Qmult_pos_Qle_Qdiv; trivial;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_52: forall (a b c d:Q), d - c<0  ->
                (d-c)*((d - c) * (-1 / 2 - 1 / 2)) <= (d-c)*((b - a) * ((2 + 1) / 2 - 1 / 2)) ->
                 -1 <= (b - a) / (d - c).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (-1/2 - 1/2) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace ((2+1)/2 - 1/2) with Qone; [|qZ_numerals; field; auto];
 intros H_mult;
 apply Qmult_neg_Qle_Qdiv; trivial;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_5: forall (a b c d:Q), d - c<>0  ->
                (d-c)*((d - c) * (-1 / 2 - 1 / 2)) <= (d-c)*((b - a) * ((2 + 1) / 2 - 1 / 2)) ->
                 -1 <= (b - a) / (d - c).
Proof.
 intros a b c d Hdc.
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_L_unfolded_auxiliary_52
  | apply Incl_M_L_unfolded_auxiliary_51
  ]; assumption.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_61: forall (a b c d:Q), 0 < d + c  ->
                    (d+c)*((a+b)*(1/2+(2+1)/2))<=(d+c)*((c+d)*(1/2+-1/2))->
                    (a + b) / (c + d) <= 0.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (1/2 + (2+1)/2) with (Qone +Qone); [|qZ_numerals; field; auto];
 replace (1/2 + -1/2) with Zero; [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:Zero<c+d);[ring_exact_Q Hdc|];
 apply Qmult_resp_Qle_pos_l with 2; auto;
 rewrite Qdiv_Qmult_numerator_l; auto;
 apply Qmult_pos_Qdiv_Qle; trivial; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_62: forall (a b c d:Q), d+c<0  ->
                    (d+c)*((a+b)*(1/2+(2+1)/2))<=(d+c)*((c+d)*(1/2+-1/2))->
                    (a + b) / (c + d) <= 0.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (1/2 + (2+1)/2) with (Qone +Qone); [|qZ_numerals; field; auto];
 replace (1/2 + -1/2) with Zero; [|qZ_numerals; field; auto];
 repeat rewrite Qmult_zero_right;
 intros H_mult;
 assert (Hcd:c+d<Zero);[ring_exact_Q Hdc|];
 apply Qle_Qdiv_nonneg_neg; trivial;
 apply Qmult_resp_Qle_pos_l with 2; auto; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_6: forall (a b c d:Q), d+c<>0  ->
                    (d+c)*((a+b)*(1/2+(2+1)/2))<=(d+c)*((c+d)*(1/2+-1/2))->
                    (a + b) / (c + d) <= 0.
Proof.
 intros a b c d Hdc.
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_L_unfolded_auxiliary_62
  | apply Incl_M_L_unfolded_auxiliary_61
  ]; assumption.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_71: forall (a b c d:Q), 0<d+c ->
                     (d+c)*((c+d)*(-1/2-1/2))<=(d+c)*((a+b)*((2+1)/2-1/2)) ->
                    -1 <= (a + b) / (c + d).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (-1/2 - 1/2) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace ((2+1)/2 - 1/2) with Qone; [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:Zero<c+d);[ring_exact_Q Hdc|];
 apply Qmult_pos_Qle_Qdiv; trivial; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_72: forall (a b c d:Q), d+c<0 ->
                     (d+c)*((c+d)*(-1/2-1/2))<=(d+c)*((a+b)*((2+1)/2-1/2)) ->
                    -1 <= (a + b) / (c + d).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (-1/2 - 1/2) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace ((2+1)/2 - 1/2) with Qone; [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:c+d<Zero);[ring_exact_Q Hdc|];
 apply Qmult_neg_Qle_Qdiv; trivial; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_7: forall (a b c d:Q), d+c  <> 0 ->
                     (d+c)*((c+d)*(-1/2-1/2))<=(d+c)*((a+b)*((2+1)/2-1/2)) ->
                    -1 <= (a + b) / (c + d).
Proof.
 intros a b c d Hdc.
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_L_unfolded_auxiliary_72
  | apply Incl_M_L_unfolded_auxiliary_71
  ]; assumption.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_81: forall (a b c d:Q), 0<d-c ->
             (d-c)*((b-a)*(1/2+(2+1)/2))<=(d-c)*((d-c)*(1/2+-1/2)) ->
                 (b - a) / (d - c)<=0.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (1/2 + (2+1)/2) with (Qone +Qone); [|qZ_numerals; field; auto];
 replace (1/2 + -1/2) with Zero; [|qZ_numerals; field; auto];
 repeat rewrite Qmult_zero_right;
 intros H_mult;
 apply Qle_Qdiv_nonpos_pos; trivial;
 apply Qmult_resp_Qle_pos_l with 2; auto; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_82: forall (a b c d:Q), d-c<0 ->
             (d-c)*((b-a)*(1/2+(2+1)/2))<=(d-c)*((d-c)*(1/2+-1/2)) ->
                 (b - a) / (d - c)<=0.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (1/2 + (2+1)/2) with (Qone +Qone); [|qZ_numerals; field; auto];
 replace (1/2 + -1/2) with Zero; [|qZ_numerals; field; auto];
 repeat rewrite Qmult_zero_right;
 intros H_mult;
 apply Qmult_resp_Qle_pos_l with 2; auto;
 rewrite Qdiv_Qmult_numerator_l; auto;
 apply Qmult_neg_Qdiv_Qle; trivial; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_L_unfolded_auxiliary_8: forall (a b c d:Q), d - c <> 0 ->
             (d-c)*((b-a)*(1/2+(2+1)/2))<=(d-c)*((d-c)*(1/2+-1/2)) ->
                 (b - a) / (d - c)<=0.
Proof.
 intros a b c d Hdc.
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_L_unfolded_auxiliary_82
  | apply Incl_M_L_unfolded_auxiliary_81
  ]; assumption.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_51: forall (a b c d:Q), 0 < d - c  ->
             (d-c)*((d-c)*(1/2-1/2))<=(d-c)*((b-a)*((2+1)/2- -1/2))->
                 0 <= (b - a) / (d - c).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (1/2 - 1/2) with Zero; [|qZ_numerals; field; auto];
 replace ((2+1)/2- -1/2) with (Qone+Qone); [|qZ_numerals; field; auto];
 rewrite Qmult_zero_right;
 intros H_mult;
 apply Qmult_resp_Qle_pos_l with 2; auto;
 rewrite Qdiv_Qmult_numerator_l; auto;
 apply Qmult_pos_Qle_Qdiv; trivial;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_52:  forall (a b c d:Q), d-c<0  ->
             (d-c)*((d-c)*(1/2-1/2))<=(d-c)*((b-a)*((2+1)/2- -1/2))->
                 0 <= (b - a) / (d - c).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (1/2 - 1/2) with Zero; [|qZ_numerals; field; auto];
 replace ((2+1)/2- -1/2) with (Qone+Qone); [|qZ_numerals; field; auto];
 rewrite Qmult_zero_right;
 intros H_mult;
 apply Qmult_resp_Qle_pos_l with 2; auto;
 rewrite Qdiv_Qmult_numerator_l; auto;
 apply Qmult_neg_Qle_Qdiv; trivial;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_5: forall (a b c d:Q), d - c<>0  ->
             (d-c)*((d-c)*(1/2-1/2))<=(d-c)*((b-a)*((2+1)/2- -1/2))->
                 0 <= (b - a) / (d - c).
Proof.
 intros a b c d Hdc;
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_R_unfolded_auxiliary_52
  | apply Incl_M_R_unfolded_auxiliary_51
  ]; assumption.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_61: forall (a b c d:Q), 0 < d + c  ->
                     (d+c)*((a+b)*(-1/2+(2+1)/2))<=(d+c)*((c+d)*(1/2+1/2))->
                    (a + b) / (c + d) <= 1.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (-1/2 + (2+1)/2) with Qone; [|qZ_numerals; field; auto];
 replace (1/2 + 1/2) with Qone; [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:Zero<c+d);[ring_exact_Q Hdc|];
 apply Qmult_pos_Qdiv_Qle; trivial; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_62: forall (a b c d:Q), d+c<0  ->
                     (d+c)*((a+b)*(-1/2+(2+1)/2))<=(d+c)*((c+d)*(1/2+1/2))->
                    (a + b) / (c + d) <= 1.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (-1/2 + (2+1)/2) with Qone; [|qZ_numerals; field; auto];
 replace (1/2 + 1/2) with Qone; [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:c+d<Zero);[ring_exact_Q Hdc|];
 apply Qmult_neg_Qdiv_Qle; trivial; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_6: forall (a b c d:Q), d+c<>0  ->
                     (d+c)*((a+b)*(-1/2+(2+1)/2))<=(d+c)*((c+d)*(1/2+1/2))->
                    (a + b) / (c + d) <= 1.
Proof.
 intros a b c d Hdc;
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_R_unfolded_auxiliary_62
  | apply Incl_M_R_unfolded_auxiliary_61
  ]; assumption.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_71: forall (a b c d:Q), 0<d+c ->
                     (d+c)*((c+d)*(1 / 2 - 1 / 2))<=(d+c)*((a+b)*((2 + 1) / 2 - -1 / 2)) ->
                    0 <= (a + b) / (c + d).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (1/2 - 1/2) with Zero; [|qZ_numerals; field; auto];
 replace ((2+1)/2 - -1/2) with (Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:Zero<c+d);[ring_exact_Q Hdc|];
 apply Qmult_resp_Qle_pos_l with 2; auto;
 rewrite Qdiv_Qmult_numerator_l; auto;
 apply Qmult_pos_Qle_Qdiv; trivial;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_72: forall (a b c d:Q), d+c<0 ->
                     (d+c)*((c+d)*(1 / 2 - 1 / 2))<=(d+c)*((a+b)*((2 + 1) / 2 - -1 / 2)) ->
                    0 <= (a + b) / (c + d).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (1/2 - 1/2) with Zero; [|qZ_numerals; field; auto];
 replace ((2+1)/2 - -1/2) with (Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:c+d<Zero);[ring_exact_Q Hdc|];
 apply Qmult_resp_Qle_pos_l with 2; auto;
 rewrite Qdiv_Qmult_numerator_l; auto;
 apply Qmult_neg_Qle_Qdiv; trivial;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_7: forall (a b c d:Q), d+c<>0 ->
                     (d+c)*((c+d)*(1 / 2 - 1 / 2))<=(d+c)*((a+b)*((2 + 1) / 2 - -1 / 2)) ->
                    0 <= (a + b) / (c + d).
Proof.
 intros a b c d Hdc;
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_R_unfolded_auxiliary_72
  | apply Incl_M_R_unfolded_auxiliary_71
  ]; assumption.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_81: forall (a b c d:Q), 0<d-c ->
             (d-c)*((b-a)*(-1 / 2 + (2 + 1) / 2))<=(d-c)*((d-c)*(1 / 2 + 1 / 2)) ->
                 (b - a) / (d - c)<=1.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (-1/2 + (2+1)/2) with Qone; [|qZ_numerals; field; auto];
 replace (1/2 + 1/2) with Qone; [|qZ_numerals; field; auto];
 intros H_mult;
 apply Qmult_pos_Qdiv_Qle; trivial;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_82: forall (a b c d:Q), d-c<0 ->
             (d-c)*((b-a)*(-1 / 2 + (2 + 1) / 2))<=(d-c)*((d-c)*(1 / 2 + 1 / 2)) ->
                 (b - a) / (d - c)<=1.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (-1/2 + (2+1)/2) with Qone; [|qZ_numerals; field; auto];
 replace (1/2 + 1/2) with Qone; [|qZ_numerals; field; auto];
 intros H_mult;
 apply Qmult_neg_Qdiv_Qle; trivial;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_R_unfolded_auxiliary_8: forall (a b c d:Q), d-c<>0 ->
             (d-c)*((b-a)*(-1 / 2 + (2 + 1) / 2))<=(d-c)*((d-c)*(1 / 2 + 1 / 2)) ->
                 (b - a) / (d - c)<=1.
Proof.
 intros a b c d Hdc;
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_R_unfolded_auxiliary_82
  | apply Incl_M_R_unfolded_auxiliary_81
  ]; assumption.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_51: forall (a b c d:Q), 0 < d - c  ->
             (d-c)*((d-c)*(0/1-1/1))<=(d-c)*((b-a)*((2+1)/1- 0/1))->
                 (-1)/3 <= (b - a) / (d - c).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (0/1 - 1/1) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace ((2+1)/1 - 0/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 apply Qmult_Qdiv_pos_Qle; auto;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_52: forall (a b c d:Q), d - c<0  ->
             (d-c)*((d-c)*(0/1-1/1))<=(d-c)*((b-a)*((2+1)/1- 0/1))->
                 (-1)/3 <= (b - a) / (d - c).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (0/1 - 1/1) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace ((2+1)/1 - 0/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 apply Qmult_Qdiv_pos_neg_Qle; auto;
 ring_exact_Q H_mult.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_5: forall (a b c d:Q), d - c<>0  ->
             (d-c)*((d-c)*(0/1-1/1))<=(d-c)*((b-a)*((2+1)/1- 0/1))->
                 (-1)/3 <= (b - a) / (d - c).
Proof.
 intros a b c d Hdc;
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_M_unfolded_auxiliary_52
  | apply Incl_M_M_unfolded_auxiliary_51
  ]; assumption.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_61: forall (a b c d:Q), 0 < d + c  ->
             (d+c)*((a+b)*(0 / 1 + (2 + 1) / 1))<=(d+c)*((c+d)*(1 / 1 + 0 / 1))->
                    (a + b) / (c + d) <= 1/3.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (1/1 + 0/1) with Qone; [|qZ_numerals; field; auto];
 replace (0/1 + (2+1)/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:Zero<c+d);[ring_exact_Q Hdc|];
 apply Qmult_Qdiv_pos_Qle; auto; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_62: forall (a b c d:Q), d + c<0  ->
             (d+c)*((a+b)*(0 / 1 + (2 + 1) / 1))<=(d+c)*((c+d)*(1 / 1 + 0 / 1))->
                    (a + b) / (c + d) <= 1/3.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (1/1 + 0/1) with Qone; [|qZ_numerals; field; auto];
 replace (0/1 + (2+1)/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:c+d<Zero);[ring_exact_Q Hdc|].
 apply Qmult_Qdiv_neg_pos_Qle; auto; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_6: forall (a b c d:Q), d + c<>0  ->
             (d+c)*((a+b)*(0 / 1 + (2 + 1) / 1))<=(d+c)*((c+d)*(1 / 1 + 0 / 1))->
                    (a + b) / (c + d) <= 1/3.
Proof.
 intros a b c d Hdc;
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_M_unfolded_auxiliary_62
  | apply Incl_M_M_unfolded_auxiliary_61
  ]; assumption.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_71: forall (a b c d:Q), 0<d+c ->
                     (d+c)*((c+d)*(0 / 1 - 1 / 1))<=(d+c)*((a+b)*((2 + 1) / 1 - 0 / 1)) ->
                    (-1)/3 <= (a + b) / (c + d).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (0/1 - 1/1) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace ((2+1)/1 - 0/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:Zero<c+d);[ring_exact_Q Hdc|];
 apply Qmult_Qdiv_pos_Qle; auto; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_72: forall (a b c d:Q), d+c<0 ->
                     (d+c)*((c+d)*(0 / 1 - 1 / 1))<=(d+c)*((a+b)*((2 + 1) / 1 - 0 / 1)) ->
                    (-1)/3 <= (a + b) / (c + d).
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (0/1 - 1/1) with (Qopp Qone); [|qZ_numerals; field; auto];
 replace ((2+1)/1 - 0/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 assert (Hcd:c+d<Zero);[ring_exact_Q Hdc|];
 apply Qmult_Qdiv_pos_neg_Qle; auto; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_7: forall (a b c d:Q), d+c<>0 ->
                     (d+c)*((c+d)*(0 / 1 - 1 / 1))<=(d+c)*((a+b)*((2 + 1) / 1 - 0 / 1)) ->
                    (-1)/3 <= (a + b) / (c + d).
Proof.
 intros a b c d Hdc;
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_M_unfolded_auxiliary_72
  | apply Incl_M_M_unfolded_auxiliary_71
  ]; assumption.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_81: forall (a b c d:Q), 0<d-c ->
             (d-c)*((b-a)*(0 / 1 + (2 + 1) / 1))<=(d-c)*((d-c)*(1 / 1 + 0 / 1)) ->
                 (b - a) / (d - c)<=1/3.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_pos_l _ _ _ Hdc H0); clear H0;
 replace (1/1 + 0/1) with Qone; [|qZ_numerals; field; auto];
 replace (0/1 + (2+1)/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 apply Qmult_Qdiv_pos_Qle; auto; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_82: forall (a b c d:Q), d-c<0 ->
             (d-c)*((b-a)*(0 / 1 + (2 + 1) / 1))<=(d-c)*((d-c)*(1 / 1 + 0 / 1)) ->
                 (b - a) / (d - c)<=1/3.
Proof.
 intros a b c d Hdc H0;
 generalize (Qmult_resp_Qle_neg_l _ _ _ Hdc H0); clear H0;
 replace (1/1 + 0/1) with Qone; [|qZ_numerals; field; auto];
 replace (0/1 + (2+1)/1) with (Qone+Qone+Qone); [|qZ_numerals; field; auto];
 intros H_mult;
 apply Qmult_Qdiv_neg_pos_Qle; auto; ring_exact_Q H_mult.
Qed.

Lemma Incl_M_M_unfolded_auxiliary_8: forall (a b c d:Q), d-c<>0 ->
             (d-c)*((b-a)*(0 / 1 + (2 + 1) / 1))<=(d-c)*((d-c)*(1 / 1 + 0 / 1)) ->
                 (b - a) / (d - c)<=1/3.
Proof.
 intros a b c d Hdc;
 destruct (not_Qeq_inf _ _ Hdc);
  [ apply Incl_M_M_unfolded_auxiliary_82
  | apply Incl_M_M_unfolded_auxiliary_81
  ]; assumption.
Qed.

Lemma Incl_M_L_unfolded:forall mu r, (-1<=r<=1)%R->Incl_M mu LL -> (-1<=as_Moebius mu r<=0)%R.
Proof.
 intros ((a,b),(c,d)) r H_r; unfold as_Moebius, Incl_M, map_digits, fst, snd;
 intros [H_vanish [H1 [H2 [H3 H4]]]];
 generalize (Bounded_M_d_minus_c_nonzero _ _ _ _ H_vanish); intro H_cd1;
 generalize (Bounded_M_c_plus_d_nonzero _ _ _ _ H_vanish); intro H_cd2;
 assert (Hdc:d + c <> Zero);[ring_exact_Q H_cd2|].

 destruct (Qle_dec_weak Zero (a*d-b*c)) as [H_det|H_det];
 split.
  apply Rle_trans with ((b-a)/(d-c))%R.
   rationalify_R; apply Incl_M_L_unfolded_auxiliary_5; trivial.
   stepl ((a*(-1)+b)/(c*(-1)+d))%R.
    apply (det_nonneg_nondecreasing _ _ _ _ (-1)%R r H_vanish H_det min_one_is_in_base_interval H_r (proj1 H_r)).
    apply (f_equal2 Rdiv); ring...
  apply Rle_trans with ((a+b)/(c+d))%R.
   stepr ((a*1+b)/(c*1+d))%R.
    apply (det_nonneg_nondecreasing _ _ _ _ r (1)%R H_vanish H_det H_r one_is_in_base_interval (proj2 H_r)).
    apply (f_equal2 Rdiv); ring.
   rationalify_R; apply Incl_M_L_unfolded_auxiliary_6; trivial...
  apply Rle_trans with ((a+b)/(c+d))%R.
   rationalify_R; apply Incl_M_L_unfolded_auxiliary_7; trivial.
   stepl ((a*1+b)/(c*1+d))%R.
    apply (det_nonpos_nonincreasing _ _ _ _ r (1)%R H_vanish H_det H_r one_is_in_base_interval (proj2 H_r)).
    apply (f_equal2 Rdiv); ring...
  apply Rle_trans with ((b-a)/(d-c))%R.
   stepr ((a*(-1)+b)/(c*(-1)+d))%R.
    apply (det_nonpos_nonincreasing _ _ _ _ (-1)%R r H_vanish H_det min_one_is_in_base_interval H_r (proj1 H_r)).
    apply (f_equal2 Rdiv); ring.
   rationalify_R; apply Incl_M_L_unfolded_auxiliary_8; trivial...
Qed.

Lemma Incl_M_R_unfolded:forall mu r, (-1<=r<=1)%R->Incl_M mu RR -> (0<=as_Moebius mu r<=1)%R.
Proof.
 intros ((a,b),(c,d)) r H_r; unfold as_Moebius, Incl_M, map_digits, fst, snd;
 intros [H_vanish [H1 [H2 [H3 H4]]]];
 generalize (Bounded_M_d_minus_c_nonzero _ _ _ _ H_vanish); intro H_cd1;
 generalize (Bounded_M_c_plus_d_nonzero _ _ _ _ H_vanish); intro H_cd2;
 assert (Hdc:d + c <> Zero);[ring_exact_Q H_cd2|].

 destruct (Qle_dec_weak Zero (a*d-b*c)) as [H_det|H_det];
 split.
  apply Rle_trans with ((b-a)/(d-c))%R.
   rationalify_R; apply Incl_M_R_unfolded_auxiliary_5; trivial.
   stepl ((a*(-1)+b)/(c*(-1)+d))%R.
    apply (det_nonneg_nondecreasing _ _ _ _ (-1)%R r H_vanish H_det min_one_is_in_base_interval H_r (proj1 H_r)).
    apply (f_equal2 Rdiv); ring...
  apply Rle_trans with ((a+b)/(c+d))%R.
   stepr ((a*1+b)/(c*1+d))%R.
    apply (det_nonneg_nondecreasing _ _ _ _ r (1)%R H_vanish H_det H_r one_is_in_base_interval (proj2 H_r)).
    apply (f_equal2 Rdiv); ring.
   rationalify_R; apply Incl_M_R_unfolded_auxiliary_6; trivial...
  apply Rle_trans with ((a+b)/(c+d))%R.
   rationalify_R; apply Incl_M_R_unfolded_auxiliary_7; trivial.
   stepl ((a*1+b)/(c*1+d))%R.
    apply (det_nonpos_nonincreasing _ _ _ _ r (1)%R H_vanish H_det H_r one_is_in_base_interval (proj2 H_r)).
    apply (f_equal2 Rdiv); ring...
  apply Rle_trans with ((b-a)/(d-c))%R.
   stepr ((a*(-1)+b)/(c*(-1)+d))%R.
    apply (det_nonpos_nonincreasing _ _ _ _ (-1)%R r H_vanish H_det min_one_is_in_base_interval H_r (proj1 H_r)).
    apply (f_equal2 Rdiv); ring.
   rationalify_R; apply Incl_M_R_unfolded_auxiliary_8; trivial.
Qed.

Lemma Incl_M_M_unfolded:forall mu r, (-1<=r<=1)%R->Incl_M mu MM -> (-1/3<=as_Moebius mu r<=1/3)%R.
Proof.
 intros ((a,b),(c,d)) r H_r; unfold as_Moebius, Incl_M, map_digits, fst, snd;
 intros [H_vanish [H1 [H2 [H3 H4]]]];
 generalize (Bounded_M_d_minus_c_nonzero _ _ _ _ H_vanish); intro H_cd1;
 generalize (Bounded_M_c_plus_d_nonzero _ _ _ _ H_vanish); intro H_cd2;
 assert (Hdc:d + c <> Zero);[ring_exact_Q H_cd2|].

 destruct (Qle_dec_weak Zero (a*d-b*c)) as [H_det|H_det];
 split.
  apply Rle_trans with ((b-a)/(d-c))%R.
   rationalify_R; apply Incl_M_M_unfolded_auxiliary_5; trivial.
   stepl ((a*(-1)+b)/(c*(-1)+d))%R.
    apply (det_nonneg_nondecreasing _ _ _ _ (-1)%R r H_vanish H_det min_one_is_in_base_interval H_r (proj1 H_r)).
    apply (f_equal2 Rdiv); ring...
  apply Rle_trans with ((a+b)/(c+d))%R.
   stepr ((a*1+b)/(c*1+d))%R.
    apply (det_nonneg_nondecreasing _ _ _ _ r (1)%R H_vanish H_det H_r one_is_in_base_interval (proj2 H_r)).
    apply (f_equal2 Rdiv); ring.
   rationalify_R; apply Incl_M_M_unfolded_auxiliary_6; trivial.
  apply Rle_trans with ((a+b)/(c+d))%R.
   rationalify_R; apply Incl_M_M_unfolded_auxiliary_7; trivial.
   stepl ((a*1+b)/(c*1+d))%R.
    apply (det_nonpos_nonincreasing _ _ _ _ r (1)%R H_vanish H_det H_r one_is_in_base_interval (proj2 H_r)).
    apply (f_equal2 Rdiv); ring...
  apply Rle_trans with ((b-a)/(d-c))%R.
   stepr ((a*(-1)+b)/(c*(-1)+d))%R.
    apply (det_nonpos_nonincreasing _ _ _ _ (-1)%R r H_vanish H_det min_one_is_in_base_interval H_r (proj1 H_r)).
    apply (f_equal2 Rdiv); ring.
   rationalify_R; apply Incl_M_M_unfolded_auxiliary_8; trivial...
Qed.

Lemma  Incl_M_L_folded: forall mu, (forall r, (-1 <= r <= 1)%R -> denom_nonvanishing_M mu r) -> (*Is_refining_M mu ->*)
     (forall r, (-1 <= r <= 1)%R -> (-1 <= as_Moebius mu r <= 0)%R) -> Incl_M mu LL.
Proof.
 intros ((a,b),(c,d)) H_denom H_mu.
 unfold denom_nonvanishing_M in H_denom; simpl in H_denom.
 unfold as_Moebius in H_mu; simpl in H_mu.
 assert (H_dcmin:d-c <>Zero);
 [apply Q_to_R_Qneq; realify_Q; stepl (c*(-1)+d)%R; [|ring]; apply (H_denom (-1)%R min_one_is_in_base_interval)|].
 assert (H_dc:d+c <>Zero);
 [apply Q_to_R_Qneq; realify_Q_goal; stepl (c*1+d)%R; [|ring]; apply (H_denom (1)%R one_is_in_base_interval)|].
 assert (Hd: d<>Zero);
 [apply Q_to_R_Qneq; realify_Q_goal; stepl (c*0+d)%R; [|ring]; apply H_denom; split; Fourier.fourier|].
 unfold Incl_M, Bounded_M, map_digits, fst, snd; qZ_numerals; repeat split.
  (* Bounded_M *)
  clear H_mu.
  destruct (Q_zerop c) as [Hc|Hc].
   subst c; destruct (not_Qeq_inf _ _ Hd) as [Hd_sg|Hd_sg].
    right; auto.
    left; auto.
   destruct (Q_le_lt_dec (-Qone) (- (d/c))) as [Hdc_min|Hdc_min].
    destruct (Q_le_lt_dec (- (d/c)) (Qone)) as [Hdc_|Hdc_].
     apply False_ind; apply (H_denom (-(d/c))%R);
      [ revert Hc; realify_Q_assumptions; intros _ _ _ H1 H2 H3; revert H2 H1; realify_Q_goal; tauto
      | try field; rationalify_R_goal; apply Q_to_R_not_eq; assumption
      ]...
     destruct (not_Qeq_inf _ _ Hc) as [Hc_sg|Hc_sg].
      (* c<0 *)
      left; split.
       apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl (Qone-(-(d/c))); [| field; auto];  apply Qlt_Qminus_Zero_neg; assumption.
       apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl ((-Qone)-(-(d/c))); [| field; auto]; apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with Qone; auto.
      (* 0<c *)
      right; split.
       apply Qlt_Qdiv_denom_pos_neg with c; trivial;
       stepl (Qone-(-(d/c))); [| field; auto];  apply Qlt_Qminus_Zero_neg; assumption.
       apply Qlt_Qdiv_denom_pos_neg with c; trivial;
       stepl ((-Qone)-(-(d/c))); [| field; auto]; apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with Qone; auto...
     destruct (not_Qeq_inf _ _ Hc) as [Hc_sg|Hc_sg].
      (* c<0 *)
      right; split.
       apply Qlt_pos_Qopp; apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl ((-(d/c))-(Qone)); [| field; auto];  apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with (-Qone); auto.
       apply Qlt_pos_Qopp; apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl ((-(d/c))-(-Qone)); [| field; auto]; apply Qlt_Qminus_Zero_neg; assumption.
      (* 0<c *)
      left; split.
       apply Qlt_neg_Qopp; apply Qlt_Qdiv_denom_pos_neg with c; trivial.
       stepl ((-(d/c))-(Qone)); [| field; auto]; apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with (-Qone); auto.
       apply Qlt_neg_Qopp; apply Qlt_Qdiv_denom_pos_neg with c; trivial;
       stepl ((-(d/c))-(-Qone)); [| field; auto]; apply Qlt_Qminus_Zero_neg; assumption.
  (* Refining 1 *)
  destruct (not_Qeq_inf _ _ H_dcmin) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_minsig.
   (* d-c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite Rmult_comm; apply Rdiv_Rmult_pos_neg_Rle'; auto; try Fourier.fourier;
   stepl (-1)%R; [|field]; stepr ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj1 (H_mu (-1)%R min_one_is_in_base_interval)).
   (* 0<d-c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite (Rmult_comm (b+ -a)%R); apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepl (-1)%R; [|field]; stepr ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj1 (H_mu (-1)%R min_one_is_in_base_interval)).
  (* Refining 2 *)
  destruct (not_Qeq_inf _ _ H_dcmin) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_minsig.
   (* d-c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite (Rmult_comm (b+ -a)%R); apply Rdiv_Rmult_neg_pos_Rle'; auto; try Fourier.fourier;
   stepr R0; [|field]; stepl ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj2 (H_mu (-1)%R min_one_is_in_base_interval)).
   (* 0<d-c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite Rmult_comm; apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepr R0; [|field]; stepl ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj2 (H_mu (-1)%R min_one_is_in_base_interval)).
  (* Refining 3 *)
  destruct (not_Qeq_inf _ _ H_dc) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_sig.
   (* d+c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_pos_neg_Rle'; auto; try Fourier.fourier;
   stepl (-1)%R; [|field]; stepr ((a * 1 + b) / (c * 1 + d))%R; [|field; auto; stepl (d+c)%R; trivial; ring];
   exact (proj1 (H_mu (1)%R one_is_in_base_interval)).
   (* 0<d+c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepl (-1)%R; [|field]; stepr ((a * 1 + b) / (c * 1 + d))%R; [|field; auto;stepl (d+c)%R; trivial; ring];
   exact (proj1 (H_mu (1)%R one_is_in_base_interval)).
  (* Refining 4 *)
  destruct (not_Qeq_inf _ _ H_dc) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_sig.
   (* d+c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_neg_pos_Rle'; auto; try Fourier.fourier.
   stepr R0; [|field]; stepl ((a * 1 + b) / (c * 1 + d))%R; [|field; auto; stepl (d+c)%R; trivial; ring];
   exact (proj2 (H_mu (1)%R one_is_in_base_interval)).
   (* 0<d+c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepr R0; [|field]; stepl ((a * 1 + b) / (c * 1 + d))%R; [|field; auto;stepl (d+c)%R; trivial; ring];
   exact (proj2 (H_mu (1)%R one_is_in_base_interval)).
Qed.

Lemma  Incl_M_R_folded: forall mu, (forall r, (-1 <= r <= 1)%R -> denom_nonvanishing_M mu r) ->
     (forall r, (-1 <= r <= 1)%R -> (0 <= as_Moebius mu r <= 1)%R) -> Incl_M mu RR.
Proof.
 intros ((a,b),(c,d)) H_denom H_mu.
 unfold denom_nonvanishing_M in H_denom; simpl in H_denom.
 unfold as_Moebius in H_mu; simpl in H_mu.
 assert (H_dcmin:d-c <>Zero);
 [apply Q_to_R_Qneq; realify_Q; stepl (c*(-1)+d)%R; [|ring]; apply (H_denom (-1)%R min_one_is_in_base_interval)|].
 assert (H_dc:d+c <>Zero);
 [apply Q_to_R_Qneq; realify_Q_goal; stepl (c*1+d)%R; [|ring]; apply (H_denom (1)%R one_is_in_base_interval)|].
 assert (Hd: d<>Zero);
 [apply Q_to_R_Qneq; realify_Q_goal; stepl (c*0+d)%R; [|ring]; apply H_denom; split; Fourier.fourier|].
 unfold Incl_M, Bounded_M, map_digits, fst, snd; qZ_numerals; repeat split.
  (* Bounded_M *)
  clear H_mu.
  destruct (Q_zerop c) as [Hc|Hc].
   subst c; destruct (not_Qeq_inf _ _ Hd) as [Hd_sg|Hd_sg].
    right; auto.
    left; auto.
   destruct (Q_le_lt_dec (-Qone) (- (d/c))) as [Hdc_min|Hdc_min].
    destruct (Q_le_lt_dec (- (d/c)) (Qone)) as [Hdc_|Hdc_].
     apply False_ind; apply (H_denom (-(d/c))%R);
      [ revert Hc; realify_Q_assumptions; intros _ _ _ H1 H2 H3; revert H2 H1; realify_Q_goal; tauto
      | try field; rationalify_R_goal; apply Q_to_R_not_eq; assumption
      ]...
     destruct (not_Qeq_inf _ _ Hc) as [Hc_sg|Hc_sg].
      (* c<0 *)
      left; split.
       apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl (Qone-(-(d/c))); [| field; auto];  apply Qlt_Qminus_Zero_neg; assumption.
       apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl ((-Qone)-(-(d/c))); [| field; auto]; apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with Qone; auto.
      (* 0<c *)
      right; split.
       apply Qlt_Qdiv_denom_pos_neg with c; trivial;
       stepl (Qone-(-(d/c))); [| field; auto];  apply Qlt_Qminus_Zero_neg; assumption.
       apply Qlt_Qdiv_denom_pos_neg with c; trivial;
       stepl ((-Qone)-(-(d/c))); [| field; auto]; apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with Qone; auto...
     destruct (not_Qeq_inf _ _ Hc) as [Hc_sg|Hc_sg].
      (* c<0 *)
      right; split.
       apply Qlt_pos_Qopp; apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl ((-(d/c))-(Qone)); [| field; auto];  apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with (-Qone); auto.
       apply Qlt_pos_Qopp; apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl ((-(d/c))-(-Qone)); [| field; auto]; apply Qlt_Qminus_Zero_neg; assumption.
      (* 0<c *)
      left; split.
       apply Qlt_neg_Qopp; apply Qlt_Qdiv_denom_pos_neg with c; trivial.
       stepl ((-(d/c))-(Qone)); [| field; auto]; apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with (-Qone); auto.
       apply Qlt_neg_Qopp; apply Qlt_Qdiv_denom_pos_neg with c; trivial;
       stepl ((-(d/c))-(-Qone)); [| field; auto]; apply Qlt_Qminus_Zero_neg; assumption.
  (* Refining 1 *)
  destruct (not_Qeq_inf _ _ H_dcmin) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_minsig.
   (* d-c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite Rmult_comm; apply Rdiv_Rmult_pos_neg_Rle'; auto; try Fourier.fourier;
   stepl R0; [|field]; stepr ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj1 (H_mu (-1)%R min_one_is_in_base_interval)).
   (* 0<d-c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite (Rmult_comm (b+ -a)%R); apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepl R0; [|field]; stepr ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj1 (H_mu (-1)%R min_one_is_in_base_interval)).
  (* Refining 2 *)
  destruct (not_Qeq_inf _ _ H_dcmin) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_minsig.
   (* d-c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite (Rmult_comm (b+ -a)%R); apply Rdiv_Rmult_neg_pos_Rle'; auto; try Fourier.fourier;
   stepr R1; [|field]; stepl ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj2 (H_mu (-1)%R min_one_is_in_base_interval)).
   (* 0<d-c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite Rmult_comm; apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepr R1; [|field]; stepl ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj2 (H_mu (-1)%R min_one_is_in_base_interval)).
  (* Refining 3 *)
  destruct (not_Qeq_inf _ _ H_dc) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_sig.
   (* d+c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_pos_neg_Rle'; auto; try Fourier.fourier;
   stepl R0; [|field]; stepr ((a * 1 + b) / (c * 1 + d))%R; [|field; auto; stepl (d+c)%R; trivial; ring];
   exact (proj1 (H_mu (1)%R one_is_in_base_interval)).
   (* 0<d+c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepl R0; [|field]; stepr ((a * 1 + b) / (c * 1 + d))%R; [|field; auto;stepl (d+c)%R; trivial; ring];
   exact (proj1 (H_mu (1)%R one_is_in_base_interval)).
  (* Refining 4 *)
  destruct (not_Qeq_inf _ _ H_dc) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_sig.
   (* d+c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_neg_pos_Rle'; auto; try Fourier.fourier.
   stepr R1; [|field]; stepl ((a * 1 + b) / (c * 1 + d))%R; [|field; auto; stepl (d+c)%R; trivial; ring];
   exact (proj2 (H_mu (1)%R one_is_in_base_interval)).
   (* 0<d+c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepr R1; [|field]; stepl ((a * 1 + b) / (c * 1 + d))%R; [|field; auto;stepl (d+c)%R; trivial; ring];
   exact (proj2 (H_mu (1)%R one_is_in_base_interval)).
Qed.

Lemma  Incl_M_M_folded: forall mu, (forall r, (-1 <= r <= 1)%R -> denom_nonvanishing_M mu r) ->
     (forall r, (-1 <= r <= 1)%R -> ((-1/3) <= as_Moebius mu r <= 1/3)%R) -> Incl_M mu MM.
Proof.
 intros ((a,b),(c,d)) H_denom H_mu.
 unfold denom_nonvanishing_M in H_denom; simpl in H_denom.
 unfold as_Moebius in H_mu; simpl in H_mu.
 assert (H_dcmin:d-c <>Zero);
 [apply Q_to_R_Qneq; realify_Q; stepl (c*(-1)+d)%R; [|ring]; apply (H_denom (-1)%R min_one_is_in_base_interval)|].
 assert (H_dc:d+c <>Zero);
 [apply Q_to_R_Qneq; realify_Q_goal; stepl (c*1+d)%R; [|ring]; apply (H_denom (1)%R one_is_in_base_interval)|].
 assert (Hd: d<>Zero);
 [apply Q_to_R_Qneq; realify_Q_goal; stepl (c*0+d)%R; [|ring]; apply H_denom; split; Fourier.fourier|].
 unfold Incl_M, Bounded_M, map_digits, fst, snd; qZ_numerals; repeat split.
  (* Bounded_M *)
  clear H_mu.
  destruct (Q_zerop c) as [Hc|Hc].
   subst c; destruct (not_Qeq_inf _ _ Hd) as [Hd_sg|Hd_sg].
    right; split; stepl d; trivial; ring.
    left; split; stepr d; trivial; ring.
   destruct (Q_le_lt_dec (-Qone) (- (d/c))) as [Hdc_min|Hdc_min].
    destruct (Q_le_lt_dec (- (d/c)) (Qone)) as [Hdc_|Hdc_].
     apply False_ind; apply (H_denom (-(d/c))%R);
      [ revert Hc; realify_Q_assumptions; intros _ _ _ H1 H2 H3; revert H2 H1; realify_Q_goal; tauto
      | try field; rationalify_R_goal; apply Q_to_R_not_eq; assumption
      ]...
     destruct (not_Qeq_inf _ _ Hc) as [Hc_sg|Hc_sg].
      (* c<0 *)
      left; split.
       apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl (Qone-(-(d/c))); [| field; auto];  apply Qlt_Qminus_Zero_neg; assumption.
       apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl ((-Qone)-(-(d/c))); [| field; auto]; apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with Qone; auto.
      (* 0<c *)
      right; split.
       apply Qlt_Qdiv_denom_pos_neg with c; trivial;
       stepl (Qone-(-(d/c))); [| field; auto];  apply Qlt_Qminus_Zero_neg; assumption.
       apply Qlt_Qdiv_denom_pos_neg with c; trivial;
       stepl ((-Qone)-(-(d/c))); [| field; auto]; apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with Qone; auto...
     destruct (not_Qeq_inf _ _ Hc) as [Hc_sg|Hc_sg].
      (* c<0 *)
      right; split.
       apply Qlt_pos_Qopp; apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl ((-(d/c))-(Qone)); [| field; auto];  apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with (-Qone); auto.
       apply Qlt_pos_Qopp; apply Qlt_Qdiv_denom_neg_neg with c; trivial;
       stepl ((-(d/c))-(-Qone)); [| field; auto]; apply Qlt_Qminus_Zero_neg; assumption.
      (* 0<c *)
      left; split.
       apply Qlt_neg_Qopp; apply Qlt_Qdiv_denom_pos_neg with c; trivial.
       stepl ((-(d/c))-(Qone)); [| field; auto]; apply Qlt_Qminus_Zero_neg; apply Qlt_transitive with (-Qone); auto.
       apply Qlt_neg_Qopp; apply Qlt_Qdiv_denom_pos_neg with c; trivial;
       stepl ((-(d/c))-(-Qone)); [| field; auto]; apply Qlt_Qminus_Zero_neg; assumption.
  (* Refining 1 *)
  destruct (not_Qeq_inf _ _ H_dcmin) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_minsig.
   (* d-c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite Rmult_comm; apply Rdiv_Rmult_pos_neg_Rle'; auto; try Fourier.fourier;
   stepl ((-1)/3)%R; [|field]; stepr ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj1 (H_mu (-1)%R min_one_is_in_base_interval)).
   (* 0<d-c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite (Rmult_comm (b+ -a)%R); apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepl ((-1)/3)%R; [|field]; stepr ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj1 (H_mu (-1)%R min_one_is_in_base_interval)).
  (* Refining 2 *)
  destruct (not_Qeq_inf _ _ H_dcmin) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_minsig.
   (* d-c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite (Rmult_comm (b+ -a)%R); apply Rdiv_Rmult_neg_pos_Rle'; auto; try Fourier.fourier;
   stepr (1/3)%R; [|field]; stepl ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj2 (H_mu (-1)%R min_one_is_in_base_interval)).
   (* 0<d-c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite Rmult_comm; apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepr (1/3)%R; [|field]; stepl ((a * (-1) + b) / (c * (-1) + d))%R; [|field; auto];
   exact (proj2 (H_mu (-1)%R min_one_is_in_base_interval)).
  (* Refining 3 *)
  destruct (not_Qeq_inf _ _ H_dc) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_sig.
   (* d+c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_pos_neg_Rle'; auto; try Fourier.fourier;
   stepl ((-1)/3)%R; [|field]; stepr ((a * 1 + b) / (c * 1 + d))%R; [|field; auto; stepl (d+c)%R; trivial; ring];
   exact (proj1 (H_mu (1)%R one_is_in_base_interval)).
   (* 0<d+c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepl ((-1)/3)%R; [|field]; stepr ((a * 1 + b) / (c * 1 + d))%R; [|field; auto;stepl (d+c)%R; trivial; ring];
   exact (proj1 (H_mu (1)%R one_is_in_base_interval)).
  (* Refining 4 *)
  destruct (not_Qeq_inf _ _ H_dc) as [H_|H_]; apply Q_to_R_Qle; realify_Q; auto; intros H_dcmin H_dc Hd H_dc_sig.
   (* d+c < 0 *)
   apply Rmult_le_compat_neg_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_neg_pos_Rle'; auto; try Fourier.fourier.
   stepr (1/3)%R; [|field]; stepl ((a * 1 + b) / (c * 1 + d))%R; [|field; auto; stepl (d+c)%R; trivial; ring];
   exact (proj2 (H_mu (1)%R one_is_in_base_interval)).
   (* 0<d+c *)
   apply Rmult_le_compat_l; [Fourier.fourier|];
   rewrite (Rmult_comm (a+b)%R); apply Rdiv_Rmult_pos_pos_Rle';  auto; try Fourier.fourier;
   stepr (1/3)%R; [|field]; stepl ((a * 1 + b) / (c * 1 + d))%R; [|field; auto;stepl (d+c)%R; trivial; ring];
   exact (proj2 (H_mu (1)%R one_is_in_base_interval)).
Qed.

Lemma Bounded_M_Incl_M_L_folded: forall mu, Bounded_M mu ->
  (forall r, (-1 <= r <= 1)%R -> (-1 <= as_Moebius mu r <= 0)%R) -> Incl_M mu LL.
Proof.
 intros mu H_bound; generalize (Bounded_M_denom_nonvanishing_M mu H_bound); apply Incl_M_L_folded.
Qed.

Lemma Bounded_M_Incl_M_R_folded: forall mu, Bounded_M mu ->
  (forall r, (-1 <= r <= 1)%R -> (0 <= as_Moebius mu r <= 1)%R) -> Incl_M mu RR.
Proof.
 intros mu H_bound; generalize (Bounded_M_denom_nonvanishing_M mu H_bound); apply Incl_M_R_folded.
Qed.

Lemma Bounded_M_Incl_M_M_folded: forall mu, Bounded_M mu ->
     (forall r, (-1 <= r <= 1)%R -> ((-1/3) <= as_Moebius mu r <= 1/3)%R) -> Incl_M mu MM.
Proof.
 intros mu H_bound; generalize (Bounded_M_denom_nonvanishing_M mu H_bound); apply Incl_M_M_folded.
Qed.

Close Scope Q_scope.
Close Scope Z_scope.