From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Integers.
Require Import Coqlib.
Require Import Maps.

Import Int.

(** Hardware specification *)

(** In general, coq-chip8 and original CHIP-8 has much in common if we speak about general approaches to ISA design.
  The big difference is that coq-chip8 has no keyboard nor display at all, it's better to consider our implementation as an abstract machine that realizes
  a subset of CHIP-8 ISA.
*)

(**
  coq-chip8 has 16 general purpose registers (V0 - VF) and three special ones (SP: Stack Pointer, PC: Program Counter and AReg: Address Register).
  We use AReg to work with memory. In original CHIP-8 we use the I register.
  *)

Inductive VReg : Type :=
  | v0: VReg | v1: VReg | v2: VReg | v3: VReg
  | v4: VReg | v5: VReg | v6: VReg | v7: VReg
  | v8: VReg | v9: VReg | vA: VReg | vB: VReg
  | vC: VReg | vD: VReg | vE: VReg | vF: VReg.

Inductive Reg : Type :=
  | VR: VReg -> Reg
  | PC: Reg
  | SP: Reg
  | AReg: Reg.

Coercion VR: VReg >-> Reg.

Lemma Reg_eq: forall (x y: Reg), {x = y} + {x <> y}.
Proof.
  repeat decide equality.
Qed.

Module RegEq.
  Definition t := Reg.
  Definition eq := Reg_eq.
End RegEq.

Module RegMap := EMap (RegEq).

Definition RegFile := RegMap.t int.

(**
  In our implementation memory is an almost unbound set of words.
  *)

Module IntEq.
  Definition t := int.
  Definition eq := Int.eq_dec.
End IntEq.

Module MemoryMap := EMap (IntEq).

Definition Memory := MemoryMap.t int.

Definition EmptyMemory :=
  MemoryMap.init (repr 0%Z).

(**
  I decided to separate the stack from the main memory to not check bounds of the stack
  *)

Definition Stack := list int.

(**
  The instructions of coq-chip8 are the same as the instructions of original CHIP-8 ISA, with some exceptions:
  1) No instructions related with keyboard/display are realized
  2) cls clears the memory, not a part of
  3) ldr and str work only with individual registers
*)

Inductive Instruction : Type :=
  | Icls: Instruction
  | Irts: Instruction
  | Ijmp: int -> Instruction
  | Ijsr: int -> Instruction
  | Iskeqb: VReg -> int -> Instruction (* skeq for byte *)
  | Iskneb: VReg -> int -> Instruction (* skne for byte *)
  | Iskeqr: VReg -> VReg -> Instruction (* skeq for VReg *)
  | Iskner: VReg -> VReg -> Instruction (* skne for VReg *)
  | Imovr: VReg -> VReg -> Instruction (* mov for VReg *)
  | Imovb: VReg -> int -> Instruction (* mov for byte *)
  | Ior: VReg -> VReg -> Instruction
  | Iand: VReg -> VReg -> Instruction
  | Ixor: VReg -> VReg -> Instruction
  | Iadd: VReg -> VReg -> Instruction
  | Isub: VReg -> VReg -> Instruction
  | Irsb: VReg -> VReg -> Instruction
  | Ishr: VReg -> Instruction
  | Ishl: VReg -> Instruction
  | Imvi: int -> Instruction
  | Istr: VReg -> Instruction
  | Ildr: VReg -> Instruction
  | Inop: Instruction.

Definition code := list Instruction.

Module InstructionMap := MemoryMap.

Definition InstructionMemory := MemoryMap.t Instruction.

Definition EmptyInstructionMemory :=
  MemoryMap.init (Inop).

(** * Operational semantics of coq-chip8 *)

Notation "a # b" := (a b) (at level 1, only parsing).
Notation "a # b <- c" := (RegMap.set b c a) (at level 1, b at next level).

Fixpoint LoadCodeTo (c: code) (IM: InstructionMemory) (pc: int) : InstructionMemory :=
  match c with
  | nil => IM
  | h::t => LoadCodeTo t (InstructionMap.set pc h IM) (add pc (repr 2%Z))
  end.

Definition LoadCode (c: code) (IM: InstructionMemory) : InstructionMemory :=
  LoadCodeTo c IM (repr 0%Z).

Import ListNotations.

Definition NextPC RF :=
  (add (RF#PC) (repr 2%Z)).

(** Output is either a triple or Fail *)

Inductive Output: Type :=
  | Fine: Memory -> InstructionMemory -> RegFile -> Stack -> Output
  | Fail: Output.

Definition Skip M IM RF St cond : Output :=
   if cond then
      Fine M IM (RF#PC <- (add (NextPC RF) (repr 2%Z))) St
    else
      Fine M IM (RF#PC <- (NextPC RF)) St.

Definition ExecuteStep (M: Memory) IM RF St : Output :=
  let instr := IM RF#PC in
  match instr with
  | Icls =>
    Fine EmptyMemory IM (RF#PC <- (NextPC RF)) St
  | Irts =>
    match St with
    | [] => Fail
    | h::t =>
      Fine M IM (RF#PC <- h) t
    end
  | Ijmp i =>
    Fine M IM (RF#PC <- i) St
  | Ijsr i =>
    Fine M IM (RF#PC <- i) ((RF#PC)::St)
  | Iskeqb v b =>
    Skip M IM RF St (eq RF#v b)
  | Iskeqr v v' =>
    Skip M IM RF St (eq RF#v RF#v')
  | Iskneb v b =>
    Skip M IM RF St (negb (eq RF#v b))
  | Iskner v v' =>
    Skip M IM RF St (negb (eq RF#v RF#v'))
  | Imovb v b =>
    Fine M IM ((RF#v <- b)#PC <- (NextPC RF)) St
  | Imovr v v' =>
    Fine M IM ((RF#v <- (RF#v'))#PC <- (NextPC RF)) St
  | Ior v v' =>
    Fine M IM ((RF#v <- (or (RF#v) (RF#v')))#PC <- (NextPC RF)) St
  | Ixor v v' =>
    Fine M IM ((RF#v <- (xor (RF#v) (RF#v')))#PC <- (NextPC RF)) St
  | Iand v v' =>
    Fine M IM ((RF#v <- (and (RF#v) (RF#v')))#PC <- (NextPC RF)) St
  | Iadd v v' =>
    Fine M IM (((RF#v <- (add (RF#v) (RF#v')))#vF <- (add_carry (RF#v) (RF#v') (zero)))#PC <- (NextPC RF)) St
   | Isub v v' =>
    if (lt RF#v RF#v') then
      Fine M IM (((RF#v <- (sub (RF#v) (RF#v'))#vF <- one))#PC <- (NextPC RF)) St
    else
      Fine M IM ((RF#v <- (sub (RF#v) (RF#v')))#PC <- (NextPC RF)) St
  | Irsb v' v =>
    if (lt RF#v RF#v') then
      Fine M IM (((RF#v <- (sub (RF#v) (RF#v'))#vF <- one))#PC <- (NextPC RF)) St
    else
      Fine M IM ((RF#v <- (sub (RF#v) (RF#v')))#PC <- (NextPC RF)) St| Ishr v =>
    let cr := (shr RF#v one) in
    if (eq (mul cr (repr 2%Z)) RF#v) then
      Fine M IM (((RF#v <- cr)#vF <- zero)#PC <- (NextPC RF)) St
    else
      Fine M IM (((RF#v <- cr)#vF <- one)#PC <- (NextPC RF)) St
  | Ishl v =>
    Fine M IM (((RF#v <- (shl RF#v one))#vF <- (and RF#v one))#PC <- (NextPC RF)) St
  | Imvi i =>
    Fine M IM ((RF#AReg <- i)#PC <- (NextPC RF)) St
  | Istr v =>
    Fine (MemoryMap.set (RF#v) (RF#AReg) M) IM (RF#PC <- (NextPC RF)) St
  | Ildr v =>
    Fine M IM ((RF#v <- (M (RF#AReg)))#PC <- (NextPC RF)) St
  | Inop =>
    Fine M IM RF St
  end.

(** It's not the truth every program will end up within finite time, so I decided to introduce n *)

Fixpoint ExecuteNSteps (M: Memory) IM RF St (n: nat) : Output :=
  match n with
  | 0%nat => Fine M IM RF St
  | (S n')%nat =>
    let Ex := ExecuteStep M IM RF St in
    match Ex with
    | Fine M' IM' RF' St' =>
      ExecuteNSteps M' IM' RF' St' n'
    | Fail => Fail
    end
  end.

(** Automatisation to reason about coq-chip8 programs *)

Definition Run C n : Output :=
  ExecuteNSteps EmptyMemory
    (LoadCode C EmptyInstructionMemory)
    (RegMap.init zero) [] n.

Hint Unfold LoadCode EmptyInstructionMemory EmptyMemory : chipmem.
Hint Unfold ExecuteNSteps ExecuteStep NextPC Skip Run : chipmem.
Hint Unfold MemoryMap.init InstructionMap.init MemoryMap.set InstructionMap.set : chipmem.
Hint Unfold RegMap.init RegMap.set IntEq.eq RegEq.eq zero : chipmem.

Lemma Z_eq_eq: forall x,
  eq (repr x) (repr x) = true.
Proof.
  intros. unfold eq. unfold zeq. rewrite unsigned_repr_eq.
  case (Z.eq_dec _ _); intros; intuition.
Qed.

Lemma lt_eq: forall x,
  lt (repr x) (repr x) = false.
Proof.
  unfold lt. intros. rewrite signed_repr_eq.
  apply zlt_false. destruct (zlt _ _); intuition.
Qed.

Lemma lt_pos_true: forall x y,
  x < y -> 0 <= x < half_modulus -> 0 <= y < half_modulus ->
  lt (repr x) (repr y) = true.
Proof.
  intros. unfold lt. repeat rewrite signed_repr_eq.
  rewrite half_modulus_modulus.
  apply zlt_true.
  repeat rewrite Zmod_small; intuition.
  repeat rewrite zlt_true; intuition.
Qed.

Lemma lt_pos_false: forall x y,
  y <= x -> 0 <= x < half_modulus -> 0 <= y < half_modulus ->
  lt (repr x) (repr y) = false.
Proof.
  intros. unfold lt. repeat rewrite signed_repr_eq.
  rewrite half_modulus_modulus.
  apply zlt_false.
  repeat rewrite Zmod_small; intuition.
  repeat rewrite zlt_true; intuition.
Qed.

Ltac inverse_eq :=
  match goal with
  | H: ?x = ?y |- _ => try inversion H
  end.

Hint Unfold eq zeq : Z_unfold.

Lemma Z_eq_neq:
  eq (repr 4) (repr 5) = false.
Proof.
  unfold eq. unfold zeq.
  case (Z.eq_dec _ _); intros; intuition.
  inverse_eq.
Qed.

Definition OutputM (Out: Output) : option Memory :=
  match Out with
  | Fail => None
  | Fine M _ _ _ => Some M
  end.

Definition OutputIM (Out: Output) : option InstructionMemory :=
  match Out with
  | Fail => None
  | Fine _ IM _ _ => Some IM
  end.

Definition OutputRF (Out: Output) : option RegFile :=
  match Out with
  | Fail => None
  | Fine _ _ RF _ => Some RF
  end.

Definition OutputStack (Out: Output) : option Stack :=
  match Out with
  | Fail => None
  | Fine _ _ _ St => Some St
  end.

Hint Unfold OutputM OutputIM OutputRF OutputStack : chipmem.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Export DoubleType.
Require Import Int31 Cyclic31 Ring31.
Require Import ZArith.
Require Import Bool.

Definition size := size.

Notation int := int31.

Delimit Scope int63_scope with int.
Bind Scope int63_scope with int.

(* Some constants *)
Notation "0" := 0%int31 : int63_scope.
Notation "1" := 1%int31 : int63_scope.
Notation "2" := 2%int31 : int63_scope.
Notation "3" := 3%int31 : int63_scope.

(* Comparisons *)
Definition eqb := eqb31.
Notation "m '==' n" := (eqb m n) (at level 70, no associativity) : int63_scope.

Definition ltb : int -> int -> bool :=
  fun i j => match compare31 i j with | Lt => true | _ => false end.
Notation "m < n" := (ltb m n) : int63_scope.

Definition leb : int -> int -> bool :=
  fun i j => match compare31 i j with | Gt => false | _ => true end.
Notation "m <= n" := (leb m n) : int63_scope.

Lemma eqb_correct : forall i j, (i==j)%int = true -> i = j.
Proof. exact eqb31_correct. Qed.

(* Logical operations *)
Definition lsl : int -> int -> int :=
  fun i j => addmuldiv31 j i 0.
Infix "<<" := lsl (at level 30, no associativity) : int63_scope.

Definition lsr : int -> int -> int :=
  fun i j => if (j < 31%int31)%int then addmuldiv31 (31-j)%int31 0 i else 0%int31.
Infix ">>" := lsr (at level 30, no associativity) : int63_scope.

Definition land : int -> int -> int := land31.
Global Arguments land i j : simpl never.
Global Opaque land.
Infix "land" := land (at level 40, left associativity) : int63_scope.

Definition lor : int -> int -> int := lor31.
Global Arguments lor i j : simpl never.
Global Opaque lor.
Infix "lor" := lor (at level 40, left associativity) : int63_scope.

Definition lxor : int -> int -> int := lxor31.
Global Arguments lxor i j : simpl never.
Global Opaque lxor.
Infix "lxor" := lxor (at level 40, left associativity) : int63_scope.

(* Arithmetic modulo operations *)
Notation "n + m" := (add31 n m) : int63_scope.
Notation "n - m" := (sub31 n m) : int63_scope.
Notation "n * m" := (mul31 n m) : int63_scope.

Definition mulc : int -> int -> int * int :=
  fun i j => match mul31c i j with
               | W0 => (0%int, 0%int)
               | WW h l => (h, l)
             end.

Definition div : int -> int -> int :=
  fun i j => let (q,_) := div31 i j in q.
Notation "n / m" := (div n m) : int63_scope.

Definition modulo : int -> int -> int :=
  fun i j => let (_,r) := div31 i j in r.
Notation "n '\%' m" := (modulo n m) (at level 40, left associativity) : int63_scope.

(* Iterators *)

Definition firstr i := if ((i land 1) == 0)%int then D0 else D1.
Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A)
 (i:int31) : A :=
  match n with
  | O => case0
  | S next =>
          if (i == 0)%int then
             case0
          else
             let si := (i >> 1)%int in
             caserec (firstr i) si (recr_aux next A case0 caserec si)
  end.
Definition recr := recr_aux size.
Definition iter_int31 i A f :=
  recr (A->A) (fun x => x)
   (fun b si rec => match b with
      | D0 => fun x => rec (rec x)
      | D1 => fun x => f (rec (rec x))
    end)
    i.

Definition foldi_cont
     {A B     : Type}
     (f       : int -> (A -> B) -> A -> B)
     (from to : int)
     (cont    : A -> B)                      : A -> B :=
  if ltb to from then
    cont
  else
    let (_,r) := iter_int31 (to - from) _ (fun (jy: (int * (A -> B))%type) =>
                     let (j,y) := jy in ((j-1)%int, f j y)
                                      ) (to, cont) in
    f from r.

Definition foldi_down_cont
    {A B         : Type}
    (f           : int -> (A -> B) -> A -> B)
    (from downto : int)
    (cont        : A -> B)                      : A -> B :=
  if ltb from downto then
    cont
  else
    let (_,r) := iter_int31 (from - downto) _ (fun (jy: (int * (A -> B))%type) =>
                     let (j,y) := jy in ((j+1)%int, f j y)
                                      ) (downto, cont) in
    f from r.

(* Fake print *)

Definition print_int : int -> int := fun i => i.


From CoreErlang.FrameStack Require Export Compatibility.

Import ListNotations.

Definition CIU (r1 r2 : Redex) : Prop :=
  REDCLOSED r1 /\ REDCLOSED r2 /\
  forall F, FSCLOSED F -> | F, r1 | ↓ -> | F, r2 | ↓.

Definition CIU_open (Γ : nat) (r1 r2 : Redex) :=
  forall ξ, SUBSCOPE Γ ⊢ ξ ∷ 0 ->
  CIU (r1.[ξ]ᵣ) (r2.[ξ]ᵣ).

Lemma CIU_closed :
  forall r1 r2,
  CIU r1 r2 -> REDCLOSED r1 /\ REDCLOSED r2.
Proof.
  intros. unfold CIU in H. intuition.
Qed.

Lemma CIU_closed_l : forall {r1 r2},
    CIU r1 r2 ->
    REDCLOSED r1.
Proof.
  intros.
  apply CIU_closed in H.
  intuition.
Qed.

Global Hint Resolve CIU_closed_l : core.

Lemma CIU_closed_r : forall {r1 r2},
    CIU r1 r2 ->
    REDCLOSED r2.
Proof.
  intros.
  apply CIU_closed in H.
  intuition.
Qed.

Global Hint Resolve CIU_closed_r : core.

Lemma CIU_open_scope : forall {Γ r1 r2},
    CIU_open Γ r1 r2 ->
    RED Γ ⊢ r1 /\ RED Γ ⊢ r2.
Proof.
  intros.
  unfold CIU_open in H.
  split; eapply subst_implies_scope_red; intros; apply H in H0; auto;
    now apply CIU_closed in H0.
Qed.

Lemma CIU_open_scope_l : forall {Γ r1 r2},
    CIU_open Γ r1 r2 ->
    RED Γ ⊢ r1.
Proof.
  intros.
  apply CIU_open_scope in H.
  intuition.
Qed.

Global Hint Resolve CIU_open_scope_l : core.

Lemma CIU_open_scope_r : forall {Γ r1 r2},
    CIU_open Γ r1 r2 ->
    RED Γ ⊢ r2.
Proof.
  intros.
  apply CIU_open_scope in H.
  intuition.
Qed.

Global Hint Resolve CIU_open_scope_r : core.

Lemma Rrel_implies_CIU : forall Γ r1 r2,
  Rrel_open Γ r1 r2 ->
  CIU_open Γ r1 r2.
Proof.
  intros.
  unfold CIU_open; intros.
  unfold CIU.
  split. 2: split.
  - apply -> (subst_preserves_scope_red); eauto.
  - apply -> (subst_preserves_scope_red); eauto.
  - intros. inv H2. eapply H. 3: apply Frel_Fundamental_closed; auto. 3: eassumption.
    apply Grel_Fundamental; auto.
    reflexivity.
Qed.

Lemma Rrel_comp_CIU_implies_Rrel : forall {Γ r1 r2 r3},
    Rrel_open Γ r1 r2 ->
    CIU_open Γ r2 r3 ->
    Rrel_open Γ r1 r3.
Proof.
  intros Γ r1 r2 r3 HRrel HCIU.
  intros.
  split. 2: split. 1-2: apply -> subst_preserves_scope_red; eauto; apply H.
  intros. eapply HRrel in H1; eauto. eapply HCIU in H1; eauto.
  apply H.
Qed.

Lemma CIU_implies_Rrel : forall {Γ r1 r2},
    CIU_open Γ r1 r2 ->
    Rrel_open Γ r1 r2.
Proof.
  intros.
  eapply Rrel_comp_CIU_implies_Rrel; eauto.
  apply Rrel_Fundamental.
  now apply CIU_open_scope_l in H.
Qed.

Theorem CIU_iff_Rrel : forall {Γ r1 r2},
    CIU_open Γ r1 r2 <->
    Rrel_open Γ r1 r2.
Proof.
  intuition (auto using CIU_implies_Rrel, Rrel_implies_CIU).
Qed.

Theorem CIU_eval : forall r1 v,
  REDCLOSED r1 ->
  ⟨ [], r1 ⟩ -->* v -> CIU r1 v /\ CIU v r1.
Proof.
  intros. split. split. 2: split. auto.
  inv H0. eapply step_any_closedness; eauto. apply H1. now constructor.

  destruct H0 as [k [Hr Hd]].
  intros. inv H1. eapply frame_indep_nil in Hd.
  eapply term_step_term in H2. 2: eassumption. eexists. eassumption.

  split. 2: split. 2: auto.
  inv H0. eapply step_any_closedness; eauto. apply H1. now constructor.

  intros. destruct H0 as [k [Hr Hd]]. inv H2. eapply frame_indep_nil in Hd.
  eapply step_term_term_plus in Hd. 2: eassumption.
  eexists. eassumption.
Qed.

(*--- ProgRes Ver ---*)
(*
Definition substProg (ξ : Substitution) (base : ProgResult) : ProgResult :=
match base with
| RExp e      => RExp (e.[ξ])
| ValSeqRes vs  => ValSeqRes (map (fun x => substVal ξ x) vs)
| ExcRes (class, reason, details) => ExcRes (class, reason.[ξ]ᵥ, details.[ξ]ᵥ)
end.
Notation "s .[ σ ]ₚ" := (substProg σ s)
  (at level 2, σ at level 200, left associativity,
   format "s .[ σ ]ₚ" ).

Definition CIU (p1 p2 : ProgResult) : Prop :=
  PROGCLOSED p1 /\ PROGCLOSED p2 /\
  forall F, FSCLOSED F -> | F, p1 | ↓ -> | F, p2 | ↓.

Definition CIU_open (Γ : nat) (p1 p2 : ProgResult) :=
  forall ξ, SUBSCOPE Γ ⊢ ξ ∷ 0 ->
  CIU (p1.[ξ]ₚ) (p2.[ξ]ₚ).

Lemma CIU_closed :
  forall p1 p2,
  CIU p1 p2 -> PROGCLOSED p1 /\ PROGCLOSED p2.
Proof.
  intros. unfold CIU in H. intuition.
Qed.

Lemma CIU_closed_l : forall {p1 p2},
    CIU p1 p2 ->
    PROGCLOSED p1.
Proof.
  intros.
  apply CIU_closed in H.
  intuition.
Qed.

Global Hint Resolve CIU_closed_l : core.

Lemma CIU_closed_r : forall {p1 p2},
    CIU p1 p2 ->
    PROGCLOSED p2.
Proof.
  intros.
  apply CIU_closed in H.
  intuition.
Qed.

Global Hint Resolve CIU_closed_r : core.

Check subst_implies_scope_exp.
Lemma CIU_open_scope : forall {Γ p1 p2},
    CIU_open Γ p1 p2 ->
    PROG Γ ⊢ p1 /\ PROG Γ ⊢ p2.
Proof.
  intros.
  unfold CIU_open in H.
  split.
  * destruct p1.
    - constructor. Check subst_implies_scope_exp.
      eapply (subst_implies_scope_exp _ _ 0).
      intros. specialize (H ξ H0). inversion H.
      inversion H1. auto.
    - constructor. Check subst_implies_scope_val.
      intros. eapply (subst_implies_scope_val _ _ 0).
      intros. specialize (H ξ H1). inversion H.
      inversion H2. rewrite map_length in H5.
      specialize (H5 i H0).
      Check map_nth. remember (fun x : ValueExpression => x.[ξ]ᵥ) as F.
      replace VNil with (F VNil) in H5 by (subst;simpl;auto).
      rewrite map_nth in H5. subst. auto.
    - destruct e. destruct p. constructor.
      + eapply (subst_implies_scope_val _ _ 0).
        intros. specialize (H ξ H0). inversion H.
        inversion H1. auto.
      + eapply (subst_implies_scope_val _ _ 0).
        intros. specialize (H ξ H0). inversion H.
        inversion H1. auto.
  * destruct p2.
    - constructor. Check subst_implies_scope_exp.
      eapply (subst_implies_scope_exp _ _ 0).
      intros. specialize (H ξ H0). inversion H.
      destruct H2. inversion H2. auto.
    - constructor. Check subst_implies_scope_val.
      intros. eapply (subst_implies_scope_val _ _ 0).
      intros. specialize (H ξ H1). inversion H.
      destruct H3. inversion H3. rewrite map_length in H6.
      specialize (H6 i H0).
      Check map_nth. remember (fun x : ValueExpression => x.[ξ]ᵥ) as F.
      replace VNil with (F VNil) in H6 by (subst;simpl;auto).
      rewrite map_nth in H6. subst. auto.
    - destruct e. destruct p. constructor.
      + eapply (subst_implies_scope_val _ _ 0).
        intros. specialize (H ξ H0). inversion H.
        destruct H2. inversion H2. auto.
      + eapply (subst_implies_scope_val _ _ 0).
        intros. specialize (H ξ H0). inversion H.
        destruct H2. inversion H2. auto.
Qed.

Lemma CIU_open_scope_l : forall {Γ p1 p2},
    CIU_open Γ p1 p2 ->
    PROG Γ ⊢ p1.
Proof.
  intros.
  apply CIU_open_scope in H.
  intuition.
Qed.

Global Hint Resolve CIU_open_scope_l : core.

Lemma CIU_open_scope_r : forall {Γ p1 p2},
    CIU_open Γ p1 p2 ->
    PROG Γ ⊢ p2.
Proof.
  intros.
  apply CIU_open_scope in H.
  intuition.
Qed.

Global Hint Resolve CIU_open_scope_r : core.
*)


Require Import SetoidClass.
Require Import Pactole.Core.Identifiers.
Require Import Pactole.Core.State.
Require Import Pactole.Core.Configuration.

(** To use these results, just provide an instance of the [NoByzantine] class. *)

Section NoByzantine.

Context `{Names}.
Context `{St : State}.

Class NoByzantine := { nB_eq_0 : nB = 0 }.

Context {NoByz : NoByzantine}.
(** There is no byzantine robot so we can simplify properties
    about identifiers and configurations. *)
Lemma no_byz : forall (id : ident) P, (forall g, P (Good g)) -> P id.
Proof using NoByz.
intros [g | b] P HP.
+ apply HP.
+ assert (Hnil : Bnames = nil) by now rewrite <- List.length_zero_iff_nil, Bnames_length, nB_eq_0.
  elim (@List.in_nil _ b). rewrite <- Hnil. apply In_Bnames.
Qed.

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

End NoByzantine.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj23synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (mult lv0 lv1) lv2) (plus (plus (mult lv0 lv1) lv1) (mult lv3 lv1))).
Admitted.
QuickChick conj23synthconj1.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C Aprime Cprime : Universe, ((wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ B O /\ (wd_ A O /\ (wd_ C O /\ (wd_ Aprime O /\ (wd_ O E /\ (col_ O Eprime Aprime /\ (col_ O Eprime O /\ (col_ O Eprime Cprime /\ (col_ Eprime B O /\ (col_ O E A /\ (col_ O E B /\ col_ O E C))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                            Eta                                     *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Add LoadPath ".." as IntensionalLib.

Require Import Arith Omega Max Bool List.

Require Import IntensionalLib.Closure_calculus.Closure_calculus.

Require Import IntensionalLib.Fieska_calculus.Test.
Require Import IntensionalLib.Fieska_calculus.General.
Require Import IntensionalLib.Fieska_calculus.Fieska_Terms.
Require Import IntensionalLib.Fieska_calculus.Fieska_Tactics.
Require Import IntensionalLib.Fieska_calculus.Fieska_reduction.
Require Import IntensionalLib.Fieska_calculus.Fieska_Normal.
Require Import IntensionalLib.Fieska_calculus.Fieska_Closed.
Require Import IntensionalLib.Fieska_calculus.Substitution.
Require Import IntensionalLib.Fieska_calculus.Fieska_Eval.
Require Import IntensionalLib.Fieska_calculus.Star.
Require Import IntensionalLib.Fieska_calculus.Fixpoints.
Require Import IntensionalLib.Fieska_calculus.Extensions.
Require Import IntensionalLib.Closure_to_Fieska.Tagging.
Require Import IntensionalLib.Closure_to_Fieska.Adding.
Require Import IntensionalLib.Closure_to_Fieska.Abstraction_to_Combination.

Lemma lift_rec_preserves_components_l:
forall M n k, lift_rec (left_component M) n k = left_component (lift_rec M n k).
Proof. induction M; split_all. Qed.

Lemma lift_rec_preserves_components_r:
forall M n k, lift_rec (right_component M) n k = right_component (lift_rec M n k).
Proof. induction M; split_all. Qed.

Lemma lift_rec_preserves_sf_red1:
forall M N, sf_red1 M N -> forall n k, sf_red1 (lift_rec M n k) (lift_rec N n k).
Proof.
intros M N r; induction r; split_all.
rewrite lift_rec_preserves_components_l.
rewrite lift_rec_preserves_components_r.
eapply2 f_compound_red.
rewrite ! lift_rec_preserves_components_l.
rewrite ! lift_rec_preserves_components_r.
eapply2 e_compound_compound_red. Qed.

Lemma lift_rec_multi_step:
forall (red: Fieska -> Fieska -> Prop),
(forall M N, red M N -> forall n k, red (lift_rec M n k) (lift_rec N n k)) ->
(forall M N, multi_step red M N -> forall n k, multi_step red (lift_rec M n k) (lift_rec N n k)).
Proof.
intros red H M N r; induction r; split_all.
eapply succ_red. eapply2 H. eapply2 IHr.
Qed.

Lemma lift_rec_preserves_sf_red:
forall M N, sf_red M N -> forall n k, sf_red (lift_rec M n k) (lift_rec N n k).
Proof. eapply2 lift_rec_multi_step. eapply2 lift_rec_preserves_sf_red1. Qed.

Lemma subst_rec_preserves_sf_red1:
forall M N, sf_red1 M N -> forall n k, sf_red1 (subst_rec M n k) (subst_rec N n k).
Proof.
intros M N r; induction r; split_all.
rewrite subst_rec_preserves_components_l.
rewrite subst_rec_preserves_components_r.
eapply2 f_compound_red.
eapply2 subst_rec_preserves_compounds.  eapply2 preserves_compound_sf_red1.
eapply2 preserves_compound_sf_red1.
eapply2 e_op_compound_red.  eapply2 subst_rec_preserves_compounds.
eapply2 e_compound_op_red.  eapply2 subst_rec_preserves_compounds.
rewrite ! subst_rec_preserves_components_l.
rewrite ! subst_rec_preserves_components_r.
apply e_compound_compound_red.
  eapply2 subst_rec_preserves_compounds.
  eapply2 subst_rec_preserves_compounds.
eapply2 IHr1. eapply2 IHr2.
eapply2 preserves_compound_sf_red1.
eapply2 (preserves_compound_sf_red1 M).
eapply2 preserves_compound_sf_red1.
eapply2 (preserves_compound_sf_red1 M).
Qed.

Lemma subst_rec_multi_step:
forall (red: Fieska -> Fieska -> Prop),
(forall M N, red M N -> forall n k, red (subst_rec M n k) (subst_rec N n k)) ->
(forall M N, multi_step red M N -> forall n k, multi_step red (subst_rec M n k) (subst_rec N n k)).
Proof.
intros red H M N r; induction r; split_all.
eapply succ_red. eapply2 H. eapply2 IHr.
Qed.

Lemma subst_rec_preserves_sf_red:
forall M N, sf_red M N -> forall n k, sf_red (subst_rec M n k) (subst_rec N n k).
Proof. eapply2 subst_rec_multi_step. eapply2 subst_rec_preserves_sf_red1. Qed.

Inductive ext_equiv : Fieska -> Fieska -> Prop :=
| ext_red : forall M N, (exists P, sf_red M P /\ sf_red N P) -> ext_equiv M N
| ext_eta : forall M N, ext_equiv (App (lift 1 M) (Ref 0)) (App (lift 1 N) (Ref 0)) -> ext_equiv M N
.

Hint Constructors ext_equiv.

Lemma ext_equiv_reflexive: forall M, ext_equiv M M.
Proof. intro; eauto. Qed.

Lemma ext_equiv_symmetric : forall M N, ext_equiv M N -> ext_equiv N M.
Proof.
intros M N e; induction e.
inversion H. inversion H0. eapply2 ext_red.
eapply2 ext_eta.
Qed.

Lemma ext_equiv_transitive: forall M N, ext_equiv M N -> forall P, ext_equiv N P -> ext_equiv M P.
Proof.
intros M N e1; induction e1.
(* 2 *)
inversion H. inversion H0. clear H H0.
intros P e2. generalize H1 H2; clear H1 H2. generalize x M.  clear - e2.
 induction e2; intros.
(* 3 *)
inversion H. inversion H0.
assert(exists Q, sf_red x Q /\ sf_red x0 Q) by eapply2 confluence_sf_red.
inversion H5. inversion H6.
eapply2 ext_red. exist x1; split; auto. eapply2 transitive_red. eapply2 transitive_red.
(* 2 *)
eapply2 ext_eta. eapply2 (IHe2 (App (lift 1 x) (Ref 0))).
eapply2 preserves_app_sf_red. unfold lift; eapply2 lift_rec_preserves_sf_red.
eapply2 preserves_app_sf_red. unfold lift; eapply2 lift_rec_preserves_sf_red.
(* 1 *)
intros P e2; induction e2.
(* 2 *)
inversion H. inversion H0.
eapply2 ext_eta. eapply2 IHe1.
eapply2 ext_red. exist (App (lift 1 x) (Ref 0)). split.
eapply2 preserves_app_sf_red. unfold lift; eapply2 lift_rec_preserves_sf_red.
eapply2 preserves_app_sf_red. unfold lift; eapply2 lift_rec_preserves_sf_red.
(* 1 *)
eapply2 ext_eta.
Qed.

Lemma sf_red_implies_ext_equiv: forall M N, sf_red M N -> ext_equiv M N.
Proof. intros. eapply2 ext_red. Qed.

Lemma optimise_A: forall M N,  ext_equiv (App (App (Op Aop) M) N) (App M N).
Proof.
intros. eapply2 ext_eta. eapply2 ext_red. exist (App (lift 1 (App M N)) (Ref 0)).
unfold lift, lift_rec; fold lift_rec. split.  eval_tac. auto.
Qed.

Lemma optimise_star: forall M N, sf_red M N -> ext_equiv (star_opt M) (star_opt N).
Proof.
intros. eapply2 ext_eta. eapply2 ext_red.
 exist (subst (lift_rec N 1 1) (Ref 0)). split.
unfold lift; rewrite lift_rec_preserves_star_opt.
eapply transitive_red. eapply2 star_opt_beta.
unfold subst; apply subst_rec_preserves_sf_red.
eapply2 lift_rec_preserves_sf_red.
unfold lift; rewrite lift_rec_preserves_star_opt.
eapply2 star_opt_beta.
Qed.

Lemma optimise_eta2: forall M, ext_equiv M (star_opt (App (lift 1 M) (Ref 0))).
Proof.
intros. eapply2 ext_eta. eapply2 ext_red.
exists (App (lift 1 M) (Ref 0)). split. auto.
unfold lift; rewrite lift_rec_preserves_star_opt.
eapply transitive_red. eapply2 star_opt_beta.
unfold subst, lift_rec; fold lift_rec. unfold subst_rec; fold subst_rec.
insert_Ref_out; relocate_lt.
rewrite lift_rec_lift_rec; try omega. unfold plus.
rewrite subst_rec_lift_rec; try omega.
unfold lift; rewrite lift_rec_null; auto.
Qed.

Lemma lift_rec_preserves_var : forall M n k, lift_rec(var M) n k = var (lift_rec M n k).
Proof.
intros; unfold var, app_comb; unfold_op. unfold lift_rec; fold lift_rec.
rewrite lift_rec_closed. auto.
Qed.

Theorem identity_abstraction_optimised:
ext_equiv (closure_to_fieska (Abs Closure_calculus.Iop 0 (Closure_calculus.Ref 0))) i_op.
Proof.
unfold closure_to_fieska.
replace i_op with (star_opt ( Ref 0)) at 2 by auto.
eapply2 ext_eta. eapply2 ext_red.
exist (Ref 0). split.
unfold lift; rewrite lift_rec_closed. 2: cbv; auto.
eapply transitive_red. eapply2 abs_red. eapply2 add_red_var_equal.
unfold_op; split; auto.   unfold app_comb. eapply2 matchfail_compound_op.
unfold_op; eapply2 matchfail_compound_op.
unfold lift, lift_rec; eval_tac.
Qed.

(* restore

Define polyvariate binding in closure calculus as syntactic sugar then use this here.

To do.

1) revise paper according to my lights
2) upload to GitHub
3) address referees comments (minor)
4) address minor comments.

*)

Lemma lift_rec_preserves_abs:
forall sigma i t n k,
lift_rec (abs sigma i t) n k = abs (lift_rec sigma n k) (lift_rec i n k) (lift_rec t n k).
Proof. intros; cbv; auto. Qed.

Lemma lift_rec_preserves_add:
forall sigma n k,
lift_rec (add sigma) n k = add (lift_rec sigma n k).
Proof. intros; cbv; auto. Qed.

Theorem first_projection_abstraction_optimised:
ext_equiv (closure_to_fieska (Abs Closure_calculus.Iop 1
 (Abs (Add Closure_calculus.Iop  1 (Closure_calculus.Ref 1)) 0 (Closure_calculus.Ref 1)))) k_op.
Proof.
unfold closure_to_fieska.
eapply2 ext_eta. eapply2 ext_eta. eapply2 ext_red.
exist (Ref 1). split.
2: cbv; eval_tac.
unfold lift; rewrite ! lift_rec_preserves_abs.
unfold_op; rewrite ! lift_rec_app.
rewrite ! lift_rec_preserves_abs.
unfold lift_rec; fold lift_rec.
rewrite ! lift_rec_preserves_add.
rewrite ! lift_rec_preserves_var.
unfold lift_rec; fold lift_rec; relocate_lt.
rewrite ! lift_rec_preserves_var.
unfold lift_rec; fold lift_rec; relocate_lt.  unfold plus.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 abs_red. auto.
eapply transitive_red. eapply preserves_app_sf_red.
 eapply2 add_red_abs. auto.
eapply transitive_red. eapply2 abs_red.
eapply transitive_red. eapply2 add_red_var_unequal.
unfold program; auto. unfold program; auto. discriminate.
unfold app_comb. eapply2 matchfail_compound_l.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 add_red_add. auto.
eapply transitive_red. eapply2 add_red_var_equal.
unfold program; auto.
unfold app_comb. eapply2 matchfail_compound_l.
eapply2 add_red_var_equal. unfold program; auto.
unfold app_comb. eapply2 matchfail_compound_l.
Qed.

Theorem closure_optimized:
forall M,
ext_equiv (closure_to_fieska (Abs (Add Closure_calculus.Iop 1 M) 0 (Closure_calculus.Ref 0))) i_op.
Proof.
intro. unfold closure_to_fieska; fold closure_to_fieska.
eapply2 ext_eta.
unfold_op; unfold lift; rewrite lift_rec_preserves_abs.
rewrite lift_rec_preserves_add; rewrite lift_rec_preserves_var.
unfold lift_rec; fold lift_rec. rewrite ! (lift_rec_closed (ref _)).
2: cbv; auto. 2: cbv; auto.
eapply2 ext_red. exist (Ref 0). split. 2: eval_tac.
eapply transitive_red. eapply2 abs_red. unfold_op.
eapply transitive_red. eapply2 add_red_var_equal; unfold program; auto.
unfold app_comb; auto. auto.
Qed.

Theorem three_optimizations:
ext_equiv (closure_to_fieska (Abs Closure_calculus.Iop 0 (Closure_calculus.Ref 0))) i_op /\
ext_equiv (closure_to_fieska (Abs Closure_calculus.Iop 1
 (Abs (Add Closure_calculus.Iop  1 (Closure_calculus.Ref 1)) 0 (Closure_calculus.Ref 1)))) k_op /\
forall M,
ext_equiv (closure_to_fieska (Abs (Add Closure_calculus.Iop 1 M) 0 (Closure_calculus.Ref 0))) i_op.
Proof.
repeat split. eapply2 identity_abstraction_optimised.
eapply2 first_projection_abstraction_optimised.
eapply2 closure_optimized.
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^285 - 9
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 32;
    bitwidth := 32;
    s := 2^285;
    c := [(1, 9)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(** Uncomputablity in the definition of R function **)
(** For convenience's sake, we focus on real numbers in [0,1] **)
Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Logic.Classical.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import Classes.Morphisms.
From Coq Require Import QArith.QArith_base.
From Coq Require Import QArith.Qabs.
From Coq Require Import QArith.Qminmax.
From Coq Require Import QArith.Qround.
From Coq Require Import Logic.Classical.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Logic.PropExtensionality.
From Coq Require Import Classes.Equivalence.
Require Import Coq.setoid_ring.Ring_theory.
Require Import Coq.Classes.RelationClasses.
Require Import Ring.
From Coq Require Import Field.
From Coq Require Import Omega.
From CReal Require Import Uncomputable.TMSet.
From CReal Require Import INQ_libs.
From CReal Require Import QArith_base_ext.
From CReal Require Import ComRealBase.
From CReal Require Import ComRealField.
From CReal Require Import ComRealBaseLemma1.
From CReal Require Import ComRealLemmas.
From CReal Require Import ComRealBase_Dec.
From CReal Require Import ComRealBase_TMR.
From Coq Require Import Psatz.
Require Import Coq.Logic.ProofIrrelevance.
Import ListNotations.
Import TM_u_u.

Module Wrong_Up (VirR: VIR_R) (VirRSingleton : VIR_R_SINGLETON VirR) (VirRComp: VIR_R_COMPLETE VirR).
  Import VirR VirRSingleton.

  Module VirRSL := VirRSingletonLemmas VirR VirRSingleton.
  Module VirRSL2 := VirRSingletonLemmas2 VirR VirRSingleton VirRComp.
  Export VirRSL VirRSL2.
  Module Dec := DEC_R VirR VirRSingleton VirRComp.
  Module TMR := TMR_Set VirR VirRSingleton VirRComp.
  Export TMR.
  Local Open Scope R_scope.

  Parameter up : R -> Z.
  Parameter Up_R0 : (up R0 = 0)%Z.
  Axiom up_comp : Proper (Req ==> eq) up.
  Existing Instance up_comp .

  Theorem Up_same : forall (r1 r2 : R) , r1 == r2 -> (up r1 = up r2)%Z.
  Proof.
    intros. rewrite H.
    auto.
  Qed.

  Theorem Up_R : (forall (r : R) (z : Z) , IZR (z - 1) < r /\ r <= IZR z <-> (up r = z)%Z) -> Halting.
  Proof.
    unfold Halting.
    intros.
    pose proof TMR_get i.
    remember (Get_TMR i) as X0.
    clear HeqX0.
    pose proof Z.eq_dec (up X0) 0%Z.
    destruct H0. pose proof H2. destruct H2.
    destruct H1.
    - rewrite <- (H X0 0%Z) in e.
      simpl in *. destruct e.
      rewrite IZR_R0 in H5.
      apply Rge_le in H2.
      pose proof conj H5 H2.
      assert (X0 == 0). { auto with real. }
      clear H6.
      pose proof H7 as H6. clear H7.
      right.
      rewrite Dec_R_eq in H6 ; auto ; try (apply In_Search_R0).
      intros.
      clear H5 H4 H3 H2 H1.
      specialize (H0 j).
      rewrite H6 in H0.
      assert (Nat.b2n (TM i j) = 0)%nat.
      { apply (partial_functional_Dec_R R0 j) ; auto. apply Zero_Dec. }
      apply Nat.b2n_inj. auto.
    - left. destruct H2.
      + apply Dec_R_gt in H1 ; auto ; try (apply In_Search_R0).
        repeat destruct H1. exists x.
        specialize (H0 x).
        destruct (TM i x) ; auto.
        simpl in *.
        pose proof Zero_Dec x.
        exfalso. apply (lt_irrefl O). apply H1 ; auto.
      + apply Up_same in H1.
        exfalso. apply n.
        rewrite H1. apply Up_R0.
  Qed.

End Wrong_Up.

Module CR_uu (VirR: VIR_R) (VirRSingleton : VIR_R_SINGLETON VirR) (VirRComp: VIR_R_COMPLETE VirR).
  Import VirR VirRSingleton.

  Module VirRSL := VirRSingletonLemmas VirR VirRSingleton.
  Module VirRSL2 := VirRSingletonLemmas2 VirR VirRSingleton VirRComp.
  Export VirRSL VirRSL2.
  Module TMR := TMR_Set VirR VirRSingleton VirRComp.
  Export TMR.
  Local Open Scope R_scope.

  Fixpoint sum_f (f : nat -> nat) (n : nat) : Q :=
    match n with
      | 0%nat => INQ (f 0%nat)
      | S n' => (sum_f f n' + (INQ (f n) / INQ (10 ^ n)))%Q
    end.

  Theorem sum_f_expand : forall (f : nat -> nat)(n : nat) , (sum_f f (S n) == sum_f f n + (INQ (f (S n)) / INQ (10 ^ (S n))))%Q.
  Proof.
    intros.
    reflexivity.
  Qed.

  Theorem f_lt_sum_f_lt : forall (f f1 : nat -> nat) , (forall n : nat , (f n < f1 n)%nat) -> (forall n : nat , (sum_f f n < sum_f f1 n)%Q).
  Proof.
    intros.
    induction n.
    - simpl. apply INQ_lt. apply (H O).
    - rewrite (sum_f_expand f n).
      rewrite (sum_f_expand f1 n).
      apply Qplus_lt_le_compat ; auto.
      apply Qlt_le_weak.
      unfold Qdiv.
      assert (~ INQ(10 ^ S n) == 0)%Q.
      {
        unfold not.
        intros.
        apply (Qlt_irrefl 0).
        rewrite <- H0 at 2.
        rewrite <- INQ_Qeq_0.
        apply INQ_lt.
        apply lt_trans with (m := S n).
        destruct n ; omega.
        apply Nat.pow_gt_lin_r. omega.
      }
      apply Qlt_shift_div_l.
      + rewrite <- INQ_Qeq_0. apply INQ_lt.
        apply lt_trans with (m := S n).
        destruct n ; omega.
        apply Nat.pow_gt_lin_r. omega.
      + rewrite <- Qmult_assoc.
        rewrite (Qmult_comm (/ INQ (10 ^ S n)) (INQ (10 ^ S n))).
        rewrite Qmult_inv_r ; auto.
        rewrite Qmult_1_r.
        apply INQ_lt. auto.
  Qed.

  Theorem f_le_sum_f_le : forall (f f1 : nat -> nat) , (forall n : nat , (f n <= f1 n)%nat) -> (forall n : nat , (sum_f f n <= sum_f f1 n)%Q).
  Proof.
    intros.
    induction n.
    - simpl. apply INQ_le. apply (H O).
    - rewrite (sum_f_expand f n).
      rewrite (sum_f_expand f1 n).
      apply Qplus_le_compat; auto.
      unfold Qdiv.
      assert (~ INQ(10 ^ S n) == 0)%Q.
      {
        unfold not.
        intros.
        apply (Qlt_irrefl 0).
        rewrite <- H0 at 2.
        rewrite <- INQ_Qeq_0.
        apply INQ_lt.
        apply lt_trans with (m := S n).
        destruct n ; omega.
        apply Nat.pow_gt_lin_r. omega.
      }
      apply Qle_shift_div_l.
      + rewrite <- INQ_Qeq_0. apply INQ_lt.
        apply lt_trans with (m := S n).
        destruct n ; omega.
        apply Nat.pow_gt_lin_r. omega.
      + rewrite <- Qmult_assoc.
        rewrite (Qmult_comm (/ INQ (10 ^ S n)) (INQ (10 ^ S n))).
        rewrite Qmult_inv_r ; auto.
        rewrite Qmult_1_r.
        apply INQ_le. auto.
  Qed.

  Theorem sum_f_up : forall f : nat -> nat , Indec f -> (forall n : nat , sum_f f (S n) <= sum_f f n + INQ(1) / INQ (10 ^ n))%Q.
  Proof.
    intros.
    rewrite sum_f_expand. rewrite Qplus_le_r.
    assert (INQ (10) / INQ(10 ^ (S n)) == INQ (1) / INQ (10 ^ n))%Q.
    {
      rewrite Nat.pow_succ_r'.
      rewrite <- INQ_mult.
      unfold Qdiv.
      rewrite Qinv_mult_distr.
      rewrite Qmult_assoc.
      rewrite Qmult_inv_r.
      rewrite INQ_Qeq_1. reflexivity.
      unfold not. intros. inversion H0.
    }
    rewrite <- H0.
    apply Qle_shift_div_l.
    - rewrite <- INQ_Qeq_0. apply INQ_lt.
      apply lt_trans with (m := S n).
      destruct n ; omega.
      apply Nat.pow_gt_lin_r. omega.
    - unfold Qdiv.
      assert (~ INQ(10 ^ S n) == 0)%Q.
      {
        unfold not.
        intros.
        apply (Qlt_irrefl 0).
        rewrite <- H1 at 2.
        rewrite <- INQ_Qeq_0.
        apply INQ_lt.
        apply lt_trans with (m := S n).
        destruct n ; omega.
        apply Nat.pow_gt_lin_r. omega.
      }
      rewrite <- Qmult_assoc.
      rewrite (Qmult_comm (/ INQ (10 ^ S n)) (INQ (10 ^ S n))).
      rewrite Qmult_inv_r ; auto.
      pose proof H (S n).
      rewrite Qmult_1_r.
      apply INQ_le.
      apply lt_le_weak ; auto.
      destruct H2; omega.
  Qed.

  Theorem Mono_up_sum_f : forall (f : nat -> nat)(n m : nat) , (n <= m)%nat -> (sum_f f n <= sum_f f m)%Q.
  Proof.
    intros.
    induction H.
    - lra.
    - apply Qle_trans with (sum_f f m) ; auto.
      simpl.
      rewrite <- Qplus_0_r at 1.
      apply Qplus_le_r.
      unfold Qdiv. apply Qmult_le_0_compat.
      + rewrite <- INQ_Qeq_0. apply INQ_le. omega.
      + apply Qinv_le_0_compat. rewrite <- INQ_Qeq_0. apply INQ_le. omega.
  Qed.

  Theorem sum_f_Dec_R_up : forall (f : nat -> nat) (n m : nat) , Indec f -> (n < m)%nat ->  Dec_R (IQR (sum_f f n)) m 0.
  Proof.
    intros.
    generalize dependent m.
    induction n.
    - intros.
      hnf.
      exists ((f 0) * (10 ^ m))%nat. rewrite <- mult_IQR.
      repeat split .
      + apply IQR_le.
        simpl. rewrite INQ_mult. lra.
      + apply IQR_lt. simpl.
        rewrite INQ_mult. apply INQ_lt. omega.
      + assert (m = m - 1 + 1)%nat. { omega. }
        rewrite H1.
        rewrite Nat.pow_add_r.
        rewrite mult_assoc.
        rewrite Nat.mod_mul ; auto.
    - intros. hnf.
      assert (n < m)%nat. { omega. }
      specialize (IHn m H1).
      destruct IHn , H2 , H2.
      rewrite <- mult_IQR in *.
      apply le_IQR in H2. apply lt_IQR in H4.
      exists (x + (f (S n)) * (10 ^ (m - S n)))%nat. rewrite <- mult_IQR in *.
      repeat split .
      + apply IQR_le. rewrite sum_f_expand.
        rewrite Qmult_plus_distr_l. rewrite <- INQ_plus.
        apply Qle_Qplus_Qle ; auto.
        unfold Qdiv. rewrite <- Qmult_assoc. rewrite <- INQ_mult.
        destruct (H (S n)).
        * rewrite H5. rewrite INQ_Qeq_0. rewrite !Qmult_0_l. lra.
        * rewrite H5. rewrite INQ_Qeq_1. rewrite !Qmult_1_l.
          assert (m = m - S n + S n)%nat. { omega. }
          rewrite H6 at 2.
          rewrite Nat.pow_add_r.
          rewrite <- INQ_mult.
          rewrite Qmult_comm at 1.
          rewrite <- Qmult_assoc.
          rewrite Qmult_inv_r.
          rewrite Qmult_1_r. lra.
          intro.
          rewrite <- INQ_Qeq_0 in H7. apply Qeq_INQ_eq in H7.
          apply (lt_irrefl O). rewrite <- H7 at 2.
          apply Max_powan_0. omega.
      + apply IQR_lt. rewrite sum_f_expand.
        rewrite Qmult_plus_distr_l.
        assert (x + f (S n) * 10 ^ (m - S n) + 1 = x + 1 + f (S n) * 10 ^ (m - S n))%nat. { omega. }
        rewrite H5. clear H5. rewrite <- INQ_plus.
        apply Qlt_Qplus_Qle ; auto.
        unfold Qdiv. rewrite <- Qmult_assoc. rewrite <- INQ_mult.
        destruct (H (S n)).
        * rewrite H5. rewrite INQ_Qeq_0. rewrite !Qmult_0_l. lra.
        * rewrite H5. rewrite INQ_Qeq_1. rewrite !Qmult_1_l.
          assert (m = m - S n + S n)%nat. { omega. }
          rewrite H6 at 1.
          rewrite Nat.pow_add_r.
          rewrite <- INQ_mult.
          rewrite Qmult_comm at 1.
          rewrite <- Qmult_assoc.
          rewrite Qmult_inv_r.
          rewrite Qmult_1_r. lra.
          intro.
          rewrite <- INQ_Qeq_0 in H7. apply Qeq_INQ_eq in H7.
          apply (lt_irrefl O). rewrite <- H7 at 2.
          apply Max_powan_0. omega.
      + rewrite Nat.add_mod ; auto.
        rewrite <- H3. rewrite plus_0_l.
        rewrite Nat.mod_mod ; auto.
        assert (m - S n = m - S n - 1 + 1)%nat. { omega. }
        rewrite H5. rewrite Nat.pow_add_r.
        rewrite mult_assoc.
        rewrite Nat.mod_mul ; auto.
  Qed.

  Theorem sum_f_le_0 : forall (f : nat -> nat)(n : nat) , Indec f -> (0 <= IQR (sum_f f n)).
  Proof.
    intros.
    rewrite <- IQR_R0. apply IQR_le.
      apply Qle_trans with (sum_f f O).
      - rewrite <- INQ_Qeq_0. simpl. apply INQ_le. destruct (H O) ; omega.
      - assert (forall n : nat , sum_f f n >= sum_f f O)%Q.
        { intros. induction n0 ; try (lra).
          apply Qle_trans with (sum_f f n0) ; auto.
          apply Mono_up_sum_f. omega.
        }
        apply H0.
  Qed.

  Theorem sum_f_Same_Ipart : forall (f : nat -> nat) (n : nat) , Indec f -> (Same_Ipart (IQR(sum_f f (S n))) (IQR(sum_f f n))).
  Proof.
    intros.
    apply (Same_Ipart_mult _ _ (10 ^ n)).
    - apply Max_powan_0. omega.
    - destruct (archimedean_exists (IQR (sum_f f n) * IQR (10 ^ n)%nat)).
      apply Rle_ge. apply Rmult_le_pos. apply sum_f_le_0 ; auto.
      rewrite INQ_IQR_INR. auto with real.
      exists x. destruct H0.
      rewrite <- INQ_IQR_INR.
      repeat split ; auto.
      + apply Rle_trans with (IQR (sum_f f n) * IQR (10 ^ n)%nat) ; auto.
        rewrite INQ_IQR_INR.
        apply Rmult_le_compat_r. auto with real.
        apply IQR_le. apply Mono_up_sum_f. omega.
      + rewrite <- mult_IQR in *. apply IQR_lt. apply lt_IQR in H1. apply le_IQR in H0.
        rewrite sum_f_expand.
        destruct (H (S n)).
        * rewrite H2. rewrite INQ_Qeq_0. unfold Qdiv. rewrite Qmult_0_l.
          rewrite Qplus_0_r. auto.
        * rewrite H2. clear H2.
          rewrite Qmult_plus_distr_l.
          assert (10 ^ S n = 10 ^ n * 10)%nat. { rewrite mult_comm. apply Nat.pow_succ_r. omega. }
          assert (INQ(1) / INQ(10^ S n) * INQ (10 ^ n) == INQ (1) / INQ(10) )%Q.
          {
            apply (Qmult_inj_r _ _ (INQ 10)).
            - intro. rewrite <- INQ_Qeq_0 in H3. apply Qeq_INQ_eq in H3. inversion H3.
            - rewrite <- Qmult_assoc. rewrite INQ_mult.  rewrite <- H2.
              field. split ; intro.
              + rewrite <- INQ_Qeq_0 in H3. apply Qeq_INQ_eq in H3. inversion H3.
              + apply (Qlt_irrefl 0%Q). rewrite <- H3 at 2.
                rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0 ; omega.
          }
          rewrite H3.
          pose proof (sum_f_Dec_R_up f n (S n)).
          assert (S n > n)%nat. { omega. }
          specialize (H4 H H5). clear H5.
          hnf in H4.
          destruct H4,H4,H4. rewrite <- mult_IQR in *.
          apply le_IQR in H4. apply lt_IQR in H6.
          symmetry in H5.
          apply mod_exists in H5 ; try (omega) .
          destruct H5.  rewrite plus_0_r in *.
          rewrite H2 in *. rewrite <- INQ_mult in *.
          rewrite Qmult_assoc in *.
          subst x0.
          rewrite mult_comm in *.
          rewrite <- INQ_plus in H6.
          rewrite <- INQ_mult in *.
          assert (INQ(10) > 0)%Q. { rewrite <- INQ_Qeq_0. apply INQ_lt. omega. }
          apply Qmult_lt_0_le_reg_r in H4 ; auto.
          assert (INQ(1) == INQ(1) / INQ(10) * INQ(10))%Q. { field. intro. rewrite H7 in H5. apply Qlt_irrefl in H5. auto. }
          rewrite H7 in H6.
          rewrite <- Qmult_plus_distr_l in H6.
          apply Qmult_lt_r in H6 ; auto.
          assert (sum_f f n * (10 ^ n)%nat < x1 + 1%nat)%Q.
          { apply Qlt_trans with (x1 + 1%nat / 10%nat)%Q ; auto.
            apply Qplus_lt_r. rewrite INQ_Qeq_1.
            unfold Qdiv. rewrite Qmult_1_l.
            apply Qlt_shift_inv_r ; auto.
          }
          assert (x = x1).
          {
            apply (Ipart_unique (IQR (sum_f f n * (10 ^ n)%nat))) ; split ; try (apply IQR_le) ; try (apply IQR_lt) ; auto.
            rewrite <- INQ_plus. auto.
          }
          subst.
          apply Qlt_trans with (x1 + 1%nat / 10%nat + 1%nat / 10%nat)%Q.
          ** apply Qplus_lt_l. auto.
          ** rewrite <- INQ_plus. rewrite <- Qplus_assoc.
             apply Qplus_lt_r.
             unfold Qdiv. rewrite <- Qmult_plus_distr_l.
             rewrite INQ_plus. simpl. rewrite INQ_Qeq_1.
             apply Qmult_lt_r with (INQ (10)) ; auto.
  Qed.

  Theorem sum_f_Dec_R_same : forall (f : nat -> nat) (n m : nat) , Indec f -> (m <= n)%nat ->  Dec_R (IQR (sum_f f n)) m (f m).
  Proof.
    intros.
    generalize dependent m.
    induction n.
    - intros. inversion H0.
      subst. exists (f 0)%nat.
      repeat split.
      * rewrite <- mult_IQR. simpl. rewrite Zmult_1_r. apply Rle_refl.
      * rewrite <- mult_IQR. apply IQR_lt. simpl. rewrite INQ_Qeq_1. rewrite Qmult_1_r.
        apply INQ_lt. omega.
      * destruct (H O) ; rewrite H1 ; auto.
    - intros.
      inversion H0.
      * subst. assert (n < S n)%nat. { omega. }
        pose proof sum_f_Dec_R_up f n (S n) H H1.
        clear H0 H1 IHn.
        destruct H2 , H0 , H0.
        hnf.
        exists (x + f (S n))%nat.
        rewrite <- mult_IQR in *. apply le_IQR in H0. apply lt_IQR in H2.
        repeat split.
        + apply IQR_le. rewrite sum_f_expand.
          rewrite Qmult_plus_distr_l.
          rewrite <- INQ_plus.
          apply Qle_Qplus_Qle ; auto.
          rewrite Qmult_comm.
          rewrite Qmult_div_r. lra.
          intro.
          apply (Qlt_irrefl 0).
          rewrite <- H3 at 2.
          rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
        + apply IQR_lt. rewrite sum_f_expand.
          rewrite Qmult_plus_distr_l.
          assert (x + f (S n) + 1 = x + 1 + f (S n))%nat. { omega. }
          rewrite H3. clear H3.
          rewrite <- INQ_plus.
          apply Qlt_Qplus_Qle ; auto.
          rewrite Qmult_comm.
          rewrite Qmult_div_r. lra.
          intro.
          apply (Qlt_irrefl 0).
          rewrite <- H3 at 2.
          rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
        + rewrite Nat.add_mod ; auto.
          rewrite <- H1. rewrite plus_0_l.
          destruct (H (S n)) ; rewrite H3 ; auto.
      * subst. specialize (IHn _ H2).
        subst. assert (n < S n)%nat. { omega. }
        pose proof sum_f_Dec_R_up f n (S n) H H1.
        clear H1.
        destruct IHn , H1 , H1.
        destruct H3 , H3 , H3.
        hnf.
        rewrite <- mult_IQR in *. apply le_IQR in H3. apply lt_IQR in H7.
        exists x.
        split ; auto.
        assert (Same_Ipart (IQR (sum_f f (S n) * (10 ^ m)%nat)) (IQR (sum_f f n * (10 ^ m)%nat))).
        {
          apply  (Same_Ipart_mult _ _ (10 ^ (n - m))).
          - apply Max_powan_0 ; omega.
          - destruct (archimedean_exists (IQR ((sum_f f n) * INQ (10 ^ n)))).
            rewrite mult_IQR. apply Rle_ge. apply Rmult_le_pos.
            apply sum_f_le_0 ; auto.
            rewrite INQ_IQR_INR. auto with real.
            destruct H8.
            exists x1.
            assert (((10 ^ m)%nat * (10 ^ (n - m))%nat) == (10 ^ n)%nat)%Q.
            { rewrite INQ_mult. apply eq_INQ_Qeq.
              rewrite <- Nat.pow_add_r.
              assert (m + (n - m) = n)%nat. { omega. }
              subst. auto.
            }
            rewrite <- INQ_IQR_INR.
            repeat split ; repeat rewrite <- mult_IQR ; try (apply IQR_le) ; try (apply IQR_lt); auto ;
            apply le_IQR in H8 ; apply lt_IQR in H9 ;
            try (rewrite <- Qmult_assoc) ; try (rewrite H10); clear H10;
            try (rewrite sum_f_expand ; rewrite Qmult_plus_distr_l) ; auto.
            + apply Qle_trans with ((sum_f f n) * (INQ (10 ^ n)))%Q ; auto.
              rewrite <- Qplus_0_r at 1.
              apply Qplus_le_r.
              unfold Qdiv.
              assert (INQ(10^n) >= 0)%Q.
              {  rewrite <- INQ_Qeq_0. apply INQ_le. apply lt_le_weak. apply Max_powan_0. omega. }
              apply Qmult_le_0_compat ; auto.
              apply Qmult_le_0_compat.
              * rewrite <- INQ_Qeq_0. apply INQ_le. destruct (H (S n)) ; omega.
              * apply Qinv_le_0_compat.
                rewrite <- INQ_Qeq_0. apply INQ_le. apply lt_le_weak. apply Max_powan_0. omega.
            + assert (10 ^ S n = 10 ^ n * 10)%nat. { rewrite mult_comm. apply Nat.pow_succ_r. omega. }
              assert (INQ(f (S n)) / INQ(10^S n) * INQ (10 ^ n) == INQ (f (S n)) / INQ(10) )%Q.
              {
                apply (Qmult_inj_r _ _ (INQ 10)).
                - intro. rewrite <- INQ_Qeq_0 in H11. apply Qeq_INQ_eq in H11. inversion H11.
                - rewrite <- Qmult_assoc. rewrite INQ_mult.  rewrite <- H10.
                  field. split ; intro.
                  + rewrite <- INQ_Qeq_0 in H11. apply Qeq_INQ_eq in H11. inversion H11.
                  + apply (Qlt_irrefl 0%Q). rewrite <- H11 at 2.
                    rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0 ; omega.
              }
              rewrite H11.
              symmetry in H6.
              apply mod_exists in H6 ; try (omega) .
              destruct H6. rewrite plus_0_r in H6.
              rewrite H10 in *. rewrite <- INQ_mult in *.
              rewrite Qmult_assoc in *.
              subst x0.
              rewrite mult_comm in *.
              rewrite <- INQ_plus in H7.
              rewrite <- INQ_mult in *.
              assert (INQ(10) > 0)%Q. { rewrite <- INQ_Qeq_0. apply INQ_lt. omega. }
              apply Qmult_lt_0_le_reg_r in H3 ; auto.
              assert (INQ(1) == INQ(1) / INQ(10) * INQ(10))%Q. { field. intro. rewrite H12 in H6. apply Qlt_irrefl in H6. auto. }
              rewrite H12 in H7.
              rewrite <- Qmult_plus_distr_l in H7.
              apply Qmult_lt_r in H7 ; auto.
              assert ((sum_f f n) * (10 ^ n)%nat < x2 + 1%nat)%Q.
              { apply Qlt_trans with (x2 + 1%nat / 10%nat)%Q ; auto.
                apply Qplus_lt_r. rewrite INQ_Qeq_1.
                unfold Qdiv. rewrite Qmult_1_l.
                apply Qlt_shift_inv_r ; auto.
              }
              assert (x2 = x1).
              {
                apply (Ipart_unique (IQR ((sum_f f n) * (10 ^ n)%nat))) ; split ; try (apply IQR_le) ; try (apply IQR_lt) ; auto.
                rewrite <- INQ_plus. auto.
              }
              subst.
              apply Qlt_trans with (x1 + 1%nat / 10%nat + f (S n) / 10%nat)%Q.
              * apply Qplus_lt_l. auto.
              * rewrite <- INQ_plus. rewrite <- Qplus_assoc.
                apply Qplus_lt_r.
                unfold Qdiv. rewrite <- Qmult_plus_distr_l.
                rewrite INQ_plus. simpl. rewrite INQ_Qeq_1.
                apply Qmult_lt_r with (INQ (10)) ; auto.
                destruct (H (S n)) ; rewrite H14 ; auto.
        }
        destruct H8 , H8 , H9 , H10.
        assert (x = x1)%nat. {apply (Ipart_unique (IQR ((sum_f f n) * (10 ^ m)%nat))) ; split ; auto. }
        subst.
        split; rewrite <- mult_IQR ; auto.
  Qed.

  Theorem sum_f_In_Search : forall (f : nat -> nat)(n : nat) , Indec f -> (sum_f f n < INQ 10)%Q.
  Proof.
    intros.
    pose proof sum_f_Same_Ipart f.
    assert ((f 0 = 0)%nat -> archimedean 0%nat (IQR (sum_f f O))).
    {
      split .
      - apply IQR_le. apply INQ_le. omega.
      - apply IQR_lt. apply INQ_lt. omega.
    }
    assert ((f 0 = 0)%nat -> forall n : nat , archimedean 0%nat (IQR (sum_f f n))).
    {
      intros.
      induction n0 ; auto.
      destruct (H0 n0 H).
      destruct H3 , H4 , H5. destruct IHn0.
      assert (x = 0)%nat.
      { apply (Ipart_unique (IQR (sum_f f n0))) ; split; auto. }
      subst. split; auto.
    }
    assert ((f 0 = 1)%nat -> archimedean 1%nat (IQR (sum_f f O))).
    {
      split .
      - apply IQR_le. apply INQ_le. omega.
      - apply IQR_lt. apply INQ_lt. omega.
    }
    assert ((f 0 = 1)%nat -> forall n : nat , archimedean 1%nat (IQR (sum_f f n))).
    {
      intros.
      induction n0 ; auto.
      destruct (H0 n0 H).
      destruct H5 , H6 , H7. destruct IHn0.
      assert (x = 1)%nat.
      { apply (Ipart_unique (IQR (sum_f f n0))) ; split ;auto. }
      subst. split; auto.
    }
    destruct (H O).
    - specialize (H1 H5). specialize (H2 H5).
      apply Qlt_trans with (INQ (1%nat)).
      + destruct (H2 n). simpl in H7. apply lt_IQR. auto.
      + apply INQ_lt. omega.
    - specialize (H3 H5). specialize (H4 H5).
      apply Qlt_trans with (INQ(2%nat)).
      + destruct (H4 n). simpl in H7. apply lt_IQR. auto.
      + apply INQ_lt. omega.
  Qed.

  Theorem In_search_sum_f : forall (f :nat -> nat)(n :nat) , Indec f -> In_Search (IQR (sum_f f n)).
  Proof.
    intros.
    split.
    * rewrite <- IQR_R0. apply Rle_ge. apply IQR_le.
      apply Qle_trans with (sum_f f O).
      - rewrite <- INQ_Qeq_0. simpl. apply INQ_le. destruct (H O) ; omega.
      - assert (forall n : nat , sum_f f n >= sum_f f O)%Q.
        { intros. induction n0 ; try (lra).
          apply Qle_trans with (sum_f f n0) ; auto.
          apply Mono_up_sum_f. omega.
        }
        apply H0.
    * apply IQR_lt. apply sum_f_In_Search. auto.
  Qed.

  Theorem InDecR_sum_f : forall ( f: nat -> nat) (n : nat) , Indec f -> InDecR (IQR (sum_f f n)).
  Proof.
    intros.
    hnf. intros m.
    destruct (classic (n < m)%nat).
    - left. apply sum_f_Dec_R_up ; auto.
    - assert (m <= n)%nat. {omega. }
      destruct (H m).
      + left. rewrite <- H2. apply sum_f_Dec_R_same ; auto.
      + right. rewrite <- H2. apply sum_f_Dec_R_same ; auto.
  Qed.

  Theorem sum_f_NQ_eqb : forall (f : nat -> nat) , Indec f -> forall n : nat , NNP_T_NQP (NN_T_NNP f) n ((sum_f f) n).
  Proof.
    intros.
    induction n.
    - repeat split; intros ; hnf in * .
      + destruct H1 , H1 , H1. inversion H0. subst.
        assert (IQR (10 ^ 0)%nat == 1). { auto with real. }
        rewrite H2 in *. clear H2.
        rewrite Rmult_1_r in *.
        apply lt_IQR in H3. apply INQ_lt in H3.
        apply le_IQR in H1. apply INQ_le in H1.
        assert (f 0 = x)%nat. { omega. }
        subst.
        destruct (H O) ; rewrite H2 ; auto.
      + inversion H0. subst.
        exists (f 0%nat).
        split.
        * assert (IQR (10 ^ 0)%nat == 1). { auto with real.  }
          rewrite H1. clear H1.
          split ; rewrite Rmult_1_r.
          ** apply Rle_refl.
          ** apply IQR_lt. apply INQ_lt. omega.
        * destruct (H O) ; rewrite H1 ; auto.
      + exists ( (f 0) * (10 ^ m))%nat.
        split.
        * split ; rewrite <- mult_IQR.
          ** apply IQR_le. simpl. rewrite INQ_mult. apply Qle_refl.
          ** apply IQR_lt. simpl. rewrite INQ_mult. apply INQ_lt. omega.
        * destruct (H O) ; rewrite H1 ; auto.
          rewrite mult_1_l.
          assert (m = m - 1 + 1)%nat. { omega. }
          rewrite H2.
          rewrite Nat.pow_add_r.
          rewrite Nat.mul_mod ; auto.
          assert (10 ^ 1 mod 10 = 0)%nat. { auto. }
          rewrite H3. rewrite mult_0_r. auto.
      + destruct (H O).
        * right. simpl. rewrite H0. apply IQR_R0.
        * left. rewrite <- IQR_R0. apply IQR_lt. simpl. rewrite H0. rewrite INQ_Qeq_1. lra.
      + destruct (H O) ; apply IQR_lt ; apply INQ_lt ; omega.
    - destruct IHn. repeat split ; intros ; auto.
      + inversion H2.
        * subst ; hnf.
          apply (partial_functional_Dec_R (IQR (sum_f f (S n))) (S n)) ; auto.
          apply sum_f_Dec_R_same ; auto.
        * apply H0 ; auto.
          assert (l = f m)%nat.
          {
            apply (partial_functional_Dec_R (IQR (sum_f f (S n))) m) ; auto.
            apply sum_f_Dec_R_same ;  auto.
          }
          subst. apply sum_f_Dec_R_same ; auto.
      + hnf in H3. subst.
        apply sum_f_Dec_R_same ; auto.
      + apply sum_f_Dec_R_up ;  auto.
      + apply Rle_ge.
        apply Rle_trans with (IQR (sum_f f n)).
        destruct H1. auto with real.
        apply IQR_le. apply Mono_up_sum_f. auto.
      + apply IQR_lt. apply (sum_f_In_Search f (S n)). auto.
  Qed.

  Theorem limit_r_Un_cv'_eqb : forall (f : nat -> nat) (r : R) , Indec f -> limit (sum_f f) r <-> (Un_cv' (NNP_T_NQP (NN_T_NNP f)) r).
  Proof.
    intros.
    pose proof InDec_eqb f.
    destruct H0. specialize (H0 H). clear H1.
    split ; intros ; hnf ; simpl in *.
    - split ; intros.
      + repeat split ; hnf ; intros ; subst ; try (rewrite H3 in *; apply H4 ; auto) ;
        try (rewrite <- H3 in *; apply H4 ; auto).
        * exists (sum_f f a). apply sum_f_NQ_eqb. auto.
        * apply (partial_functional_NNP_T_NQP (NN_T_NNP f) H0 a) ; auto.
      + destruct H1.
        specialize (H3 eps H2).
        destruct H3.
        exists x.
        intros.
        assert (q == sum_f f m)%Q.
        { apply (partial_functional_NNP_T_NQP (NN_T_NNP f) H0 m) ; auto.
          apply sum_f_NQ_eqb ; auto.
        }
        apply (H3 _ _ H4 H6).
   - split ; intros.
     + repeat split ; hnf ; intros ; subst ; try (lra).
       exists (sum_f f a). reflexivity.
     + destruct H1.
       specialize (H3 eps H2).
       destruct H3.
       exists x. intros.
       apply (H3 m) ; auto.
       pose proof sum_f_NQ_eqb _ H m. rewrite H5. auto.
  Qed.

  Theorem sum_f_limit_r : forall (f : nat -> nat) (r : R) , Indec f ->
      limit (sum_f f) r <-> (forall n : nat , Dec_R r n (f n)) /\ In_Search r.
  Proof.
    intros.
    split ; intros.
    - apply limit_r_Un_cv'_eqb in H0 ; auto.
      split ; intros.
      * apply (Un_cv'_Dec (NN_T_NNP f)) ; auto.
        + apply InDec_eqb. auto.
        + reflexivity.
      * assert (Sup_Q (NNP_T_NQP (NN_T_NNP f)) r).
        { apply mono_up_limit_sup_Q ; auto.
          - hnf. split ; hnf; intros.
            + repeat split ; hnf ; intros ; subst ; try (rewrite <- H2 in * ; apply H3 ; auto).
              * exists (sum_f f a).
                split ; auto.
                apply sum_f_NQ_eqb. auto. apply In_search_sum_f ; auto.
              * apply InDec_eqb in H.
                apply (partial_functional_NNP_T_NQP (NN_T_NNP f) H a) ; auto.
            + split. apply is_function_NQP_T_NRP. apply is_function_NNP_T_NQP. apply InDec_eqb. auto.
              intros.
              destruct H1 , H1. destruct H2 , H2.
              subst.
              inversion H3.
              * right. rewrite <- H1 , <- H2. apply IQR_eq. subst. apply InDec_eqb in H.
                apply (partial_functional_NNP_T_NQP (NN_T_NNP f) H n) ; auto.
              * subst.
                destruct H4, H5.
                destruct (classic (forall n , (n > n1)/\(n <= S m) -> f n = 0)%nat).
                ** right. apply Dec_R_eq ; intros.
                   rewrite <- H1 ; auto. rewrite <- H2 ; auto.
                   rewrite <- H1 , <- H2 . clear H1 H2.
                   specialize (H4 j). specialize (H5 j).
                   destruct H4 , H5.
                   destruct (classic (j <= n1)%nat).
                   ++ assert (j <= S m)%nat. { omega. }
                      specialize (H1 H11). specialize (H4 H10).
                      rewrite H1. rewrite H4. reflexivity.
                   ++ apply Nat.nle_gt in H10.
                      specialize (H5 H10).
                      destruct (classic (j <= S m)%nat).
                      -- specialize (H1 H11).
                         rewrite H1.
                         split ; intros.
                         *** assert (m0 = 0)%nat. { destruct H12. auto. }
                             subst. auto.
                         *** assert (m0 = 0)%nat. { apply (partial_functional_Dec_R (IQR x0) j) ; auto. }
                             subst. hnf. apply H9. omega.
                      -- apply Nat.nle_gt in H11.
                         specialize (H2 H11).
                         split ; intros.
                         *** assert (m0 = 0)%nat. { apply (partial_functional_Dec_R (IQR x) j) ; auto. }
                             subst. auto.
                         *** assert (m0 = 0)%nat. { apply (partial_functional_Dec_R (IQR x0) j) ; auto. }
                             subst. auto.
                ** apply not_all_ex_not in H9. destruct H9.
                   pose proof H9.
                   apply not_imply_elim in H9.
                   apply not_imply_elim2 in H10.
                   rewrite <- H1 , <- H2. clear H1 H2.
                   left. pose proof (H4 x1). pose proof (H5 x1).
                   destruct H9 , H1 , H2.
                   specialize (H13 H9). specialize (H1 H11).
                   assert (f x1 = 1)%nat. {destruct (H x1) ; auto. exfalso. auto. }
                   apply Dec_R_lt ; auto.
                   exists x1. split ; intros.
                   ++ assert (m1 = 0)%nat. {apply (partial_functional_Dec_R (IQR x0) x1) ; auto. }
                      assert (Dec_R (IQR x) x1 1). { apply H1 ; hnf ;  auto. }
                      assert (m2 = 1)%nat. {apply (partial_functional_Dec_R (IQR x) x1) ; auto. }
                      subst. auto.
                   ++ clear H10 H8.
                      assert (k <= S m)%nat. { omega. }
                      specialize (H4 k). specialize (H5 k).
                      destruct H4 , H5. specialize (H4 H8). rewrite H4 in H17.
                      hnf in H17.
                      destruct (classic (k <= n1)%nat).
                      --  specialize (H5 H19). rewrite H5 in H16. hnf in H16.
                          subst. auto.
                      --  apply Nat.nle_gt in H19. specialize (H18 H19).
                          assert (m1 = 0)%nat. {apply (partial_functional_Dec_R (IQR x0) k) ; auto. }
                          subst. omega.
          - exists 2. apply Dec_R2_bound. apply InDec_eqb. auto.
        }
        assert (upper_bound_Q (NNP_T_NQP (NN_T_NNP f)) 2). { apply Dec_R2_bound. apply InDec_eqb. auto. }
        destruct H1.
        hnf in H3.
        split .
        + apply Rle_ge.
          apply Rle_trans with (IQR (INQ (f 0)%nat)).
          ** rewrite <- IQR_R0. apply IQR_le.
             rewrite <- INQ_Qeq_0. apply INQ_le. destruct (H O) ; omega.
          ** apply (H3 O).
             hnf. exists (INQ (f 0%nat)).
             split; auto with real.
             hnf. split ; intros.
             ++ split ; intros.
                -- inversion H4. subst.
                   pose proof (sum_f_Dec_R_same f O O H H4).
                   simpl in H5.
                   split ; intros.
                   assert (l = f 0%nat). {apply (partial_functional_Dec_R (IQR (f 0%nat)) 0) ; auto. }
                   hnf . auto.
                   hnf in H6. subst. auto.
                -- apply (sum_f_Dec_R_up f O m) ; auto.
             ++ apply (In_search_sum_f f O). auto.
        + apply Rle_lt_trans with 2.
          ** apply Rge_le. apply H1. auto.
          ** apply R2_Rlt_R10.
    - hnf. split ; intros.
      + repeat split ; hnf ; intros ; subst ; try (rewrite H2 in * ; auto).
        * exists (sum_f f a). reflexivity.
      + apply eps_gt_10n in H1.
        destruct H1.
        exists x.
        intros.
        subst. apply IQR_eq in H3. rewrite H3.
        rewrite <- !INQ_IQR_INR in *.
        assert (IQR 1%nat = IQR 1). { auto. } rewrite H4 in *. clear H4.
        apply Rlt_trans with (IQR 1 * / IQR (10 ^ x)%nat) ; auto.
        apply Dec_R_eq_lemma ; auto.
        * apply In_search_sum_f. auto.
        * apply H0.
        * intros. split ; intros.
          ** assert (f j = m0)%nat. { apply (partial_functional_Dec_R (IQR (sum_f f m)) j) ; auto.
                                      apply sum_f_Dec_R_same ; auto. omega. }
             subst. apply H0.
          ** assert (f j = m0)%nat. { apply (partial_functional_Dec_R r j) ; auto. apply H0. }
             subst. apply sum_f_Dec_R_same ; auto. omega.
  Qed.

  Theorem sum_f_limit_eps : forall (f : nat -> nat)(n m : nat) , Indec f -> (n <= m) % nat -> (Qabs(sum_f f n - sum_f f m) < 1 / INQ (10^n))%Q.
  Proof.
    intros.
    apply Qabs_diff_Qlt_condition.
    assert (Rabs(IQR (sum_f f n) - IQR (sum_f f m)) < IQR 1 / IQR ((10^n)%nat)).
    { apply Dec_R_eq_lemma ; try (apply In_search_sum_f ; auto).
      intros.
      split ; intros.
      * assert (f j = m0)%nat. { apply (partial_functional_Dec_R (IQR (sum_f f n)) j) ; auto.
                                 apply sum_f_Dec_R_same ; auto. }
        subst. apply sum_f_Dec_R_same ; auto. omega.
      * assert (f j = m0)%nat. { apply (partial_functional_Dec_R (IQR (sum_f f m)) j) ; auto.
                                 apply sum_f_Dec_R_same ; auto. omega. }
        subst. apply sum_f_Dec_R_same ; auto.
    }
    apply Rabs_tri in H1.
    destruct H1.
    assert (IQR 1 / IQR (10 ^ n)%nat == IQR (1 / (10^n)%nat)).
    {
      unfold Rdiv.
      rewrite IQR_inv.
      - rewrite <- mult_IQR. reflexivity.
      - intro. apply (Qlt_irrefl 0).
        rewrite <- H3 at 2.
        rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
    }
    split; apply lt_IQR.
    - apply Rlt_le_trans with (IQR (sum_f f m) + IQR 1 / IQR (10 ^ n)%nat) ; auto.
      rewrite plus_IQR.
      apply Rplus_le_compat_l.
      rewrite <- H3. apply Rle_refl.
   - apply Rle_lt_trans with (IQR (sum_f f m) - IQR 1 / IQR (10 ^ n)%nat) ; auto.
     apply Rle_Rminus.
     unfold Qminus. rewrite plus_IQR.
     rewrite <- (Rplus_0_r (IQR (sum_f f m))) at 2.
     rewrite Rplus_assoc.
     apply Rplus_le_compat_l.
     rewrite H3.
     rewrite <- plus_IQR. rewrite <- IQR_R0.
     apply IQR_le. lra.
  Qed.

  Theorem P_OR_NP : (forall P : Prop, {P} + {~ P}) -> Halting.
  Proof.
    unfold Halting.
    intros.
    pose proof X (exists j : nat , TM i j = true).
    destruct H ; auto.
    right.
    intros.
    destruct (TM i j) eqn : En ; auto.
    exfalso. apply n. exists j. auto.
  Qed.

  Theorem Two_dimensions : (forall r1 r2 : R, {r1 == r2} + {~ r1 == r2}) -> Halting.
  Proof.
    unfold Halting.
    intros.
    pose proof TMR_get i.
    remember (Get_TMR i) as X0.
    pose proof X X0 R0.
    clear HeqX0 X. destruct H.
    destruct H0.
    - rewrite Dec_R_eq in r ; auto.
      + right. intros.
        pose proof Zero_Dec j.
        rewrite <- r in H0.
        specialize (H j).
        assert (0 = Nat.b2n (TM i j))%nat. { apply (partial_functional_Dec_R X0 j) ; auto. }
        apply Nat.b2n_inj. auto.
      + apply In_Search_R0.
    - apply Dec_R_not_eq in n ; auto.
      + left. destruct n.
        exists x.
        pose proof Zero_Dec x.
        specialize (H x).
        assert (Nat.b2n (TM i x) <> 0)%nat.
        { intro. apply (H0 O) ; auto.
          rewrite H3 in H. auto.
        }
        destruct (TM i x) ; auto.
      + apply In_Search_R0.
  Qed.

  Theorem Three_dimensions : (forall r1 r2 : R, {r1 == r2} + {r1 > r2} + {r1 < r2}) -> Halting.
  Proof.
    intros.
    apply Two_dimensions.
    intros.
    pose proof (X r1 r2).
    clear X.
    destruct H ; auto with real.
    destruct s ; auto with real.
  Qed.

  Theorem Two_dimensions2 : (forall r1 r2 : R, {r1 >= r2} + {r1 < r2}) -> Halting.
  Proof.
    intros.
    apply Three_dimensions.
    intros.
    pose proof (X r1 r2).
    destruct H ; auto.
    pose proof (X r2 r1).
    destruct H ; auto.
    left. left. auto with real.
  Qed.

  Theorem Exam_dimensions2 : (forall r : R , {r == R0} + {~ r == R0}) -> Halting.
  Proof.
    unfold Halting.
    intros.
    apply Two_dimensions.
    intros.
    pose proof X (r1 - r2).
    destruct H.
    - left. auto with real.
    - right. auto with real.
  Qed.

  Definition CR (r : R) : Prop :=
      exists f : nat -> nat, Indec f /\  (forall (n: nat), Dec_R r n (f n)).
  Definition CR1 (r : R) := {f : nat -> nat | Indec f /\  (forall (n: nat), Dec_R r n (f n)) }.
  (** exists a sequence of rational number limits to r *)
  Definition CR2 (r : R) := exists f : nat -> Q, limit f r.
  (** exists a Cauthy sequence of rational number limits to r *)
  Definition CR3 (r : R) :=
      {f : nat -> Q & {N : Q -> nat | limit f r
      /\ (forall eps : Q , (eps > 0)%Q -> forall (n m : nat) , (n >= N eps)%nat /\ (n >= 1) %nat -> (m >= n)%nat -> (Qabs(f n - f m) < eps)%Q)
      /\ (forall n , (f n >= 0)%Q) } }.

  Theorem CR1_CR : forall r : R , CR1 r -> CR r.
  Proof.
    intros.
    unfold CR1 in *.
    unfold CR in *.
    destruct H as [f ?].
    exists f. auto.
  Qed.
  Theorem CR3_CR2 : forall r : R , CR3 r -> CR2 r.
  Proof.
    unfold CR3 in *.
    unfold CR2 in *.
    intros.
    destruct H as [? [? ?]].
    exists x. destruct a. auto.
  Qed.

  Theorem CR_CR2 : forall r : R , In_Search r -> CR r -> CR2 r.
  Proof.
    unfold CR.
    unfold CR2.
    intros.
    destruct H0 , H0.
    exists (sum_f x).
    rewrite sum_f_limit_r ; auto.
  Qed.

  Theorem CR1_CR3 : forall r : R , In_Search r -> CR1 r -> CR3 r.
  Proof.
    unfold CR1.
    unfold CR3.
    intros.
    destruct H0 , a.
    exists (sum_f x).
    exists (fun eps => eps_arrow_nat eps).
    split.
    - rewrite sum_f_limit_r ; auto.
    - split ; intros ; try (apply le_IQR ; rewrite IQR_R0 ; apply Rge_le ;
        apply In_search_sum_f ; auto).
      destruct H3.
      pose proof eps_arrow_correct eps.
      remember (eps_arrow_nat eps) as n0.
      apply Qlt_trans with (y := (1 / INQ(n0))%Q).
      + apply Qlt_trans with (y := (1 / INQ(10^n))%Q).
        * apply sum_f_limit_eps ; auto.
        * apply Qlt_shift_div_l.
          ** rewrite Heqn0. apply eps_arrow_pro ; auto.
          ** rewrite Qmult_comm.
             assert (1 / INQ (10 ^ n) == / INQ (10 ^ n))%Q.
             {
               field.
               unfold not.
               intros.
               apply (Qlt_irrefl 0).
               rewrite <- H7 at 2.
               rewrite <- INQ_Qeq_0. apply INQ_lt.
               apply Max_powan_0. omega.
             }
             rewrite H7.
             clear H7.
             apply Qlt_shift_div_r.
             rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
             rewrite Qmult_1_l.
             apply INQ_lt.
             apply le_lt_trans with (m := n) ; auto.
             apply Nat.pow_gt_lin_r . omega.
      + apply Qlt_shift_div_r.
        * rewrite Heqn0. apply eps_arrow_pro ; auto.
        * rewrite Qmult_comm.
        assert (1 == 1 / eps * eps)%Q.
        { field. unfold not. intros.
          rewrite H7 in H2. apply (Qlt_irrefl 0). auto.
        }
        rewrite H7 at 1.
        apply Qmult_lt_compat_r ; auto.
  Qed.

  Theorem TM'r_is_computable1 : forall n : nat , CR1 (TM'r n).
  Proof.
    intros.
    unfold CR1.
    exists (fun n0 => Nat.b2n (TM n0 n)).
    intros.
    split.
    - hnf. intros.
      destruct (TM x n) ; auto.
    - apply TM'r_pro.
  Qed.

  Theorem TM'r_is_computable : forall n : nat , CR (TM'r n).
  Proof.
    intros.
    apply CR1_CR. apply TM'r_is_computable1.
  Qed.

  Theorem TM'r_is_computable3 : forall n : nat , CR3 (TM'r n).
  Proof.
    intros.
    apply CR1_CR3.
    apply In_Search_TM'r.
    apply TM'r_is_computable1.
  Qed.

  Theorem TM'r_is_computable2 : forall n : nat , CR2 (TM'r n).
  Proof.
    intros.
    apply CR3_CR2. apply TM'r_is_computable3.
  Qed.

  Theorem lim_CN_NCN : (forall (Un:nat -> R) (l1:R), Un_cv Un l1 -> (forall n : nat ,CR (Un n)) -> CR l1) -> Halting_easy'.
  Proof.
    intros.
    pose proof H TM'r limitTM'r limit_of_TM'r TM'r_is_computable.
    clear H.
    unfold CR in *.
    unfold Halting_easy'.
    inversion H0.
    intros. destruct H.
    pose proof H1 i.
    clear H1.
    destruct (limitTM'r_pro0 i).
    - rewrite (limitTM'r_pro' i) in H1.
      assert (H' : {exists j : nat, TM i j = true} + {forall j : nat, TM i j = false}) by auto.
      exists H'. auto.
    - rewrite (limitTM'r_pro i) in H1.
      assert (H' : {exists j : nat, TM i j = true} + {forall j : nat, TM i j = false}) by auto.
      exists H'. auto.
  Qed.

  Theorem lim_CN_NCN' : (forall (Un:nat -> R) (l1:R), Un_cv Un l1 -> (forall n : nat ,CR (Un n)) -> CR l1) -> Halting_easy.
  Proof.
    intros.
    pose proof H TM'r limitTM'r limit_of_TM'r TM'r_is_computable.
    clear H.
    unfold CR in *.
    unfold Halting_easy.
    destruct H0 as [f ?].
    unfold Halting.
    refine (@ex_intro _ _ _ I).
    intros. destruct H.
    pose proof H0 i.
    clear H0.
    destruct (f i) as [ | [ | ]].
    - right. apply limitTM'r_pro' ; auto.
    - left. apply limitTM'r_pro ; auto.
    - exfalso.
      destruct (limitTM'r_pro0 i).
      + assert (0 = S (S n))%nat. { apply (partial_functional_Dec_R limitTM'r i) ; auto. }
        inversion H2.
      + assert (1 = S (S n))%nat. { apply (partial_functional_Dec_R limitTM'r i) ; auto. }
        inversion H2.
  Qed.

  Theorem lim_CN1_NCN : (forall (Un:nat -> R) (l1:R), Un_cv Un l1 -> (forall n : nat ,CR1 (Un n)) -> CR1 l1) -> Halting.
  Proof.
    unfold Halting.
    intros.
    pose proof X TM'r limitTM'r limit_of_TM'r TM'r_is_computable1.
    clear X.
    unfold CR1 in *.
    destruct H as [f ]. destruct a.
    specialize (H0 i).
    destruct (f i) as [ | [ | ]].
    - right. apply limitTM'r_pro' ; auto.
    - left. apply limitTM'r_pro ; auto.
    - exfalso.
      destruct (limitTM'r_pro0 i).
      + assert (0 = S (S n))%nat. { apply (partial_functional_Dec_R limitTM'r i) ; auto. }
        inversion H2.
      + assert (1 = S (S n))%nat. { apply (partial_functional_Dec_R limitTM'r i) ; auto. }
        inversion H2.
  Qed.

  Theorem lim_CN3_NCN : (forall (Un:nat -> R) (l1:R), Un_cv Un l1 -> (forall n : nat ,CR3 (Un n)) -> CR3 l1) -> Halting.
  Proof.
    intros.
    apply limitTM'r_pro1.
    intros.
    pose proof X TM'r limitTM'r limit_of_TM'r TM'r_is_computable3.
    clear X.
    unfold CR3 in *.
    destruct H as [f [N [? ?]]].
    set (INQ 1 / INQ (10 ^ (S (S n))))%Q.
    assert (H' : (0 < q)%Q).
    {
      subst q.
      rewrite INQ_Qeq_1. unfold Qdiv. rewrite Qmult_1_l.
      apply Qinv_lt_0_compat.
      rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
    }
    remember (q / INQ 2)%Q as eps0.
    assert (H'' : (0 < eps0 )%Q).
    {
      subst.
      apply Qlt_shift_div_l.
      - rewrite <- INQ_Qeq_0. apply INQ_lt. omega.
      - rewrite Qmult_0_l. auto.
    }
    destruct H0.
    pose proof H0 _ H''.
    remember (N eps0) as n1.
    remember (max (S n1) n) as n0.
    clear H0.
    assert (H''' : (n0 >= n1 /\ n0 >= 1)%nat).
    {
      assert (max (S n1) n >= S n1)%nat. { apply Nat.le_max_l. }
      split ; rewrite Heqn0 ; omega.
    }
    assert (Rabs (IQR (f n0) - limitTM'r) < IQR q).
    {
      destruct H.
      assert (IQR eps0 > R0).
      { rewrite <- IQR_R0. apply IQR_lt. auto. }
      specialize (H0 _ H3).
      destruct H0.
      assert (max n0 x >= x)%nat. { apply Nat.le_max_r. }
      assert (max n0 x >= n0)%nat. { apply Nat.le_max_l. }
      remember (max n0 x) as x0.
      assert (f x0 == f x0)%Q. { lra. }
      specialize (H0 _ _ H4 H6).
      specialize (H2 _ _ H''' H5).
      clear H''' H5 H6 H4.
      apply Rabs_tri in H0.
      destruct H0.
      apply Qabs_diff_Qlt_condition in H2.
      destruct H2.
      assert (q == eps0 + eps0)%Q.
      { subst. unfold Qdiv. rewrite <- Qmult_plus_distr_r.
        assert (/ INQ 2 + / INQ 2 == (2 # 1) * / INQ 2)%Q.
        { field. intro. rewrite <- INQ_Qeq_0 in H6. apply Qeq_INQ_eq in H6. omega. }
        assert (INQ 2 > 0)%Q. { rewrite <- INQ_Qeq_0. apply INQ_lt. omega. }
        rewrite H6.
        simpl. rewrite <- Qmult_1_r at 1.
        apply Qmult_inj_l.
        lra. rewrite <- (Qmult_inv_r (INQ 2)) ; try (lra).
        apply Qinv_lt_0_compat in H7.
        apply Qmult_inj_r ; try (lra).
        assert (INQ (2) == INQ (1) + INQ(1))%Q.
        { rewrite INQ_plus. simpl. reflexivity. }
        rewrite H8. rewrite INQ_Qeq_1. reflexivity.
      }
      assert (IQR q == IQR eps0 + IQR eps0).
      {
        apply NNPP. intro.
        apply Rdichotomy in H7.
        destruct H7 ; rewrite <- plus_IQR in H7 ; apply lt_IQR in H7 ; lra.
      }
      rewrite H7.
      clear H7 H6.
      apply Rabs_tri.
      apply IQR_lt in H2.
      apply IQR_lt in H5.
      rewrite plus_IQR in *.
      rewrite minus_IQR in *.
      split.
      - rewrite <- Rplus_assoc.
        apply Rlt_trans with (IQR (f x0) + IQR eps0) ; auto.
        apply Rplus_lt_compat_r ; auto.
      - apply Rlt_Rminus_Rplus. apply Rlt_Rminus_Rplus in H5.
        apply Rlt_Rminus_Rplus in H4.
        apply Rlt_trans with (IQR eps0 + IQR (f x0)) ; auto.
        rewrite Rplus_assoc.
        apply Rplus_lt_compat_l ; auto.
    }
    subst q.
    assert (IQR (1%nat / (10 ^ (S (S n)))%nat) == IQR 1 / IQR (10 ^ (S (S n)))%nat).
    { unfold Rdiv. unfold Qdiv.
      rewrite mult_IQR. rewrite INQ_IQR_INR. rewrite IQR_R1. rewrite INR_R1.
      rewrite IQR_inv. auto. reflexivity.
      intro.
      apply (Qlt_irrefl 0%Q).
      rewrite <- H3 at 2. rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
    }
    rewrite H3 in H0.
    clear H3.
    assert (forall n : nat , ~ ((10 ^ n)%nat == 0)%Q).
    { intros. intro.
      apply (Qlt_irrefl 0%Q).
      rewrite <- H3 at 2.
      rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
    }
    assert (forall n : nat , (10 ^ n)%nat > 0)%Q.
    { intros.
      rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
    }
    assert (Rabs (IQR (f n0) - limitTM'r) < IQR 1 / IQR (10 ^ S n)%nat).
    { apply Rlt_trans with (IQR 1 / IQR (10 ^ S (S n))%nat) ; auto.
      rewrite IQR_R1. unfold Rdiv. rewrite !Rmult_1_l.
      rewrite !IQR_inv ; auto.
      apply IQR_lt. apply Qlt_shift_inv_r ; auto.
      rewrite Qmult_comm.
      assert ((10 ^ (S (S n)))%nat == 10%nat * (10 ^ S n)%nat)%Q.
      { rewrite Nat.pow_succ_r'. rewrite INQ_mult. ring. }
      rewrite H5.
      rewrite <- Qmult_assoc. rewrite Qmult_inv_r ; auto.
      rewrite Qmult_1_r. rewrite <- INQ_Qeq_1. apply INQ_lt. omega.
    }
    pose proof Dec_R_eps_same _ _ (S n) H5.
    assert (Same_Ipart_n limitTM'r (S n - 1)).
    {
      assert (IQR 1%nat / IQR (10 ^ (S (S n - 1)))%nat == IQR (1%nat / (10 ^ (S (S n - 1)))%nat)).
      { unfold Rdiv. rewrite INQ_IQR_INR. rewrite INR_R1. rewrite Rmult_1_l.
        rewrite IQR_inv.
        apply IQR_eq.
        unfold Qdiv. rewrite INQ_eq_1. rewrite Qmult_1_l. reflexivity.
        intro. rewrite <- INQ_Qeq_0 in H7.
        apply Qeq_INQ_eq in H7. apply lt_irrefl with O.
        rewrite <- H7 at 2. apply Max_powan_0. omega.
      }
      pose proof Same_Ipart_pow10n limitTM'r (S n - 1).
      assert (In_Search limitTM'r). { apply InSearch_limitTM'r. }
      assert (InDecR_n limitTM'r (S (S n - 1))). { apply InDecR_all_n. apply limitTM'r_pro0. }
      specialize (H8 H9 H10). clear H9 H10.
      hnf in *.
      destruct H8. exists x. rewrite <- H7 in *.
      rewrite <- !INQ_IQR_INR in *. auto with real.
    }
    destruct (Dec_Q_nine (f n0) (S n)).
    - rewrite <- IQR_R0. apply IQR_le. auto.
    - apply (Dec_Q_Dec_R_same _ (f n0)) ; auto.
      apply InSearch_limitTM'r.
      apply limitTM'r_pro0.
    - destruct (Dec_Q (f n0) n).
      + rewrite <- IQR_R0. apply IQR_le. auto.
      + rewrite H6 in d ; auto.
        apply Dec_R_nine_same.
        rewrite <- IQR_R0. apply Rle_ge. apply IQR_le. auto.
        assert (S (S n - 1) = S n)%nat. { omega. }
        rewrite H8. auto.
      + rewrite H6 in n3 ; auto.
        right. destruct (limitTM'r_pro0 n) ; auto.
        exfalso. auto.
        apply Dec_R_nine_same.
        rewrite <- IQR_R0. apply Rle_ge. apply IQR_le. auto.
        assert (S (S n - 1) = S n)%nat. { omega. }
        rewrite H8. auto.
  Qed.

End CR_uu.


(** Coq coding by choukh, Aug 2021 **)

(* 基于安德森[2]第4节对可满足性的讨论 *)

Require Import CM.Logic.Classical.
Require Import CM.Logic.Model.Var_B_ab_a.

Definition 缺陷性 : 性质 := λ x, x = b.

Definition 积极 : 泛性质 性质 := λ Φ, 反 Φ ⇒ 缺陷性.
Definition 消极 := λ Φ, ¬ 积极 Φ.

Theorem 积极性质的反面消极 : ⌈∀ Φ, 积极 Φ → 消极 (反 Φ)⌋.
Proof.
  证明. intros Φ HP HN. destruct w.
  - 排中 ((Φ a) w₁).
    + assert (((反 反 Φ) a) w₁). firstorder.
      apply 𝗧 in HN. apply HN in H0. discriminate.
    + apply 𝗧 in HP. apply HP in H. discriminate.
  - 排中 ((Φ a) w₂).
    + assert (((反 反 Φ) a) w₂). firstorder.
      apply 𝗧 in HN. apply HN in H0. discriminate.
    + apply 𝗧 in HP. apply HP in H. discriminate.
Qed.

Theorem 积极的必然后果也积极 : ⌈∀ Φ Ψ : 性质, 积极 Φ → (Φ ⟹ Ψ) → 积极 Ψ⌋.
Proof.
  证明. intros Φ Ψ HP H. 必入. intros x HΨ.
  排中 ((Φ a) w0) as [HΦ|HΦ].
  - pose proof (H w0 R) as H'.
      apply H' in HΦ; [|destruct w0; constructor].
      destruct x. exfalso; auto. reflexivity.
  - pose proof (HP w0 R) as HP'.
    apply HP' in HΦ. discriminate.
Qed.

(* x具有神性，当且仅当x必然有且仅必然有积极性质 *)
Definition 神性 : 性质 := λ x, ∀ Φ, □ Φ x ↔ 积极 Φ.

Theorem 神性积极 : ⌈积极 神性⌋.
Proof.
  证明. 必入. intros x Hng.
  destruct x; [exfalso|reflexivity].
  apply Hng. intros Φ. split; intros H.
  - 必入. intros y Hy. destruct y; firstorder.
  - 必入. 反证. apply H in 反设. discriminate. apply R0.
Qed.

Theorem 积极性质必然积极 : ⌈∀ Φ, 积极 Φ → □ 积极 Φ⌋.
Proof.
  证明. intros Φ HP. 必入. 必入. intros x H.
  destruct x; [exfalso|reflexivity].
  apply H. 反证. apply HP in 反设. discriminate.
  destruct w; destruct w0; destruct w1; constructor.
Qed.

(* P是x的本性，当且仅当x必然有且仅必然有P的必然后果 *)
Definition 本性 : 性质 → 实体 → 命题 :=
  λ Φ x, ∀ Ψ, □ Ψ x ↔ Φ ⇒ Ψ.

(* 实体实在，当且仅当该实体的任意本性都必然存在实例 *)
Definition 实在性 : 性质 := λ x, ∀ Φ, 本性 Φ x → □ ∃ x, Φ x.

Theorem 实在性积极 : ⌈积极 实在性⌋.
Proof.
  证明. 必入. intros x H.
  destruct x; [exfalso|reflexivity].
  apply H. intros Φ HE. 必入.
  exists a. firstorder.
Qed.

Lemma 存在偶然命题 : ⌈∃ P, P ∧ ◇ ¬ P⌋.
Proof.
  证明. destruct w.
  - set (∃ᴱ x y, x ≠ y) as P. exists P. split.
    + exists a. split. constructor.
      exists b. split. constructor. discriminate.
    + 可入 w₂. constructor.
      intros [x [Hx [y [Hy Hnq]]]].
      inversion Hx. inversion Hy. congruence.
  - set (∀ᴱ x y, x = y) as P. exists P. split.
    + intros x Hx y Hy.
      inversion Hx. inversion Hy. reflexivity.
    + 可入 w₁. constructor.
      intros H. pose proof (H a a₁ b b₁). discriminate.
Qed.

Theorem 反模态坍塌 : ⌈¬ ∀ P, P → □ P⌋.
Proof. 证明. pose proof 存在偶然命题. firstorder. Qed.