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 Logic.ProofIrrelevance.
From Coq Require Import Classes.Equivalence.
From Coq Require Import setoid_ring.Ring_theory.
From Coq Require Import Classes.RelationClasses.
From Coq Require Import setoid_ring.Ring.
From Coq Require Import setoid_ring.Field.
From Coq Require Import omega.Omega.
From Coq Require Import micromega.Psatz.
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 ComRealLemmas.
From CReal Require Import ComRealBaseLemma1.
From CReal Require Import ComRealBase_Dec.
Import ListNotations.
Import TM_u_u.

Module TMR_Set (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.
  Module Dec := DEC_R VirR VirRSingleton VirRComp.
  Export VirRSL VirRSL2 Dec.
  Local Open Scope R_scope.

  Definition limit : (nat -> Q) -> R -> Prop.
    intros.
    set (fun n q => q == H n)%Q.
    apply (Un_cv' P X).
  Defined.

  Definition Un_cv : (nat -> R) -> R -> Prop.
    intros.
    set (fun n r => r == X n).
    apply (Un_cv P X0).
  Defined.

  Instance Un_cv_comp : Proper (eq ==> Req ==> iff) Un_cv.
  Proof.
    hnf ; red ; intros.
    subst.
    repeat split ; intros ; destruct H ;  hnf in * ; subst ; try (apply H);
    try (rewrite <- H2 in * ; auto).
    - specialize (H2 _ H1). destruct H2. exists x. intros.
      rewrite <- H0. apply (H2 m) ; auto.
    - specialize (H2 _ H1). destruct H2. exists x. intros.
      rewrite  H0. apply (H2 m) ; auto.
  Qed.

  Definition TMR : nat -> R -> Prop.
    intros n r.
    apply ((forall m : nat , Dec_R r m (Nat.b2n(TM n m))) /\ In_Search r).
  Defined.

  Theorem image_Defined_TMR : image_defined TMR.
  Proof.
    hnf ; intros.
    set (fun n m => Nat.b2n (TM a n) = m).
    assert (InDec P).
    {
      subst P. split .
      - intros. destruct (TM a x) ; auto.
      - intros. subst. auto.
    }
    set (NNP_Dec P H).
    destruct (image_defined_Dec_r d).
    destruct H0.
    exists x.
    split ; auto.
    intros.
    apply H0.
    simpl. reflexivity.
  Qed.

  Theorem injective_TMR : injective eq TMR.
  Proof.
    hnf ; intros.
    destruct H,  H0.
    apply TMuu_eqb. intros.
    specialize (H j).
    specialize (H0 j).
    apply Nat.b2n_inj.
    apply (partial_functional_Dec_R b j) ; auto.
  Qed.

  Theorem partial_functional_TMR : partial_functional Req TMR.
  Proof.
    hnf ; intros.
    destruct H , H0.
    apply Dec_R_eq ; auto.
    intros. specialize (H j). specialize (H0 j).
    split ; intros.
    + assert (m = Nat.b2n (TM a j)). { apply (partial_functional_Dec_R b1 j) ; auto. }
      subst. auto.
    + assert (m = Nat.b2n (TM a j)). { apply (partial_functional_Dec_R b2 j) ; auto. }
      subst. auto.
  Qed.

  Instance TMR_comp : Proper (eq ==> Req ==> iff) TMR.
  Proof.
    hnf ; red ; intros ; subst ; split ; intros.
    - destruct H. split ; intros ; rewrite <- H0 ;auto.
    - destruct H. split ; intros ; rewrite H0 ; auto.
  Qed.

  Definition Get_TMR : nat -> R.
    intros n.
    pose proof (image_Defined_TMR n).
    apply Rsinglefun.
    exists (TMR n).
    split ; intros.
    - apply (partial_functional_TMR n) ; auto.
    - split ; auto.
      hnf. intros. hnf in H0. subst. rewrite H0. reflexivity.
  Defined.

  Theorem TMR_get : forall n : nat , TMR n (Get_TMR n).
  Proof.
    intros.
    apply (Rsinglefun_correct (TMR n)).
  Qed.

  Definition TMr : nat -> R -> Prop.
    intros n r.
    apply ((forall m : nat , Dec_R r m (Nat.b2n(TM m n))) /\ In_Search r).
  Defined.

  Instance TMr_comp : Proper (eq ==> Req ==> iff) TMr.
  Proof.
    hnf ; red ; intros ; subst ; split ; intros.
    - destruct H. split ; intros ; rewrite <- H0 ;auto.
    - destruct H. split ; intros ; rewrite H0 ; auto.
  Qed.

  Theorem image_Defined_TMr : image_defined TMr.
  Proof.
    hnf ; intros.
    set (fun n m => Nat.b2n (TM n a) = m).
    assert (InDec P).
    {
      subst P. split .
      - intros. destruct (TM x a) ; auto.
      - intros. subst. auto.
    }
    set (NNP_Dec P H).
    destruct (image_defined_Dec_r d).
    destruct H0.
    exists x.
    split ; auto.
    intros.
    apply H0.
    simpl. reflexivity.
  Qed.

  Theorem partial_functional_TMr : partial_functional Req TMr.
  Proof.
    hnf ; intros.
    destruct H , H0.
    apply Dec_R_eq ; auto.
    intros. specialize (H j). specialize (H0 j).
    split ; intros.
    + assert (m = Nat.b2n (TM j a)). { apply (partial_functional_Dec_R b1 j) ; auto. }
      subst. auto.
    + assert (m = Nat.b2n (TM j a)). { apply (partial_functional_Dec_R b2 j) ; auto. }
      subst. auto.
  Qed.

  Definition TM'r : nat -> R.
    intros n.
    pose proof (image_Defined_TMr n).
    apply Rsinglefun.
    exists (TMr n).
    split ; intros.
    - apply (partial_functional_TMr n) ; auto.
    - split ; auto.
      hnf. intros. hnf in H0. rewrite H0. reflexivity.
  Defined.

  Theorem TMr_get : forall n : nat , TMr n (TM'r n).
  Proof.
    intros.
    apply (Rsinglefun_correct (TMr n)).
  Qed.

  Theorem TM'r_pro : forall (n m: nat), Dec_R (TM'r n) m (Nat.b2n(TM m n)).
  Proof.
    intros.
    pose proof TMr_get n.
    destruct H. auto.
  Qed.

  Theorem In_Search_TM'r : forall n : nat , In_Search (TM'r n).
  Proof.
    intros.
    pose proof TMr_get n.
    destruct H. auto.
  Qed.

  Theorem Ex_limit_of_TM'r : exists r : R , Un_cv TM'r r.
  Proof.
    apply mono_up_upper_bound_seq_has_limit.
    - split ; hnf ; intros.
      + repeat split ; hnf ; intros ; subst; try (rewrite H0 in * ; auto).
        exists (TM'r a). auto with real.
      + pose proof In_Search_TM'r. subst.
        apply Dec_R_ge .
        rewrite H. auto.
        rewrite H0 . auto. intros.
        rewrite H , H0 in *.
        pose proof TM'r_pro n n0.
        pose proof TM'r_pro n1 n0.
        assert (m1 = Nat.b2n (TM n0 n)). { apply (partial_functional_Dec_R (TM'r n) n0); auto. }
        assert (m2 = Nat.b2n (TM n0 n1)). { apply (partial_functional_Dec_R (TM'r n1) n0); auto. }
        subst. clear H H0 H3 H4.
        destruct (TM n0 n1) eqn : En.
        * assert (TM n0 n = true). { apply (Turing_mono n0 n1 n) ; auto. }
          rewrite H. omega.
        * destruct (TM n0 n) ; simpl ; omega.
    - exists (IQR (10%nat)).
      hnf. intros.
      subst. destruct (In_Search_TM'r n).
      rewrite H.
      auto with real.
  Qed.

  Definition limitTM'r : R.
    apply Rsinglefun.
    exists (Un_cv TM'r).
    split ; intros.
    - unfold Un_cv in *.
      apply (Un_cv_inject (fun (n : nat) (r : R) => r == TM'r n)) ; auto.
    - split .
      + apply Ex_limit_of_TM'r.
      + hnf. intros. rewrite H. reflexivity.
  Defined.

  Theorem limit_of_TM'r : Un_cv TM'r limitTM'r.
  Proof.
    apply (Rsinglefun_correct (Un_cv TM'r)).
  Qed.

  Theorem Sup_of_TM'r : forall n : nat , limitTM'r >= TM'r n.
  Proof.
    intro.
    set (fun (n : nat)(r : R) => r == TM'r n).
    assert (mono_up P).
    { subst P.
      split ; hnf ; intros.
      + repeat split ; hnf ; intros ; subst.
        * exists (TM'r a). auto with real.
        * rewrite H , H0. auto with real.
        * rewrite H0 in *. auto .
        * rewrite H0 in *. auto.
      + pose proof In_Search_TM'r. subst.
        apply Dec_R_ge ; try (rewrite H ; auto); try (rewrite H0 ; auto).
        intros.
        rewrite H , H0 in *.
        pose proof TM'r_pro n0 n2.
        pose proof TM'r_pro n1 n2.
        assert (m1 = Nat.b2n (TM n2 n0)). { apply (partial_functional_Dec_R (TM'r n0) n2); auto. }
        assert (m2 = Nat.b2n (TM n2 n1)). { apply (partial_functional_Dec_R (TM'r n1) n2); auto. }
        subst. clear H H0 H3 H4.
        destruct (TM n2 n1) eqn : En.
        * assert (TM n2 n0 = true). { apply (Turing_mono n2 n1 n0) ; auto. }
          rewrite H. omega.
        * destruct (TM n2 n0) ; simpl ; omega.
    }
    assert (exists r : R , upper_bound P r).
    { subst P. exists (IQR (10%nat)).
      hnf. intros.
      subst. destruct (In_Search_TM'r n0). rewrite H0. auto with real.
    }
    pose proof limit_of_TM'r.
    pose proof mono_up_limit_sup P H H0 limitTM'r H1.
    destruct H2.
    hnf in H3.
    subst P. simpl in H3.
    apply Rle_ge. apply (H3 n). auto with real.
  Qed.

  Theorem TMR_proper0 : forall (n:nat) (r:R) , TMR n r -> forall (j : nat), (Dec_R r j 1 -> TM n j = true) /\ (Dec_R r j 0 -> TM n j = false).
  Proof.
    intros.
    destruct H.
    destruct (TM n j) eqn : H1; split ; auto ; intros ; pose proof H j ;
    rewrite H1 in H3 ;  simpl in * ;
    assert (1 = 0)%nat ;  try (apply (partial_functional_Dec_R r j) ; auto ) ;
    inversion H4.
  Qed.

  Theorem TMR_proper1 : forall (n : nat) (r : R), TMR n r -> (forall (j k : nat), (j <= k)%nat -> (Dec_R r j 1) -> (Dec_R r k 1)).
  Proof.
    intros.
    pose proof H.
    destruct H.
    pose proof H k.
    assert (H' : TM n j = true).
    { apply (TMR_proper0 n r H2) ; auto. }
    assert (H'' : TM n k = true).
    { apply Turing_mono with j ; auto. }
    rewrite H'' in H4. apply H4.
  Qed.

  Theorem TMR_proper1' : forall (n : nat) (r : R), TMR n r -> (forall (j k : nat), (j <= k)%nat -> (Dec_R r k 0) -> (Dec_R r j 0)).
  Proof.
    intros.
    pose proof H.
    destruct H.
    pose proof H j.
     assert (H' : TM n k = false).
    { apply (TMR_proper0 n r H2) ; auto. }
    assert (H'' : TM n j = false).
    { apply Turing_mono' with k ; auto. }
    rewrite H'' in H4. apply H4.
  Qed.

  Theorem diffR_diffTMR : forall (n1 n2 : nat) (r1 r2 : R) , TMR n1 r1 -> TMR n2 r2 -> (~ r1 == r2 <-> n1 <> n2).
  Proof.
    intros.
    pose proof injective_TMR.
    pose proof partial_functional_TMR.
    hnf in *.
    unfold not.
    split.
    - intros.
      subst. apply H3.
      apply (H2 n2 r1 r2) ; auto.
    - intros. apply H3. apply (H1 n1 n2) in H0; auto with real.
      rewrite <- H4. apply H.
  Qed.

  Theorem TM'r_pro0 : forall (n m : nat), Dec_R (TM'r n) m 1 <-> TM m n = true.
  Proof.
    intros.
    pose proof TM'r_pro n m.
    unfold not in *.
    split ; intros.
    - apply Nat.b2n_inj. simpl.
      apply (partial_functional_Dec_R (TM'r n) m) ; auto.
    - rewrite H0 in H; auto.
  Qed.

  Theorem TM'r_pro0' : forall (n m : nat), Dec_R (TM'r n) m 0 <-> TM m n = false.
  Proof.
    intros.
    pose proof TM'r_pro n m.
    unfold not in *.
    split ; intros.
    - apply Nat.b2n_inj. simpl.
      apply (partial_functional_Dec_R (TM'r n) m) ; auto.
    - rewrite H0 in H; auto.
  Qed.

  Theorem TM'r_InDecR : forall n : nat , InDecR (TM'r n).
  Proof.
    intros. intro.
    destruct (TM n0 n) eqn : En.
    - right. apply TM'r_pro0. auto.
    - left. apply TM'r_pro0'. auto.
  Qed.

  Theorem TM'r_pro1 : forall (n m : nat) , Dec_R (TM'r n) m 1 -> (forall (r : nat) , (r >= n)%nat -> Dec_R (TM'r r) m 1).
  Proof.
    intros.
    apply TM'r_pro0 in H.
    apply TM'r_pro0.
    pose proof Turing_mono m n r.
    apply H1 ; auto.
  Qed.

  Theorem TM'r_pro1' : forall (n m : nat) , Dec_R (TM'r n) m 0 -> (forall (r : nat) , (r <= n)%nat -> Dec_R (TM'r r) m 0).
  Proof.
    intros.
    apply TM'r_pro0' in H.
    apply TM'r_pro0'.
    pose proof Turing_mono' m n r.
    apply H1 ; auto.
  Qed.

  Theorem InSearch_limitTM'r : In_Search limitTM'r.
  Proof.
    set (fun (n : nat)(r : R) => r == TM'r n).
    assert (mono_up P).
    { subst P.
      split ; hnf ; intros.
      + repeat split ; hnf ; intros ; subst.
        * exists (TM'r a). auto with real.
        * rewrite H , H0. auto with real.
        * rewrite H0 in *. auto .
        * rewrite H0 in *. auto.
      + pose proof In_Search_TM'r. subst.
        apply Dec_R_ge ; try (rewrite H ; auto); try (rewrite H0 ; auto).
        intros.
        rewrite H , H0 in *.
        pose proof TM'r_pro n n0.
        pose proof TM'r_pro n1 n0.
        assert (m1 = Nat.b2n (TM n0 n)). { apply (partial_functional_Dec_R (TM'r n) n0); auto. }
        assert (m2 = Nat.b2n (TM n0 n1)). { apply (partial_functional_Dec_R (TM'r n1) n0); auto. }
        subst. clear H H0 H3 H4.
        destruct (TM n0 n1) eqn : En.
        * assert (TM n0 n = true). { apply (Turing_mono n0 n1 n) ; auto. }
          rewrite H. omega.
        * destruct (TM n0 n) ; simpl ; omega.
    }
    assert (exists r : R , upper_bound P r).
    { subst P. exists (IQR (10%nat)).
      hnf. intros.
      subst. destruct (In_Search_TM'r n).
      rewrite H0. auto with real.
    }
    pose proof limit_of_TM'r.
    pose proof mono_up_limit_sup P H H0 limitTM'r H1.
    destruct H2. clear H0 H1 H.
    split .
    - hnf in *. subst P.
      apply Rle_ge.
      apply Rle_trans with (TM'r O).
      + destruct (In_Search_TM'r O) ; auto.
        auto with real.
      + apply (H3 O). auto with real.
    - apply Rle_lt_trans with 2.
      + apply Rge_le. apply H2.
        hnf. intros.
        subst P. simpl in *.
        subst. left.
        apply Dec_R_lt. rewrite H.
        apply In_Search_TM'r.
        * split. left. apply Rlt_gt. auto with real.
          apply R2_Rlt_R10.
        * exists O.
          split ; intros ; try (omega).
          pose proof Two_Dec.
          assert (m2 = 2)%nat. { apply (partial_functional_Dec_R 2 0) ; auto. }
          pose proof TM'r_InDecR n O.
          assert (m1 = 0 \/ m1 = 1)%nat.
          { destruct H6.
            - left. apply (partial_functional_Dec_R (TM'r n) O) ; rewrite H in * ; auto.
            - right. apply (partial_functional_Dec_R (TM'r n) O) ; rewrite H in * ; auto.
          }
          omega.
      + apply R2_Rlt_R10.
  Qed.

  Theorem limitTM'r_pro0 : InDecR limitTM'r.
  Proof.
    hnf.
    apply NNPP.
    intro.
    apply not_all_ex_not in H.
    destruct H.
    apply not_or_and in H.
    destruct H.
    destruct (image_Defined_Dec_R limitTM'r x). apply InSearch_limitTM'r.
    assert (x0 <> 0 /\ x0 <> 1)%nat. { split ; intro ; subst ; auto. }
    assert (x0 > 1)%nat. { omega. }
    clear H2 H H0.
    pose proof limit_of_TM'r.
    pose proof TM'r_InDecR.
    destruct H.
    assert (~ (10 ^ S x)%nat == 0)%Q.
    { intro. apply (Qlt_irrefl 0%Q). rewrite <- H4 at 2. rewrite <- INQ_Qeq_0.
      apply INQ_lt. apply Max_powan_0. omega.
    }
    assert (IQR 1 / IQR (10 ^ S x)%nat > R0).
    { unfold Rdiv. rewrite IQR_inv ; auto. rewrite <- mult_IQR.
      rewrite <- IQR_R0. apply IQR_lt. rewrite Qmult_1_l.
      apply Qinv_lt_0_compat.
      rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
    }
    specialize (H2 _ H5). destruct H2.
    assert (max (S x) x1 >= x1)%nat. { apply Nat.le_max_r. }
    assert (TM'r (max (S x) x1) == TM'r (max (S x) x1)). { auto with real. }
    specialize (H2 _ _ H6 H7).
    clear H7.
    specialize  (H0 (max (S x) x1) x).
    pose proof Sup_of_TM'r (max (S x) x1).
    remember (TM'r (max (S x) x1)) as r2.
    apply Rle_neg_eqb in H7.
    rewrite Rabs_neg in H2 ; auto.
    rewrite Ropp_minus_distr' in H2.
    apply Rle_neg_eqb in H7.
    apply Rge_le in H7.
    assert (IQR (10 ^ x)%nat > R0).
    { rewrite <- IQR_R0. apply IQR_lt. rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega. }
    apply Rmult_le_r with (r3 := IQR (10 ^ x)%nat) in H7 ; auto.
    apply Rmult_lt_r with (r3 := IQR (10 ^ x)%nat) in H2 ; auto.
    rewrite Rmult_comm in H2.
    rewrite Rmult_minus_distr_l in H2.
    apply Rlt_Rminus_Rplus in H2.
    assert (IQR 1 / IQR (10 ^ S x)%nat * IQR (10 ^ x)%nat == IQR 1 / IQR (10)%nat ).
    {
      unfold Rdiv.
      rewrite IQR_R1. rewrite !Rmult_1_l.
      assert (IQR (10 ^ S x)%nat == IQR (10 ^ x)%nat * IQR (10)%nat).
      { rewrite !INQ_IQR_INR. rewrite <- mult_INR.
        rewrite Nat.pow_succ_r'. rewrite mult_comm. auto with real.
      }
      rewrite H9.
      rewrite Rinv_mult_distr. rewrite Rmult_comm.
      rewrite <- Rmult_assoc.
      rewrite Rinv_r ; auto with real.
      auto with real.
      rewrite INQ_IQR_INR. rewrite <- INR_R0. auto with real.
    }
    rewrite H9 in *.
    destruct H0 , H0 , H0 , H0 , H1 , H1 , H1.
    - assert (x2 <= x3)%nat.
      { apply NNPP. intro.
        assert (x3 + 1<= x2)%nat. { omega. }
        apply INQ_le in H15. apply IQR_le in H15.
        apply (Rlt_irrefl (IQR x2)).
        apply Rle_lt_trans with (r2 * IQR (10 ^ x)%nat) ; auto.
        apply Rle_lt_trans with (limitTM'r * IQR (10 ^ x)%nat) ; auto.
        apply Rlt_le_trans with (IQR (x3 + 1)%nat) ; auto.
      }
      assert (x0 < 10)%nat. { rewrite H12. apply Nat.mod_upper_bound. auto. }
      symmetry in H12 , H10.
      apply mod_exists in H12 ; auto. apply mod_exists in H10 ; try (omega).
      destruct H12 , H10.
      assert (x3 >= x2 + 1 + 1)%nat. { omega. }
      rewrite Rmult_comm in H2.
      pose proof Rle_lt_trans _ _ _ H1 H2.
      apply Rplus_lt_compat_r with (r := IQR 1 / IQR 10%nat) in H11.
      rewrite Rmult_comm in H11.
      pose proof Rlt_trans _ _ _ H17 H11.
      apply (Rlt_irrefl (IQR (x2 + 1)%nat + IQR 1%nat)).
      apply INQ_le in H16.
      rewrite <- INQ_plus in H16.
      apply IQR_le in H16.
      rewrite plus_IQR in H16.
      apply Rle_lt_trans with (IQR x3) ; auto.
      apply Rlt_trans with (IQR (x2 + 1)%nat + IQR 1 / IQR 10%nat) ; auto.
      apply Rplus_lt_compat_l. unfold Rdiv.
      rewrite IQR_R1. rewrite Rmult_1_l.
      rewrite IQR_inv ; auto.
      apply IQR_lt.
      rewrite INQ_Qeq_1.
      apply Qlt_shift_inv_r.
      rewrite <- INQ_Qeq_0. apply INQ_lt. omega.
      rewrite Qmult_1_l. rewrite <- INQ_Qeq_1. apply INQ_lt. omega.
      intro. rewrite <- INQ_Qeq_0 in H19. apply Qeq_INQ_eq in H19. omega.
    - assert (x2 <= x3)%nat.
      { apply NNPP. intro.
        assert (x3 + 1<= x2)%nat. { omega. }
        apply INQ_le in H15. apply IQR_le in H15.
        apply (Rlt_irrefl (IQR x2)).
        apply Rle_lt_trans with (r2 * IQR (10 ^ x)%nat) ; auto.
        apply Rle_lt_trans with (limitTM'r * IQR (10 ^ x)%nat) ; auto.
        apply Rlt_le_trans with (IQR (x3 + 1)%nat) ; auto.
      }
      assert (x0 < 10)%nat. { rewrite H12. apply Nat.mod_upper_bound. auto. }
      symmetry in H12 , H10.
      apply mod_exists in H12 ; auto. apply mod_exists in H10 ; try (omega).
      destruct H12 , H10.
      assert (x3  >= x2 + 1)%nat. { omega. }
      assert (Same_Ipart (r2 * IQR (10 ^ x)%nat) (r2 * IQR (10 ^ x)%nat + IQR 1 / IQR 10%nat)).
      { rewrite <- H9. rewrite <- Rmult_plus_distr_r.
        rewrite IQR_R1. rewrite <- INR_R1. rewrite <- INQ_IQR_INR.
        pose proof Same_Ipart_pow10n.
        assert (IQR 1%nat / IQR (10 ^ S x)%nat == IQR (1%nat / (10 ^ S x)%nat)).
        { unfold Rdiv. rewrite IQR_inv ; auto. rewrite <- mult_IQR.
          apply IQR_eq. reflexivity.
        }
        rewrite H18.
        apply H17.
        subst r2. apply In_Search_TM'r.
        apply InDecR_all_n. subst r2.
        apply TM'r_InDecR.
      }
      destruct H17 , H17 , H18 , H19.
      assert (x6 = x2)%nat. { apply (Ipart_unique (r2 * IQR (10 ^ x)%nat)) ; split; auto. }
      subst x6.
      apply (Rlt_irrefl (IQR (x2 + 1)%nat)).
      apply Rlt_trans with (r2 * IQR (10 ^ x)%nat + IQR 1 / IQR 10%nat) ; auto.
      apply Rle_lt_trans with (limitTM'r * IQR (10 ^ x)%nat) ; auto.
      apply Rle_trans with (IQR x3) ; auto.
      apply IQR_le. apply INQ_le. omega.
      rewrite Rmult_comm.
      rewrite (Rmult_comm r2 (IQR (10 ^ x)%nat)). auto.
  Qed.

  Theorem limitTM'r_pro : forall (n : nat) , Dec_R limitTM'r n 1 <-> exists j : nat , TM n j = true.
  Proof.
    intros.
    pose proof limit_of_TM'r.
    destruct H.
    split ; intros.
    - assert (~ INQ (10 ^ S n) == 0)%Q.
      { intro. apply (Qlt_irrefl 0%Q). rewrite <- H2 at 2.
        rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
      }
      set (eps := (IQR 1 / IQR (10 ^ S n)%nat)).
      assert (eps > R0).
      { rewrite <- IQR_R0. subst eps. unfold Rdiv.
        rewrite IQR_inv ; auto. rewrite <- mult_IQR. apply IQR_lt.
        rewrite Qmult_1_l. apply Qinv_lt_0_compat.
        rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
      }
      specialize (H0 _ H3). destruct H0.
      assert (x >= x)%nat. { omega. }
      assert (TM'r x == TM'r x). { auto with real. }
      specialize (H0 _ _ H4 H5).
      exists x.
      apply TM'r_pro0. clear H4 H5.
      assert (Same_Ipart_n (TM'r x) (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 H4.
          apply Qeq_INQ_eq in H4. apply lt_irrefl with O.
          rewrite <- H4 at 2. apply Max_powan_0. omega.
        }
        pose proof Same_Ipart_pow10n (TM'r x) (S n - 1).
        assert (In_Search (TM'r x)). { apply In_Search_TM'r. }
        assert (InDecR_n (TM'r x) (S (S n - 1))). { apply InDecR_all_n. apply TM'r_InDecR. }
        specialize (H5 H6 H7). clear H6 H7.
        hnf in *.
        destruct H5. exists x0. rewrite <- H4 in *.
        rewrite <- !INQ_IQR_INR in *. auto with real.
      }
      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 H5.
          apply Qeq_INQ_eq in H5. apply lt_irrefl with O.
          rewrite <- H5 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 (H6 H7 H8). clear H7 H8.
        hnf in *.
        destruct H6. exists x0. rewrite <- H5 in *.
        rewrite <- !INQ_IQR_INR in *. auto with real.
      }
      pose proof (Dec_R_eps_same (TM'r x) limitTM'r _ H0 H4 H5).
      apply H6 ; auto.
    - destruct H1.
      assert (~ INQ (10 ^ S (max x n)) == 0)%Q.
      { intro. apply (Qlt_irrefl 0%Q). rewrite <- H2 at 2.
        rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
      }
      set (eps := (IQR 1 / IQR (10 ^ S (max x n))%nat)).
      assert (eps > R0).
      { rewrite <- IQR_R0. subst eps. unfold Rdiv.
        rewrite IQR_inv ; auto. rewrite <- mult_IQR. apply IQR_lt.
        rewrite Qmult_1_l. apply Qinv_lt_0_compat.
        rewrite <- INQ_Qeq_0. apply INQ_lt. apply Max_powan_0. omega.
      }
      specialize (H0 _ H3). destruct H0.
      assert (max x0 x >= x0)%nat. { apply Nat.le_max_l. }
      assert (TM'r (max x0 x) == TM'r (max x0 x)). { auto with real. }
      specialize (H0 _ _ H4 H5). clear H4 H5 H2.
      assert (max x0 x >= x)%nat. { apply Nat.le_max_r. }
      assert (Same_Ipart_n (TM'r (max x0 x)) (S (max x n) - 1)).
      {
        assert (IQR 1%nat / IQR (10 ^ S (S (max x n) - 1))%nat == IQR (1%nat / (10 ^ S (S (max x 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 H4.
          apply Qeq_INQ_eq in H4. apply lt_irrefl with O.
          rewrite <- H4 at 2. apply Max_powan_0. omega.
        }
        pose proof Same_Ipart_pow10n (TM'r (max x0 x)) (S (max x n) - 1).
        assert (In_Search (TM'r (max x0 x))). { apply In_Search_TM'r. }
        assert (InDecR_n (TM'r (max x0 x)) (S (S (max x n) - 1))). { apply InDecR_all_n. apply TM'r_InDecR. }
        specialize (H5 H6 H7). clear H6 H7.
        hnf in *.
        destruct H5. exists x1. rewrite <- H4 in *.
        rewrite <- !INQ_IQR_INR in *. auto with real.
      }
      assert (Same_Ipart_n (limitTM'r) (S (max x n) - 1)).
      {
        assert (IQR 1%nat / IQR (10 ^ S (S (max x n) - 1))%nat == IQR (1%nat / (10 ^ S (S (max x 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 H5.
          apply Qeq_INQ_eq in H5. apply lt_irrefl with O.
          rewrite <- H5 at 2. apply Max_powan_0. omega.
        }
        pose proof Same_Ipart_pow10n limitTM'r (S (max x n) - 1).
        assert (In_Search limitTM'r). { apply InSearch_limitTM'r. }
        assert (InDecR_n limitTM'r (S (S (max x n) - 1))). { apply InDecR_all_n. apply limitTM'r_pro0. }
        specialize (H6 H7 H8). clear H7 H8.
        hnf in *.
        destruct H6. exists x1. rewrite <- H5 in *.
        rewrite <- !INQ_IQR_INR in *. auto with real.
      }
      pose proof (Dec_R_eps_same (TM'r (max x0 x)) limitTM'r _ H0 H4 H5).
      apply H6 ; auto.
      unfold lt. apply le_n_S. apply Nat.le_max_r.
      rewrite TM'r_pro0.
      apply (Turing_mono _ x (max x0 x)) ; auto.
  Qed.

  Theorem limitTM'r_pro' : forall (n : nat) , Dec_R limitTM'r n 0 <-> forall j : nat , TM n j = false.
  Proof.
    intros.
    pose proof limitTM'r_pro n.
    unfold not in *.
    split ; intros.
    - destruct (TM n j) eqn:En ; auto.
      assert (exists j : nat , TM n j = true). { exists j. auto. }
      apply H in H1.
      apply Nat.b2n_inj. simpl.
      apply (partial_functional_Dec_R limitTM'r n) ; auto.
    - destruct (limitTM'r_pro0 n ) ; auto.
      apply H in H1.
      destruct H1.
      exfalso. rewrite H0 in H1. inversion H1.
  Qed.

  Theorem limitTM'r_pro1 : (forall (n : nat) , {Dec_R limitTM'r n 0} + {Dec_R limitTM'r n 1}) -> Halting.
  Proof.
    unfold Halting.
    intros.
    pose proof H i.
    destruct H0.
    - rewrite (limitTM'r_pro' i) in d. auto.
    - rewrite (limitTM'r_pro i) in d. auto.
  Qed.

End TMR_Set.


Class RawFunctor (F : Type -> Type) :=
  MkRawFunctor { _fmap : forall A B, (A -> B) -> (F A -> F B)
               }.

Definition fmap {F : Type -> Type} `{RawFunctor F} {A B : Type} : (A -> B) -> (F A -> F B) :=
  _fmap _ _.

Arguments MkRawFunctor {_}.

Class RawApplicative (F : Type -> Type) `{RawFunctor F} :=
  MkRawApplicative { _pure       : forall A, A -> F A
                   ; _app        : forall A B, F (A -> B) -> (F A -> F B)
                   }.

Definition pure {F : Type -> Type} `{RawApplicative F} {A : Type} : A -> F A :=
  _pure _.

Definition app {F : Type -> Type} `{RawApplicative F} {A B : Type} : F (A -> B) -> (F A -> F B) :=
  _app _ _.

Arguments MkRawApplicative {_} {_}.

Class RawAlternative (F : Type -> Type) `{RawApplicative F} :=
  MkRawAlternative { _fail : forall A, F A
                   ; _alt  : forall A, F A -> F A -> F A
                   }.

Definition fail {F : Type -> Type} `{RawAlternative F} {A : Type} : F A :=
  _fail _.

Definition alt {F : Type -> Type} `{RawAlternative F} {A : Type} : F A -> F A -> F A :=
  _alt _.

Definition fromOption {F : Type -> Type} `{RawAlternative F} {A : Type} (v : option A) : F A :=
match v with
 | None   => fail
 | Some a => pure a
end.

Arguments MkRawAlternative {_} {_} {_}.

Class RawMonad (F : Type -> Type) `{RawApplicative F} :=
  MkRawMonad { _bind : forall A B, F A -> (A -> F B) -> F B }.

Definition bind {F : Type -> Type} `{RawMonad F} {A B : Type} :
  F A -> (A -> F B) -> F B := _bind _ _.

Fixpoint mapM {M : Type -> Type} `{RawMonad M} {A B : Type}
 (f : A -> M B) (xs : list A) : M (list B) :=
match xs with
  | nil        => pure nil
  | cons x xs' => bind (f x) (fun fx => fmap (cons fx) (mapM f xs'))
end.

Arguments MkRawMonad {_} {_} {_}.

Class RawMonadRun (F : Type -> Type) `{RawMonad F} :=
  MkRawMonadRun { _runMonad : forall A, F A -> list A }.

Definition runMonad {F : Type -> Type} `{RawMonadRun F} {A : Type} : F A -> list A := _runMonad _.

Arguments MkRawMonadRun {_} {_} {_} {_}.

Require Import Coq.Lists.List.

Instance listRawFunctor : RawFunctor list :=
  MkRawFunctor map.

Instance listRawApplicative : RawApplicative list :=
  MkRawApplicative (fun _ x => cons x nil) (fun _ _ fs xs => flat_map (fun f => map f xs) fs).

Instance listRawAlternative : RawAlternative list :=
  MkRawAlternative (@nil) (fun _ xs ys => xs ++ ys).

Instance listRawMonad : RawMonad list :=
  MkRawMonad (fun _ _ xs f => flat_map f xs).

Instance listRawMonadRun : RawMonadRun list :=
  MkRawMonadRun (fun _ x => x).

Instance optionRawFunctor : RawFunctor option :=
  MkRawFunctor option_map.

Instance optionRawApplicative : RawApplicative option :=
  MkRawApplicative (fun _ => Some) (fun A B => option_rect _ (option_map (B := B)) (fun _ => None)).

Instance optionRawAlternative : RawAlternative option :=
  MkRawAlternative (@None) (fun _ => option_rect _ (fun x _ => Some x) (fun x => x)).

Instance optionRawMonad : RawMonad option :=
  MkRawMonad (fun _ _ xs f => option_rect _ f None xs).

Instance optionRawMonadRun : RawMonadRun option :=
  MkRawMonadRun (fun _ => option_rect _ (fun x => cons x nil) nil).


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2004-12-22

cap of undefined symbols and aliens of defined symbols
*)

Set Implicit Arguments.

From Coq Require Import Max Sumbool.
From CoLoR Require Import LogicUtil ACalls ATrs VecUtil ListUtil NatUtil EqUtil.

Section S.

Variable Sig : Signature.

Notation term := (term Sig). Notation terms := (vector term).

(***********************************************************************)
(** we first defined a generic cap as a triple (k,f,v) where
- k is the number of aliens
- f is a function which, given a vector v of k terms, returns the cap
with the ith alien replaced by the ith term of v
- v is the vector of the k aliens

the generic cap of a term is computed by the function capa below
its property is: if capa(t) = (k,f,v) then f(v)=t

f acts as an abstract context with k holes *)

Local Open Scope type_scope.
Definition Cap := {k : nat & (terms k -> term) * terms k }.

Notation Caps := (vector Cap).

Definition mkCap := @existT nat (fun k => ((terms k -> term) * terms k)).

Definition fcap (c : Cap) := fst (projT2 c).
Definition aliens (c : Cap) := snd (projT2 c).
Definition fcap_aliens (c : Cap) := fcap c (aliens c).

(* total number of aliens of a vector of caps *)

Local Open Scope nat_scope.

Fixpoint sum n (cs : Caps n) : nat :=
  match cs with
    | Vnil => 0
    | Vcons c cs' => projT1 c + sum cs'
  end.

(* concatenation of all the aliens of a vector of caps *)

Fixpoint conc n (cs : Caps n) : terms (sum cs) :=
  match cs as cs return terms (sum cs) with
    | Vnil => Vnil
    | Vcons c cs' => Vapp (aliens c) (conc cs')
  end.

Lemma in_conc : forall u n (cs : Caps n), Vin u (conc cs) ->
  exists c, Vin c cs /\ Vin u (aliens c).

Proof.
induction cs; simpl; intros. contr.
assert (Vin u (aliens h) \/ Vin u (conc cs)). apply Vin_app. hyp.
destruct H0. exists h. auto.
assert (exists c, Vin c cs /\ Vin u (aliens c)). apply IHcs. hyp.
destruct H1 as [c]. exists c. intuition.
Qed.

Arguments in_conc [u n cs] _.

(* given a vector cs of caps and a vector ts of (sum cs) terms, this
function breaks ts in vectors of size the number of aliens of every
cap of cs, apply every fcap to the corresponding vector, and
concatenate all the results *)

Fixpoint Vmap_sum n (cs : Caps n) : terms (sum cs) -> terms n :=
  match cs as cs in vector _ n return terms (sum cs) -> terms n with
    | Vnil => fun _ => Vnil
    | Vcons c cs' => fun ts =>
      let (hd,tl) := Vbreak ts in Vcons (fcap c hd) (Vmap_sum cs' tl)
  end.

(***********************************************************************)
(** function computing the generic cap of a term *)

Notation rule := (@rule Sig). Notation rules := (list rule).

Variable R : rules.

Fixpoint capa (t : term) : Cap :=
  match t with
    | Var x => mkCap (fun _ => t, Vnil)
    | Fun f ts =>
      if defined f R then
	mkCap (fun v => Vnth v (lt_O_Sn 0), Vcons t Vnil)
      else
	let cs := Vmap capa ts in
	mkCap (fun v => Fun f (Vmap_sum cs v), conc cs)
  end.

(* number of aliens of a term *)

Definition nb_aliens t := projT1 (capa t).

(* proof of the capa property: if c = capa t then fcap c (aliens c) = t *)

Lemma Vmap_sum_conc_forall : forall n (ts : terms n),
  (Vforall (fun t => fcap_aliens (capa t) = t) ts)
  -> Vmap_sum (Vmap capa ts) (conc (Vmap capa ts)) = ts.

Proof.
induction ts; simpl; intros. refl. destruct H. rewrite Vbreak_app.
unfold fcap_aliens in H. rewrite H. apply Vtail_eq. apply IHts. hyp.
Qed.

Lemma sub_capa : forall t, fcap_aliens (capa t) = t.

Proof.
intro. pattern t. apply term_ind_forall; intros. refl.
unfold fcap_aliens, fcap, aliens. simpl. case (defined f R); simpl. refl.
apply args_eq. change (Vmap_sum (Vmap capa v) (conc (Vmap capa v)) = v).
rewrite Vmap_sum_conc_forall. refl. hyp.
Qed.

Lemma Vmap_sum_conc : forall n (ts : terms n),
  Vmap_sum (Vmap capa ts) (conc (Vmap capa ts)) = ts.

Proof.
intros. apply Vmap_sum_conc_forall. apply Vforall_intro. intros.
apply sub_capa.
Qed.

(***********************************************************************)
(** aliens are subterms *)

Lemma in_aliens_subterm : forall u t,
  Vin u (aliens (capa t)) -> subterm_eq u t.

Proof.
intros u t. pattern t. apply term_ind_forall.
simpl. intros. contr.
intros f ts H. simpl. case (defined f R).
simpl. intro. destruct H0. subst u. refl. contr.
change (Vin u (conc (Vmap capa ts)) -> subterm_eq u (Fun f ts)). intro.
assert (exists c, Vin c (Vmap capa ts) /\ Vin u (aliens c)). apply in_conc.
hyp. destruct H1 as [c]. destruct H1.
assert (exists t, Vin t ts /\ c = capa t). apply Vin_map. hyp.
destruct H3 as [t']. destruct H3. subst c.
assert (Vin u (aliens (capa t')) -> subterm_eq u t').
pattern t'. eapply Vforall_in with (n := arity f). apply H. hyp.
apply subterm_strict. eapply subterm_trans_eq1 with (u := t').
apply H4. hyp. apply subterm_fun. hyp.
Qed.

(***********************************************************************)
(** concrete cap: it is obtained by applying fcap to a sequence of fresh
variables greater than the biggest variable in t *)

Notation maxvar := (@maxvar Sig). Notation fresh := (@fresh Sig).

Definition fresh_for (t : term) := fresh (S (maxvar t)).

Definition cap t :=
  match capa t with
    | @existT _ _ n (f,_) => f (fresh_for t n)
  end.

Lemma cap_eq : forall t,
  cap t = fcap (capa t) (fresh (S (maxvar t)) (nb_aliens t)).

Proof.
intro. unfold cap, fcap, fresh_for, nb_aliens. destruct (capa t). destruct p.
refl.
Qed.

(***********************************************************************)
(** variables of the cap *)

Lemma vars_fcap_fresh_inf : forall x t m, maxvar t <= m
  -> In x (vars (fcap (capa t) (fresh (S m) (nb_aliens t))))
  -> x <= m -> In x (vars t).

Proof.
intro. set (Q := fun n (ts : terms n) =>
  forall m, maxvars ts <= m ->
  In x (vars_vec (Vmap_sum (Vmap capa ts) (fresh (S m) (sum (Vmap capa ts)))))
  -> x <= m -> In x (vars_vec ts)).
intro. pattern t. apply term_ind with (Q := Q); clear t; intros.
(* var *)
hyp.
(* fun *)
rewrite vars_fun. unfold nb_aliens in H1. simpl in H1.
destruct (defined f R); simpl in H1. destruct H1.
absurd (x<=m); lia. contr. apply H with (m := m); hyp.
(* nil *)
unfold Q. simpl. intros. contr.
(* cons *)
unfold Q. simpl. set (m := max (maxvar t) (maxvars v)).
intros m0 H1.
rewrite fresh_plus, Vbreak_app. simpl. intros. ded (in_app_or H2).
destruct H4.
(* head *)
apply in_appl. apply H with (m := m0).
eapply le_max_elim_l. unfold m in H1. rewrite maxvars_cons in H1. apply H1.
unfold nb_aliens. hyp. hyp.
(* tail *)
apply in_appr. unfold Q in H0. apply H0 with (m := m0 + projT1 (capa t)).
assert (maxvars v <= m0). eapply le_max_elim_r. unfold m in H1.
rewrite maxvars_cons in H1. apply H1. lia. hyp. lia.
Qed.

Lemma vars_cap_inf : forall x t,
  In x (vars (cap t)) -> x <= maxvar t -> In x (vars t).

Proof.
intros. apply vars_fcap_fresh_inf with (m := maxvar t). apply le_refl.
rewrite cap_eq in H. hyp. hyp.
Qed.

Lemma vars_cap_sup : forall x t,
  In x (vars (cap t)) -> x > maxvar t -> In x (vars t) -> False.

Proof.
intros x t. pattern t. apply term_ind_forall; clear t; simpl; intros.
intuition. change (In x (vars_vec v)) in H2.
change (x > maxvars v) in H1.
ded (in_vars_vec_elim H2). destruct H3 as [t]. destruct H3.
ded (vars_max H4). ded (maxvar_in _ _ H5 H3). lia.
Qed.

Lemma vars_fcap_fresh : forall x t m, maxvar t <= m
  -> In x (vars (fcap (capa t) (fresh (S m) (nb_aliens t))))
  -> x <= m + nb_aliens t.

Proof.
intro. set (Q := fun n (ts : terms n) =>
  forall m, maxvars ts <= m ->
  In x (vars_vec (Vmap_sum (Vmap capa ts) (fresh (S m) (sum (Vmap capa ts)))))
  -> x <= m + sum (Vmap capa ts)).
intro. pattern t. apply term_ind with (Q := Q); clear t.
(* var *)
simpl. intros. destruct H0. subst x0. lia. contr.
(* fun *)
intros f ts H m H0. unfold nb_aliens. simpl.
case (defined f R); simpl; intros. destruct H1. lia. contr.
apply H; hyp.
(* nil *)
unfold Q. simpl. intros. contr.
(* cons *)
intros. unfold Q. simpl. intros m H1. rewrite fresh_plus, Vbreak_app.
simpl. intro. ded (in_app_or H2). destruct H3.
assert (x <= m + projT1 (capa t)). apply H. eapply le_max_elim_l.
rewrite maxvars_cons in H1. apply H1. hyp. lia.
rewrite plus_assoc. apply H0. assert (maxvars v <= m).
eapply le_max_elim_r. rewrite maxvars_cons in H1. apply H1. lia. hyp.
Qed.

Lemma vars_cap : forall x t,
  In x (vars (cap t)) -> x <= maxvar t + nb_aliens t.

Proof.
intros. apply vars_fcap_fresh. apply le_refl. rewrite cap_eq in H. hyp.
Qed.

(***********************************************************************)
(** properties of the cap wrt calls *)

Notation calls := (calls R).
Definition vcalls := vcalls R.

Lemma calls_capa : forall t m,
  calls (fcap (capa t) (fresh m (nb_aliens t))) = nil.

Proof.
set (Q := fun n (ts : terms n) => forall m, vcalls (Vmap_sum (Vmap capa ts)
  (fresh m (sum (Vmap capa ts)))) = nil).
intro. pattern t. apply term_ind with (Q := Q); clear t; intros.
(* var *)
refl.
(* fun *)
unfold nb_aliens. simpl.
pattern (defined f R). apply bool_eq_ind; intros; simpl. refl.
rewrite H0. apply H.
(* nil *)
unfold Q. refl.
(* cons *)
unfold Q. simpl. intro. rewrite fresh_plus, Vbreak_app. simpl.
apply app_nil. apply H. apply H0.
Qed.

Lemma calls_cap t : calls (cap t) = nil.

Proof. rewrite cap_eq. apply calls_capa. Qed.

Lemma aliens_incl_calls : forall u t,
  Vin u (aliens (capa t)) -> In u (calls t).

Proof.
intros u t. pattern t. apply term_ind_forall; clear t. simpl. auto.
intros f ts H. rewrite calls_fun. simpl. case (defined f R); simpl.
intuition. unfold aliens. simpl. intro. ded (in_conc H0). do 2 destruct H1.
ded (Vin_map H1). do 2 destruct H3. subst x. ded (Vforall_in H H3).
eapply in_vcalls. apply H4. hyp. hyp.
Qed.

(***********************************************************************)
(** concrete alien substitution:
it gives t when applied to the concrete cap of t *)

Definition alien_sub t := fsub (maxvar t) (aliens (capa t)).

Lemma alien_sub_var : forall x, alien_sub (Var x) x = Var x.

Proof.
intro. unfold alien_sub, fsub. simpl. case (le_lt_dec x x). auto.
intro. absurd (x < x). apply lt_irrefl. hyp.
Qed.

Lemma app_fcap : forall m s, (forall x, x <= m -> s x = Var x)
  -> forall t, maxvar t <= m
  -> forall v, sub s (fcap (capa t) v) = fcap (capa t) (Vmap (sub s) v).

Proof.
intros until t. pattern t.
set (Q := fun n (ts : terms n) => maxvars ts <= m
  -> forall v, Vmap (sub s) (Vmap_sum (Vmap capa ts) v)
               = Vmap_sum (Vmap capa ts) (Vmap (sub s) v)).
apply term_ind with (Q := Q); clear t.
intros. unfold fcap. simpl. apply H. hyp.
intros f ts IH H0. simpl. unfold fcap.
case (defined f R); simpl; intros.
VSntac v. refl.
apply args_eq. apply IH. hyp.
unfold Q. auto.
intros. unfold Q. simpl. intros.
gen (Vbreak_eq_app v0). intro. rewrite H3, Vmap_app, !Vbreak_app. simpl.
rewrite maxvars_cons in H2. apply Vcons_eq_intro.
apply H0. eapply le_max_elim_l. apply H2.
apply H1. eapply le_max_elim_r. apply H2.
Qed.

Lemma Vmap_map_sum : forall m s, (forall x, x <= m -> s x = Var x)
  -> forall n (ts : terms n), maxvars ts <= m
  -> forall v, Vmap (sub s) (Vmap_sum (Vmap capa ts) v)
               = Vmap_sum (Vmap capa ts) (Vmap (sub s) v).

Proof.
induction ts; simpl; intros. refl.
gen (Vbreak_eq_app v). intro. rewrite H1, Vmap_app, !Vbreak_app. simpl.
rewrite maxvars_cons in H0. apply Vcons_eq_intro.
eapply app_fcap. apply H. eapply le_max_elim_l. apply H0.
apply IHts. eapply le_max_elim_r. apply H0.
Qed.

Lemma alien_sub_cap : forall t, sub (alien_sub t) (cap t) = t.

Proof.
intro. pattern t. apply term_ind_forall; intros.
(* var *)
simpl. apply alien_sub_var.
(* fun *)
unfold alien_sub, cap, fresh_for. set (m := maxvar (Fun f v)).
simpl. case (defined f R).
(* f defined *)
change (fsub m (Vcons (Fun f v) Vnil) (S m) = Fun f v).
apply fsub_cons. lia.
(* f undefined *)
set (cs := Vmap capa v).
change (let (n,p) := mkCap (fun ts => Fun f (Vmap_sum cs ts), conc cs) in
  let (f0,v0) := p in sub (fsub m v0) (f0 (fresh (S m) n)) = Fun f v).
set (s := mkCap (fun ts => Fun f (Vmap_sum cs ts), conc cs)).
assert (s = mkCap (fun ts => Fun f (Vmap_sum cs ts), conc cs)). refl.
destruct s. destruct p as [f0 v0]. injection H0. intros. subst x.
assert (v0 = conc cs).
apply (@inj_existT _ eq_nat_dec (fun x => terms x)). hyp.
assert (f0 = fun ts => Fun f (Vmap_sum cs ts)).
apply (@inj_existT _ eq_nat_dec (fun x => terms x -> term)). hyp.
subst f0. rewrite sub_fun. apply f_equal with (f := Fun f).
set (s := fsub m v0). set (v1 := fresh (S m) (sum cs)).
assert (Vmap (sub s) (Vmap_sum cs v1) = Vmap_sum cs (Vmap (sub s) v1)).
unfold cs. eapply Vmap_map_sum with (m := m).
unfold s. apply fsub_inf. apply le_refl. rewrite H4.
assert (Vmap (sub s) v1 = conc cs). unfold s, v1. rewrite H3, Vmap_fsub_fresh.
refl.
rewrite H5. unfold cs. apply Vmap_sum_conc.
Qed.

End S.

Arguments vars_cap_inf [Sig] _ [x t] _ _.
Arguments vars_cap_sup [Sig] _ [x t] _ _ _.
Arguments vars_cap [Sig] _ [x t] _.


Require Import Coq.ZArith.ZArith.
Require Import Coq.derive.Derive.
Require Import Coq.Lists.List.
Require Import Crypto.ArithmeticCPS.Core.
Require Import Crypto.ArithmeticCPS.ModOps.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.ArithmeticCPS.Saturated.
Require Import Crypto.Util.CPSUtil.
Require Import Crypto.Util.CPSNotations.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil.

Require Import Crypto.Util.Notations.
Local Open Scope Z_scope.
Import CPSBindNotations.
Local Open Scope cps_scope.

Module BaseConversion (Import RT : Runtime).
  Module Import Deps.
    Module Export Positional := Positional RT.
    Module Rows := Rows RT.
    Module Export Saturated.
      Module Associational := ArithmeticCPS.Saturated.Associational RT.
    End Saturated.
    Module Export Core.
      Module Associational := ArithmeticCPS.Core.Associational RT.
    End Core.
  End Deps.
  Section BaseConversion.
    Context (sw dw : nat -> Z) (* source/destination weight functions *).

    Definition convert_bases_cps (sn dn : nat) (p : list Z) : ~> list Z :=
      (p' <- Positional.from_associational_cps dw dn (Positional.to_associational sw sn p);
      chained_carries_no_reduce_cps dw dn p' (seq 0 (pred dn))).

    Definition to_associational_cps n m p : ~> list (Z * Z) :=
      (p' <- convert_bases_cps n m p;
         return (Positional.to_associational dw m p')).

    (* TODO : move to Associational? *)
    Section reorder.
      Definition reordering_carry_cps (w fw : Z) (p : list (Z * Z)) : ~> _ :=
        fun T => fold_right_cps2 (fun t acc =>
                      r <- Associational.carryterm_cps w fw t;
                        return (if fst t =? w then acc ++ r else r ++ acc)) nil p.
    End reorder.

    (* carry at specified indices in dw, then use Rows.flatten to convert to Positional with sw *)
    Definition from_associational_cps idxs n (p : list (Z * Z)) : ~> list Z :=
      (* important not to use Positional.carry here; we don't want to accumulate yet *)
      (p' <- Associational.bind_snd_cps p;
         p' <- (fun T => fold_right_cps2 (fun i acc => reordering_carry_cps (dw i) (dw (S i) / dw i) acc) p' (rev idxs));
         p' <- Rows.from_associational_cps sw n p';
         p' <- Rows.flatten_cps sw n p';
       return (fst p')).

(*    Derive from_associational_inlined
           SuchThat (forall idxs n p,
                        from_associational_inlined idxs n p = from_associational idxs n p)
           As from_associational_inlined_correct.
    Proof.
      intros.
      cbv beta iota delta [from_associational reordering_carry Associational.carryterm].
      cbv beta iota delta [Let_In]. (* inlines all shifts/lands from carryterm *)
      cbv beta iota delta [from_associational Rows.from_associational Columns.from_associational].
      cbv beta iota delta [Let_In]. (* inlines the shifts from place *)
      subst from_associational_inlined; reflexivity.
    Qed.

    Derive to_associational_inlined
           SuchThat (forall n m p,
                        to_associational_inlined n m p = to_associational n m p)
           As to_associational_inlined_correct.
    Proof.
      intros.
      cbv beta iota delta [ to_associational convert_bases
                                             Positional.to_associational
                                             Positional.from_associational
                                             chained_carries_no_reduce
                                             carry
                                             Associational.carry
                                             Associational.carryterm
                          ].
      cbv beta iota delta [Let_In].
      subst to_associational_inlined; reflexivity.
    Qed.
*)
    (* carry chain that aligns terms in the intermediate weight with the final weight *)
    Definition aligned_carries (log_dw_sw nout : nat)
      := (map (fun i => ((log_dw_sw * (i + 1)) - 1))%nat (seq 0 nout)).

    Section mul_converted.
  (*    Definition mul_converted
              n1 n2 (* lengths in original format *)
              m1 m2 (* lengths in converted format *)
              (n3 : nat) (* final length *)
              (idxs : list nat) (* carries to do -- this helps preemptively line up weights *)
              (p1 p2 : list Z) :=
        let p1_a := to_associational n1 m1 p1 in
        let p2_a := to_associational n2 m2 p2 in
        let p3_a := Associational.mul p1_a p2_a in
        from_associational idxs n3 p3_a.
*)
    End mul_converted.
  End BaseConversion.

  (* multiply two (n*k)-bit numbers by converting them to n k-bit limbs each, multiplying, then converting back *)
  Section widemul.
    Context (log2base : Z) (log2base_pos : 0 < log2base).
    Context (m n : nat) (m_nz : m <> 0%nat) (n_nz : n <> 0%nat) (n_le_log2base : Z.of_nat n <= log2base).
    Let dw : nat -> Z := weight (log2base / Z.of_nat n) 1.
    Let sw : nat -> Z := weight log2base 1.
    Let mn := (m * n)%nat.
    Let nout := (m * 2)%nat.

    (*Definition widemul a b := mul_converted sw dw m m mn mn nout (aligned_carries n nout) a b.*)

(*    Derive widemul_inlined
           SuchThat (forall a b,
                        length a = m ->
                        length b = m ->
                        widemul_inlined a b = Partition.partition sw nout (seval m a * seval m b))
           As widemul_inlined_correct.
    Proof.
      intros.
      rewrite <-widemul_correct by auto.
      cbv beta iota delta [widemul mul_converted].
      rewrite <-to_associational_inlined_correct with (p:=a).
      rewrite <-to_associational_inlined_correct with (p:=b).
      rewrite <-from_associational_inlined_correct.
      subst widemul_inlined; reflexivity.
    Qed.

    Derive widemul_inlined_reverse
           SuchThat (forall a b,
                        length a = m ->
                        length b = m ->
                        widemul_inlined_reverse a b = Partition.partition sw nout (seval m a * seval m b))
           As widemul_inlined_reverse_correct.
    Proof.
      intros.
      rewrite <-widemul_inlined_correct by assumption.
      cbv [widemul_inlined].
      match goal with |- _ = from_associational_inlined sw dw ?idxs ?n ?p =>
                      transitivity (from_associational_inlined sw dw idxs n (rev p));
                        [ | transitivity (from_associational sw dw idxs n p); [ | reflexivity ] ](* reverse to make addc chains line up *)
      end.
      { subst widemul_inlined_reverse; reflexivity. }
      { rewrite from_associational_inlined_correct by auto.
        cbv [from_associational].
        rewrite !Rows.flatten_correct by eauto using Rows.length_from_associational.
        rewrite !Rows.eval_from_associational by auto.
        f_equal.
        rewrite !eval_carries, !Associational.bind_snd_correct, !Associational.eval_rev by auto.
        reflexivity. }
    Qed.*)
  End widemul.
End BaseConversion.


Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.Base.

(* Weaken kind environment in kind judgement. *)
Lemma kind_kienv_insert
 :  forall ke sp ix t k1 k2
 ,  KindT   ke sp t k1
 -> KindT   (insert ix k2 ke) sp (liftTT 1 ix t) k1.
Proof.
 intros. gen ix ke sp k1.
 induction t; intros; simpl; inverts_kind; eauto.

 - Case "TVar".
   lift_cases; snorm.

 - Case "TForall".
   apply KiForall.
   rewrite insert_rewind. auto.

 - Case "TCon2".
   eapply KiCon2.
   destruct t1.
    destruct tc. eauto.
   destruct tc. eauto.
   destruct tc. eauto.
Qed.

Lemma kind_kienv_weaken
 :  forall ke sp t k1 k2
 ,  KindT   ke sp        t              k1
 -> KindT  (ke :> k2) sp (liftTT 1 0 t) k1.
Proof.
 intros.
 rrwrite (ke :> k2 = insert 0 k2 ke).
 apply kind_kienv_insert. auto.
Qed.