Require Import FCF.
Require Import FCF.PRF.
Require Import Permutation.

Set Implicit Arguments.

(* Sorted random functions are useful, because they ensure the function state is eq
when queries happen in different orders. *)

Section SortedRandomFunc.

  Variable A B : Set.
  Hypothesis A_EqDec : EqDec A.
  Hypothesis B_EqDec : EqDec B.
  Variable leA : A -> A -> bool.
  Hypothesis leA_trans : forall a1 a2 a3, leA a1 a2 = true -> leA a2 a3 = true -> leA a1 a3 = true.
  Hypothesis leA_refl : forall a, leA a a = true.
  Hypothesis leA_antisymm : forall a1 a2, leA a1 a2 = true -> leA a2 a1 = true -> a1 = a2.
  Hypothesis leA_total : forall a1 a2, (leA a1 a2) || (leA a2 a1) = true.
  Variable rndB : Comp B.

  Fixpoint insertInOrder (ls : list (A * B))(a : A)(b : B) :=
    match ls with
    | nil => (a, b)::ls
    | (a', b')::ls' => if (leA a a')
      then ((a, b)::ls)
      else (a', b')::(insertInOrder ls' a b)
    end.

  Theorem insertInOrder_twice_eq : forall (ls : list (A * B)) a1 b1 a2 b2,
    a1 <> a2 ->
    insertInOrder (insertInOrder ls a1 b1) a2 b2 =
    insertInOrder (insertInOrder ls a2 b2) a1 b1.

    induction ls; intuition idtac; simpl in *.
    case_eq (leA a2 a1); intros.
    case_eq (leA a1 a2); intros.
    exfalso.
    eapply H.
    eapply leA_antisymm; eauto.
    trivial.
    case_eq (leA a1 a2); intros.
    trivial.
    specialize (leA_total a1 a2).
    rewrite H0 in leA_total.
    rewrite H1 in leA_total.
    discriminate.

    case_eq (leA a1 a0); intros;
    case_eq (leA a2 a0); intros.
    simpl.
    case_eq (leA a2 a1); intros;
    case_eq (leA a1 a2); intros.
    exfalso.
    eapply H.
    eapply leA_antisymm; eauto.
    rewrite H0.
    trivial.
    rewrite H1.
    trivial.
    specialize (leA_total a1 a2).
    rewrite H2 in leA_total.
    rewrite H3 in leA_total.
    discriminate.
    simpl.
    rewrite H0.
    case_eq (leA a2 a1); intros.
    erewrite leA_trans in H1; eauto. discriminate.
    rewrite H1.
    trivial.

    simpl.
    rewrite H1.
    rewrite H0.
    case_eq (leA a1 a2); intros.
    erewrite leA_trans in H0; eauto. discriminate.
    trivial.

    simpl.
    rewrite H1.
    rewrite H0.
    f_equal.
    eauto.

  Qed.

  Theorem arrayLookup_insertInOrder_same :
    forall (ls : list (A * B)) a b,
    arrayLookup _ (insertInOrder ls a b) a = Some b.

    induction ls; intuition idtac; simpl in *.
    rewrite eqb_refl.
    trivial.
    case_eq (leA a a0); intuition idtac.
    simpl.
    rewrite eqb_refl.
    trivial.
    simpl.
    case_eq (eqb a a0); intuition idtac.
    rewrite eqb_leibniz in H0.
    subst.
    rewrite leA_refl in H.
    discriminate.
    eauto.

  Qed.

  Theorem arrayLookup_insertInOrder_ne :
    forall (ls : list (A * B)) a1 a2 b,
    a1 <> a2 ->
    arrayLookup _ (insertInOrder ls a1 b) a2 = arrayLookup _ ls a2.

    induction ls; intuition idtac; simpl in *.
    case_eq (eqb a2 a1); intuition idtac.
    rewrite eqb_leibniz in H0.
    subst.
    intuition idtac.
    case_eq (leA a1 a0); intuition idtac.
    simpl.
    case_eq (eqb a2 a1); intuition idtac.
    rewrite eqb_leibniz in H1.
    subst.
    intuition idtac.
    simpl.
    case_eq (eqb a2 a0); intuition idtac.
    eauto.
  Qed.

  Theorem insertInOrder_NoDup :
    forall (s : list (A * B)) a b,
    NoDup (fst (split s)) ->
    arrayLookup _ s a = None ->
    NoDup (fst (split (insertInOrder s a b))).

    induction s; intuition idtac; simpl in *.
    econstructor.
    intuition idtac.
    econstructor.

    case_eq (eqb a a0); intros.
    rewrite H1 in H0.
    discriminate.
    rewrite H1 in H0.
    remember (split s) as z. destruct z.
    simpl in *.
    case_eq (leA a a0); intros.
    simpl.
    remember (split s) as z. destruct z.
    simpl.
    inversion H; clear H; subst.
    econstructor.
    simpl; intuition idtac.
    subst.
    rewrite eqb_refl in *.
    discriminate.
    eapply arrayLookup_None_not_In in H0.
    intuition idtac.
    rewrite <- Heqz0.
    intuition idtac.
    econstructor; intuition idtac.
    pairInv.
    intuition idtac.
    pairInv.
    intuition idtac.

    simpl.
    remember (split (insertInOrder s a b0)) as z. destruct z.
    simpl.
    inversion H; clear H; subst.
    econstructor.
    assert (arrayLookup _ (insertInOrder s a b0) a0 = None).
    rewrite arrayLookup_insertInOrder_ne.
    eapply notInArrayLookupNone.
    rewrite <- Heqz.
    intuition idtac.
    intuition idtac; subst.
    rewrite eqb_refl in *. discriminate.
    intuition idtac.
    eapply arrayLookup_None_not_In in H.
    intuition idtac.
    rewrite <- Heqz0.
    trivial.
    specialize (IHs a b0).
    intuition idtac.
    rewrite <- Heqz0 in H3.
    trivial.

  Qed.

  Definition sortedRandomFunc (ls : list (A * B))(a : A) :=
    match (arrayLookup _ ls a) with
    | None => b <-$ rndB; ret (b, (insertInOrder ls a b))
    | Some b => ret (b, ls)
  end.

  Ltac matchOpt :=
    match goal with
    | [|- context[match ?a with | Some _ => _ | None => _ end] ] =>
      case_eq a; intros
    end.

  Theorem sortedRandomFunc_swap : forall s d1 d2,
    comp_spec eq
    ([x2, s2] <-$2 sortedRandomFunc s d1; [x3, s3] <-$2 sortedRandomFunc s2 d2; ret ((x2, x3), s3))
    ([x3, s2] <-$2 sortedRandomFunc s d2; [x2, s3] <-$2 sortedRandomFunc s2 d1; ret ((x2, x3), s3)).

    intuition idtac.
    assert B.
    eapply comp_base_exists; eauto.
    unfold sortedRandomFunc.

    case_eq (eqb d1 d2); intros.
    rewrite eqb_leibniz in H0.
    subst.
    matchOpt.
    fcf_simp.
    rewrite H0.
    fcf_simp.
    eapply comp_spec_eq_refl.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    rewrite arrayLookup_insertInOrder_same.
    fcf_simp.
    eapply comp_spec_eq_refl.

    matchOpt.
    fcf_simp.
    matchOpt.
    fcf_simp.
    rewrite H1.
    fcf_simp.
    eapply comp_spec_ret; intuition idtac.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    rewrite arrayLookup_insertInOrder_ne.
    rewrite H1.
    fcf_simp.
    apply comp_spec_eq_refl.
    intuition idtac; subst.
    rewrite eqb_refl in *.
    discriminate.
    matchOpt.
    fcf_simp.
    rewrite H1.
    fcf_inline_first.
    fcf_skip.
    rewrite arrayLookup_insertInOrder_ne.
    rewrite H2.
    fcf_simp.
    eapply comp_spec_eq_refl.
    intuition idtac; subst.
    rewrite eqb_refl in *. discriminate.

    fcf_inline_first.
    eapply (@comp_spec_eq_trans _ _ _
      (a <-$ rndB; b1 <-$ rndB;
   z <-$ ret (a, insertInOrder s d1 a);
   [x2, s2]<-2 z;
   z0 <-$ (
       ret (b1, insertInOrder s2 d2 b1));
      [x3, s3]<-2 z0; ret (x2, x3, s3))
    ).
    fcf_skip.
    rewrite arrayLookup_insertInOrder_ne.
    rewrite H2.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    eapply comp_spec_eq_refl.
    intuition idtac; subst.
    rewrite eqb_refl in *. discriminate.
    fcf_swap leftc.
    fcf_skip.
    fcf_simp.
    rewrite arrayLookup_insertInOrder_ne.
    rewrite H1.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    eapply comp_spec_ret; intuition idtac.
    f_equal.
    eapply insertInOrder_twice_eq.
    intuition idtac; subst.
    rewrite eqb_refl in *; discriminate.
    intuition idtac; subst.
    rewrite eqb_refl in *; discriminate.

  Qed.

  Theorem insertInOrder_perm : forall s a b,
    Permutation ((a, b)::s) (insertInOrder s a b).

    induction s; intuition idtac; simpl in *.
    eapply Permutation_refl.
    case_eq (leA a a0); intros.
    eapply Permutation_refl.
    eapply Permutation_trans.
    2:{
    econstructor.
    eapply IHs.
    }
    econstructor.

  Qed.

  Fixpoint sortDom (ls : list (A * B)) :=
    match ls with
    | nil => nil
    | (d, r) :: ls' => insertInOrder (sortDom ls') d r
    end.

  Theorem sortDom_perm : forall ls,
    Permutation ls (sortDom ls).

    induction ls; intuition idtac; simpl in *.
    econstructor.
    eapply Permutation_trans.
    econstructor.
    eauto.
    eapply insertInOrder_perm.

  Qed.

  Theorem arrayLookup_sortDom_eq : forall (ls : list (A * B)) a,
    arrayLookup _ ls a = arrayLookup _ (sortDom ls) a.

    induction ls; intuition idtac; simpl in *.
    case_eq (eqb a a0); intros.
    rewrite eqb_leibniz in H.
    subst.
    rewrite arrayLookup_insertInOrder_same.
    trivial.
    rewrite arrayLookup_insertInOrder_ne.
    eauto.
    intuition idtac; subst.
    rewrite eqb_refl in *. discriminate.

  Qed.

  Theorem sortedRandomFunc_sorted_equiv : forall s a,
    comp_spec (fun s1 s2 => fst s1 = fst s2 /\ (snd s2) = sortDom (snd s1))
    (@randomFunc A B rndB _ s a) (sortedRandomFunc (sortDom s) a).

    intuition idtac.
    unfold randomFunc, sortedRandomFunc.
    rewrite <- arrayLookup_sortDom_eq.
    case_eq (arrayLookup A_EqDec s a); intuition idtac.
    eapply comp_spec_ret; intuition idtac.
    fcf_skip.
    eapply comp_base_exists; eauto.
    eapply comp_base_exists; eauto.
    eapply comp_spec_ret; intuition idtac.

  Qed.

End SortedRandomFunc.

Theorem ExpROM_swap_spec_h : forall
  (D1 R1 : Set)
  (A1 : Set)
  (c1 : OracleComp D1 R1 A1)
  (D2 R2 : Set)
  (A2 : Set)
  (c2 : OracleComp D2 R2 A2)
  (eqdr1 : EqDec R1)(eqdr2 : EqDec R2)
  (eqda1 : EqDec A1)(eqda2 : EqDec A2)
  (S : Set)(eqds : EqDec S)
  (o1 : S -> D1 -> Comp (R1 * S))
  (o2 : S -> D2 -> Comp (R2 * S))
  s,
  (forall s d1,
    comp_spec eq
    ([x2, s2] <-$2 o1 s d1; [x3, s3] <-$2 c2 _ _ o2 s2; ret ((x2, x3), s3))
    ([x3, s2] <-$2 c2 _ _  o2 s; [x2, s3] <-$2 o1 s2 d1; ret ((x2, x3), s3))
  ) ->
  comp_spec eq
  ([x2, s2] <-$2 c1 _ _ o1 s; [x3, s3] <-$2 c2 _ _ o2 s2; ret ((x2, x3), s3))
  ([x3, s2] <-$2 c2 _ _ o2 s; [x2, s3] <-$2 c1 _ _ o1 s2; ret ((x2, x3), s3)).

  induction c1; intuition idtac; simpl in *.

  (* query case *)
  specialize (@H s a).
  despec.
  intuition idtac.
  exists x.
  intuition idtac.

  eapply eqRat_trans.
  2:{
  eapply eqRat_trans.
  eapply H0.
  unfold marginal_l.
  fcf_skip.
  eapply evalDist_ret_eq.
  simpl.
  case_eq (eqbPair (pair_EqDec eqda1 eqda2) eqds
  (fst x0) (a1, b0, b)); intros.
  case_eq (eqbPair (pair_EqDec eqdr1 eqda2) eqds
  (fst x0) (a1, b0, b));
  intros.
  eauto.
  apply eqbPair_prop in H3.
  destruct x0; simpl in *; subst.
  rewrite eqbPair_refl in H4.
  discriminate.
  case_eq (eqbPair (pair_EqDec eqdr1 eqda2) eqds
  (fst x0) (a1, b0, b));
  intros.
  apply eqbPair_prop in H4.
  destruct x0; simpl in *; subst.
  rewrite eqbPair_refl in H3.
  discriminate.
  trivial.
  }
  fcf_skip.
  fcf_simp.
  fcf_skip.
  fcf_simp.
  fcf_compute.

  eapply eqRat_trans.
  2:{
  eapply eqRat_trans.
  eapply H.
  unfold marginal_r.
  fcf_skip.
  eapply evalDist_ret_eq.
  simpl.
  case_eq (eqbPair (pair_EqDec eqda1 eqda2) eqds
  (snd x0) (a1, b0, b)); intros.
  case_eq (eqbPair (pair_EqDec eqdr1 eqda2) eqds
  (snd x0) (a1, b0, b));
  intros.
  eauto.
  apply eqbPair_prop in H3.
  destruct x0; simpl in *; subst.
  rewrite eqbPair_refl in H4.
  discriminate.
  case_eq (eqbPair (pair_EqDec eqdr1 eqda2) eqds
  (snd x0) (a1, b0, b));
  intros.
  apply eqbPair_prop in H4.
  destruct x0; simpl in *; subst.
  rewrite eqbPair_refl in H3.
  discriminate.
  trivial.
  }
  fcf_skip.
  fcf_simp.
  fcf_skip.
  fcf_simp.
  fcf_compute.

  (* run case *)
  assert (A -> B * S) as bs.
  intros.
  eapply oc_base_exists; eauto.
  intuition idtac.
  assert (B' * S0).
  eapply comp_base_exists; eauto.
  intuition idtac.

  assert C as c.
  eapply oc_base_exists; eauto.
  intuition idtac.

  assert (D2 -> R2) as r2.
  intuition idtac.
  assert (R2 * S0).
  eapply comp_base_exists; eauto.
  intuition idtac.

  assert A2 as a2.
  eapply oc_base_exists; eauto.

  fcf_inline_first.
  assert (EqDec C).
  eapply EqDec_pair_l; eauto.

  eapply (@comp_spec_eq_trans_l _ _ _ _ _
    (y <-$ (a <-$
   c1 (S * S0)%type (pair_EqDec e eqds)
     (fun (x : S * S0) (y : A) =>
      p <-$ (o (fst x) y) S0 eqds o1 (snd x);
      ret (fst (fst p), (snd (fst p), snd p)))
     (s, s0);
   [x2, s3]<-2 a;
   z0 <-$ c2 (S * S0)%type _
    (fun p d => r <-$ o2 (snd p) d; ret (fst r, (fst p, snd r))) s3;
  [x3, s4]<-2 z0; ret (x2, x3, s4));
  ret (((fst (fst y), fst (snd y)), (snd (fst y))), (snd (snd y))))
  ).
  fcf_inline_first.
  fcf_skip.

  fcf_inline_first.
  fcf_skip.
  simpl.
  eapply (@fcf_oracle_eq _ _ (fun p1 p2 => p1 = (snd p2) /\ fst p2 = a));
  intuition idtac.
  subst.
  eapply comp_spec_eq_trans_l.
  eapply comp_spec_symm.
  eapply comp_spec_consequence.
  eapply comp_spec_right_ident.
  intros; subst; trivial.
  fcf_skip.
  simpl.
  eapply comp_spec_ret; intuition idtac.
  simpl.
  fcf_simp.
  simpl in *; intuition idtac; subst.
  eapply comp_spec_ret; intuition idtac.

  specialize (@IHc1 _ _ _ c2 _ _ _ _ (S * S0)%type _
    (fun (x : S * S0) (y : A) =>
      p <-$ (o (fst x) y) S0 eqds o1 (snd x);
      ret (fst (fst p), (snd (fst p), snd p)))
    (fun (p : S * S0) (d : D2) =>
      r <-$ o2 (snd p) d; ret (fst r, (fst p, snd r)))).
  eapply (@ comp_spec_eq_trans_r _ _ _ _ _
      (y <-$ (z <-$
          c2 _ _
            (fun (p : S * S0) (d : D2) =>
             r <-$ o2 (snd p) d; ret (fst r, (fst p, snd r))) (s, s0);
          [x3, s3]<-2 z;
          z0 <-$
          c1 _ _
            (fun (x : S * S0) (y : A) =>
             p <-$ (o (fst x) y) S0 eqds o1 (snd x);
             ret (fst (fst p), (snd (fst p), snd p))) s3;
          [x2, s4]<-2 z0; ret (x2, x3, s4));
      ret (((fst (fst y), fst (snd y)), (snd (fst y))), (snd (snd y))))
  ).
  eapply comp_spec_seq_eq.
  intuition idtac.
  intuition idtac.
  eapply IHc1.
  intuition idtac.
  simpl in *. subst.
  eapply (@ comp_spec_eq_trans_l _ _ _ _ _
    (y <-$(z <-$ (o a d1) S0 eqds o1 b;
     [x2, s3]<-2 z;
     z0 <-$ c2 _ _ o2 s3;
     [x3, s4]<-2 z0; ret (x2, x3, s4));
      ret ((fst (fst (fst y)), (snd (fst y))), (snd (fst (fst y)), (snd y)))
    )
  ).
  fcf_inline_first.
  fcf_skip.
  simpl.
  fcf_inline_first.
  fcf_skip.
  eapply (@fcf_oracle_eq _ _ (fun p1 p2 => (snd p1) = p2 /\ fst p1 = b2)); intuition idtac.
  subst.
  eapply comp_spec_eq_trans_r.
  2:{
  eapply comp_spec_right_ident.
  }
  fcf_skip.
  eapply comp_spec_ret; intuition idtac.
  fcf_simp.
  simpl in *; intuition idtac.
  subst.
  eapply comp_spec_ret; intuition idtac.

  eapply (@ comp_spec_eq_trans_r _ _ _ _ _
    (y <-$
      (z <-$ c2 _ _ o2 b;
      [x2, s3] <-2 z;
      z0 <-$ (o a d1) _ _ o1 s3;
      [x3, s4] <-2 z0; ret (x3, x2, s4));
      ret ((fst (fst (fst y)), (snd (fst y))), (snd (fst (fst y)), (snd y)))
    )
  ).
  eapply comp_spec_seq.
  intuition idtac.
  intuition idtac.
  eapply H;
  eauto.
  intuition idtac.
  subst.
  eapply comp_spec_ret; intuition idtac.

  fcf_inline_first.
  fcf_skip.
  eapply (@fcf_oracle_eq _ _ (fun p1 p2 => p1 = (snd p2) /\ fst p2 = a)); intuition idtac.
  subst.
  eapply comp_spec_eq_trans_l.
  eapply comp_spec_symm.
  eapply comp_spec_consequence.
  eapply comp_spec_right_ident.
  intros; subst; trivial.
  fcf_skip.
  eapply comp_spec_ret; intuition idtac.

  simpl in *; intuition idtac; subst.
  fcf_inline_first.
  fcf_simp.
  fcf_inline_first.
  fcf_skip.
  fcf_simp.
  eapply comp_spec_eq_refl.

  intros.
  eapply comp_spec_eq_refl.

  fcf_inline_first.
  fcf_skip.
  eapply (@fcf_oracle_eq _ _ (fun p1 p2 => snd p1 = p2 /\ fst p1 = s));
  intuition idtac.
  subst.
  simpl.
  eapply comp_spec_eq_trans_r.
  2:{
  eapply comp_spec_right_ident.
  }
  fcf_skip.
  eapply comp_spec_ret; simpl in *; intuition idtac.
  simpl in *; intuition idtac; subst.
  fcf_simp.
  fcf_inline_first.
  fcf_skip.
  simpl.
  fcf_simp.
  eapply comp_spec_ret; intuition idtac.

  (* ret case *)
  assert C as c_ex.
  eapply comp_base_exists; eauto.

  assert A2 as a2_ex.
  eapply oc_base_exists; eauto.
  intuition idtac.
  assert (R2 * S).
  eapply comp_base_exists; eauto.
  intuition idtac.

  fcf_inline_first.
  eapply (@comp_spec_eq_trans_l _ _ _ _ _
    (a <-$ c;
      z0 <-$ c2 S eqds o2 s; [x3, s4]<-2 z0; ret (a, x3, s4))
  ).
  fcf_skip.
  fcf_swap leftc.
  fcf_skip.
  fcf_inline_first.
  fcf_skip.
  fcf_simp.
  eapply comp_spec_ret; intuition idtac.

  (* bind case *)
  assert C as c_ex.
  eapply oc_base_exists; eauto.
  intuition idtac.
  assert (B * S).
  eapply comp_base_exists; eauto.
  intuition idtac.

  assert C' as c'_ex.
  eapply oc_base_exists.
  eapply o.
  intuition idtac.
  intuition idtac.
  assert (B * S).
  eapply comp_base_exists; eauto.
  intuition idtac.

  assert A2 as a2_ex.
  eapply oc_base_exists; eauto.
  intuition idtac.
  assert (R2 * S).
  eapply comp_base_exists; eauto.
  intuition idtac.

  fcf_inline_first.
  eapply (@comp_spec_eq_trans_l _ _ _ _ _
    (a <-$ c1 S eqds o1 s;
     [z, s']<-2 a;
     z <-$ ((o z) S eqds o1 s');
     [x2, s3]<-2 z;
     z0 <-$ c2 S eqds o2 s3;
     [x3, s4]<-2 z0; ret (x2, x3, s4))
  ).
  fcf_skip.

  eapply (@comp_spec_eq_trans _ _ _
    (a <-$ c1 S eqds o1 s;
     [z, s']<-2 a;
     z1 <-$ c2 S eqds o2 s';
     [x2, s3]<-2 z1;
     z0 <-$ ((o z) S eqds o1 s3);
     [x3, s4]<-2 z0; ret (x3, x2, s4))
  ).
  fcf_skip.
  eapply H; intuition idtac.

  eapply (@comp_spec_eq_trans_l _ _ _ _ _
    (y <-$ (a <-$ c1 S eqds o1 s;
     [z, s']<-2 a;
     z1 <-$ c2 S eqds o2 s';
     [x2, s3]<-2 z1;
      ret (z, x2, s3)
    );
    z0 <-$ (o (fst (fst y))) S eqds o1 (snd y);
     [x3, s4]<-2 z0; ret (x3, (snd (fst y)), s4))
  ).
  fcf_inline_first.
  fcf_skip.
  fcf_inline_first.
  fcf_skip.
  fcf_simp.
  simpl.
  fcf_inline_first.
  eapply comp_spec_eq_refl.

  eapply (@comp_spec_eq_trans_r _ _ _ _ _
    (y <-$
     (a <-$ c2 S eqds o2 s;
     [z, s']<-2 a;
     z1 <-$ c1 S eqds o1 s';
     [x2, s3]<-2 z1;
      ret (x2, z, s3)
    );
    z0 <-$ (o (fst (fst y))) S eqds o1 (snd y);
     [x3, s4]<-2 z0; ret (x3, (snd (fst y)), s4))
  ).
  eapply comp_spec_seq.
  intuition idtac.
  intuition idtac.
  eapply IHc1; intuition idtac.
  intuition idtac.
  subst.
  fcf_skip.

  fcf_inline_first.
  fcf_skip.
  fcf_inline_first.
  fcf_skip.
  simpl.
  fcf_skip.

  Unshelve.

  eapply pair_EqDec; intuition idtac.
  eapply oc_EqDec.
  eauto.
  intuition idtac.
  assert (B * S).
  eapply comp_base_exists; eauto.
  intuition idtac.
  intuition idtac.

  eapply pair_EqDec; intuition idtac.
  eapply oc_EqDec.
  eauto.
  intuition idtac.
  assert (B * S).
  eapply comp_base_exists; eauto.
  intuition idtac.
  intuition idtac.

  eapply pair_EqDec; intuition idtac.
  eapply oc_EqDec.
  eauto.
  intuition idtac.
  assert (B * S).
  eapply comp_base_exists; eauto.
  intuition idtac.
  intuition idtac.

  eapply oc_EqDec.
  eauto.
  intuition idtac.
  assert (B * S).
  eapply comp_base_exists; eauto.
  intuition idtac.
  intuition idtac.

  eapply pair_EqDec; intuition idtac.
  eapply oc_EqDec.
  eauto.
  intuition idtac.
  assert (B * S).
  eapply comp_base_exists; eauto.
  intuition idtac.
  intuition idtac.

Qed.

Theorem ExpROM_query_swap_spec : forall
  (D2 R2 : Set)
  (A2 : Set)
  (c2 : OracleComp D2 R2 A2)
  (D1 R1 : Set)
  (A1 : Set)
  (eqdr1 : EqDec R1)(eqdr2 : EqDec R2)
  (eqda1 : EqDec A1)(eqda2 : EqDec A2)
  (S : Set)(eqds : EqDec S)
  (o1 : S -> D1 -> Comp (R1 * S))
  (o2 : S -> D2 -> Comp (R2 * S))
  s d,
  (forall s d1 d2,
    comp_spec eq
    ([x2, s2] <-$2 o1 s d1; [x3, s3] <-$2 o2 s2 d2; ret ((x2, x3), s3))
    ([x3, s2] <-$2 o2 s d2; [x2, s3] <-$2 o1 s2 d1; ret ((x2, x3), s3))
  ) ->
  comp_spec eq
  ([x2, s2] <-$2 o1 s d; [x3, s3] <-$2 c2 _ _ o2 s2; ret ((x2, x3), s3))
  ([x3, s2] <-$2 c2 _ _ o2 s; [x2, s3] <-$2 o1 s2 d; ret ((x2, x3), s3)).

  induction c2; intuition idtac; simpl in *.

  (* query case *)
  specialize (@H s d a).
  despec.
  intuition idtac.
  exists x.
  intuition idtac.

  eapply eqRat_trans.
  2:{
  eapply eqRat_trans.
  eapply H0.
  unfold marginal_l.
  fcf_skip.
  eapply evalDist_ret_eq.
  simpl.
  case_eq (eqbPair (pair_EqDec eqdr1 eqda2) eqds
  (fst x0) (a1, b0, b)); intros.
  case_eq (eqbPair (pair_EqDec eqdr1 eqdr2) eqds
  (fst x0) (a1, b0, b));
  intros.
  eauto.
  apply eqbPair_prop in H3.
  destruct x0; simpl in *; subst.
  rewrite eqbPair_refl in H4.
  discriminate.
  case_eq (eqbPair (pair_EqDec eqdr1 eqdr2) eqds
  (fst x0) (a1, b0, b));
  intros.
  apply eqbPair_prop in H4.
  destruct x0; simpl in *; subst.
  rewrite eqbPair_refl in H3.
  discriminate.
  trivial.
  }
  fcf_skip.
  fcf_simp.
  fcf_skip.
  fcf_simp.
  fcf_compute.

  eapply eqRat_trans.
  2:{
  eapply eqRat_trans.
  eapply H.
  unfold marginal_r.
  fcf_skip.
  eapply evalDist_ret_eq.
  simpl.
  case_eq (eqbPair (pair_EqDec eqdr1 eqda2) eqds
  (snd x0) (a1, b0, b)); intros.
  case_eq (eqbPair (pair_EqDec eqdr1 eqdr2) eqds
  (snd x0) (a1, b0, b));
  intros.
  eauto.
  apply eqbPair_prop in H3.
  destruct x0; simpl in *; subst.
  rewrite eqbPair_refl in H4.
  discriminate.
  case_eq (eqbPair (pair_EqDec eqdr1 eqdr2) eqds
  (snd x0) (a1, b0, b));
  intros.
  apply eqbPair_prop in H4.
  destruct x0; simpl in *; subst.
  rewrite eqbPair_refl in H3.
  discriminate.
  trivial.
  }
  fcf_skip.
  fcf_simp.
  fcf_skip.
  fcf_simp.
  fcf_compute.

  (* run case *)

  assert R1 as r1_ex.
  assert (R1 * S0).
  eapply comp_base_exists.
  eauto.
  intuition idtac.

  assert (A' -> B') as b'_ex.
  intros.
  assert (B' * S0).
  eapply comp_base_exists; eauto.
  intuition idtac.

  assert (A -> B) as b_ex.
  intros.
  assert (B * S).
  eapply oc_base_exists.
  eapply o.
  trivial.
  trivial.
  trivial.
  intuition idtac.

  assert C as c_ex.
  eapply oc_base_exists.
  eauto.
  intuition idtac.

  fcf_inline_first.
  assert (EqDec C).
  eapply EqDec_pair_l; eauto.

  eapply (@comp_spec_eq_trans_l _ _ _ _ _
    (y <-$ (z <-$ (fun p d => r <-$ o1 (snd p) d; ret (fst r, (fst p, snd r))) (s, s0) d;
     [x2, s2]<-2 z;
      z0 <-$
        c2 (S * S0)%type (pair_EqDec e eqds)
          (fun (x : S * S0) (y : A) =>
           p <-$
           (o (fst x) y) S0 eqds o2 (snd x);
           ret (fst (fst p),
               (snd (fst p), snd p)))
          s2;
      [x3, s3]<-2 z0;
      ret (x2, x3, s3));
     ret ((fst (fst y)), (snd (fst y), fst (snd y)), snd (snd y)))
  ).
  fcf_inline_first.
  fcf_skip.
  fcf_simp.
  fcf_inline_first.
  fcf_skip.
  fcf_simp.
  eapply comp_spec_ret; intuition idtac.

  specialize (@IHc2 _ _ _ _ _ _ _ (S * S0)%type _
    (fun p d => r <-$ o1 (snd p) d; ret (fst r, (fst p, snd r)))
    (fun (x : S * S0) (y : A) =>
       p <-$
       (o (fst x) y) S0 eqds o2 (snd x);
       ret (fst (fst p),
           (snd (fst p), snd p)))
  ).
  eapply (@comp_spec_eq_trans_r _ _ _ _ _
    (y <-$
   (z <-$
          c2 (S * S0)%type
            (pair_EqDec e eqds)
            (fun (x : S * S0) (y : A) =>
             p <-$
             (o (fst x) y) S0 eqds o2
               (snd x);
             ret (fst (fst p),
                 (snd (fst p), snd p))) (s, s0);
          [x3, s2]<-2 z;
          z0 <-$
          (fun (p : S * S0) (d0 : D1) =>
           r <-$ o1 (snd p) d0;
           ret (fst r, (fst p, snd r))) s2 d;
          [x2, s3]<-2 z0; ret (x2, x3, s3));
   ret (fst (fst y),
       (snd (fst y), fst (snd y)),
       snd (snd y)))
  ).
  eapply comp_spec_seq.
  intuition idtac.
  intuition idtac.
  eapply IHc2.

  intuition idtac.

  simpl.
  eapply (@comp_spec_eq_trans_l _ _ _ _ _
      ([a, b, c] <-$3 (r <-$ o1 b d1;
      [x2, s2] <-2 r;
      z0 <-$ (o a d2) S0 eqds o2 s2;
      [x3, s3]<-2 z0;
      ret (x2, x3, s3));
      ret (a, (fst b), (snd b, c)))
  ).
  fcf_inline_first.
  fcf_skip.
  fcf_inline_first.
  simpl.
  fcf_skip.
  fcf_simp.
  eapply comp_spec_ret; intuition idtac.

  eapply (@comp_spec_eq_trans_r _ _ _ _ _
    ([a, b, c] <-$3
      (z <-$ (o a d2) S0 eqds o2 b;
       [x3, s2]<-2 z;
       z0 <-$ o1 s2 d1;
       [x2, s3]<-2 z0; ret (x2, x3, s3));
    ret (a, (fst b), (snd b, c)))
  ).
  eapply comp_spec_seq_eq.
  intuition idtac.
  intuition idtac.
  eapply H; intuition idtac.
  eauto.
  intuition idtac.
  eapply comp_spec_eq_refl.
  fcf_inline_first.
  fcf_skip.
  fcf_simp.
  simpl.
  fcf_inline_first.
  fcf_skip.
  fcf_simp.
  apply comp_spec_ret; intuition idtac.

  intuition idtac.
  subst. simpl in *.
  eapply comp_spec_ret; intuition idtac.

  fcf_inline_first.
  fcf_skip.
  fcf_inline_first.
  fcf_simp.
  fcf_skip.
  simpl.
  eapply comp_spec_ret; intuition idtac.

  (* ret case *)
  assert R1 as r1_ex.
  assert (R1 * S).
  eapply comp_base_exists; eauto.
  intuition idtac.

  assert C as c_ex.
  apply comp_base_exists; eauto.

  fcf_inline_first.
  eapply comp_spec_eq_symm.
  eapply (@comp_spec_eq_trans _ _ _
    (a <-$ c;
     z0 <-$ o1 s d;
     [x2, s3]<-2 z0; ret (x2, a, s3))
  ).
  fcf_skip.
  fcf_swap leftc.
  fcf_skip.
  fcf_inline_first.
  fcf_skip.
  fcf_simp.
  eapply comp_spec_ret; intuition idtac.

  (* bind case *)
  assert R1 as r1_ex.
  assert (R1 * S).
  eapply comp_base_exists; eauto.
  intuition idtac.

  assert (A -> B).
  intros.
  assert (B * S).
  eapply comp_base_exists; eauto.
  intuition idtac.

  assert C as c_ex.
  eapply oc_base_exists; eauto.

  assert C' as c'_ex.
  eapply oc_base_exists.
  eapply o.
  trivial.
  intuition idtac.

  fcf_inline_first.
  eapply (@comp_spec_eq_trans_l _ _ _ _ _
    ([a, b, c] <-$3 (z <-$ o1 s d;
      [x2, s2]<-2 z;
      z0 <-$ c2 S eqds o2 s2;
      [z1, s']<-2 z0;
      ret (x2, z1, s'));
     z1 <-$
     ((o b) S eqds o2 c);
     [x3, s3]<-2 z1; ret (a, x3, s3))
  ).
  fcf_inline_first.
  fcf_skip.
  fcf_inline_first.
  fcf_skip.
  fcf_simp.
  eapply comp_spec_eq_refl.

  eapply (@comp_spec_eq_trans _ _ _
    ([a, b, c] <-$3
      (z <-$ c2 S eqds o2 s;
          [x3, s2]<-2 z;
          z0 <-$ o1 s2 d;
          [x2, s3]<-2 z0; ret (x2, x3, s3));
     z1 <-$
     ((o b) S eqds o2 c);
     [x3, s3]<-2 z1; ret (a, x3, s3))
  ).
  eapply comp_spec_seq_eq.
  intuition idtac.
  intuition idtac.
  eapply IHc2; intuition idtac.
  eauto.
  intuition idtac.
  eapply comp_spec_eq_refl.
  fcf_inline_first.
  fcf_skip.
  eapply comp_spec_eq_trans.
  2:{
  eapply H; intuition idtac.
  eauto.
  }
  fcf_inline_first.
  fcf_skip.

  Unshelve.

  eapply pair_EqDec; intuition idtac.
  eapply oc_EqDec.
  eauto.
  intuition idtac.
  intuition idtac.

  eapply oc_EqDec.
  eauto.
  intuition idtac.
  intuition idtac.

  eapply pair_EqDec; intuition idtac.
  eapply oc_EqDec.
  eauto.
  intuition idtac.
  intuition idtac.

Qed.

Theorem ExpROM_swap_spec : forall
  (D1 R1 : Set)
  (A1 : Set)
  (c1 : OracleComp D1 R1 A1)
  (D2 R2 : Set)
  (A2 : Set)
  (c2 : OracleComp D2 R2 A2)
  (eqdr1 : EqDec R1)(eqdr2 : EqDec R2)
  (eqda1 : EqDec A1)(eqda2 : EqDec A2)
  (S : Set)(eqds : EqDec S)
  (o1 : S -> D1 -> Comp (R1 * S))
  (o2 : S -> D2 -> Comp (R2 * S))
  s,
  (forall s d1 d2,
    comp_spec eq
    ([x2, s2] <-$2 o1 s d1; [x3, s3] <-$2 o2 s2 d2; ret ((x2, x3), s3))
    ([x3, s2] <-$2 o2 s d2; [x2, s3] <-$2 o1 s2 d1; ret ((x2, x3), s3))
  ) ->
  comp_spec eq
  ([x2, s2] <-$2 c1 _ _ o1 s; [x3, s3] <-$2 c2 _ _ o2 s2; ret ((x2, x3), s3))
  ([x3, s2] <-$2 c2 _ _ o2 s; [x2, s3] <-$2 c1 _ _ o1 s2; ret ((x2, x3), s3)).

  intuition idtac.
  eapply ExpROM_swap_spec_h.
  intuition idtac.
  intuition idtac.
  eapply ExpROM_query_swap_spec; intuition idtac.

  eauto.

Qed.

(* Experiments in the random oracle model and related theory. *)
Section ExperimentROM.

  Variable DomainRO RangeRO : Set.
  Hypothesis DomainRO_EqDec : EqDec DomainRO.
  Hypothesis RangeRO_EqDec : EqDec RangeRO.
  Variable rndRange : Comp RangeRO.

  Section WithProcs.
    Variable T : Set.
    Hypothesis T_EqDec : EqDec T.
    Variable A : OracleComp DomainRO RangeRO T.
    (* The experiment takes a function that calculates the result from the RO state *)
    Variable X : Set.
    Hypothesis X_EqDec : EqDec X.
    Variable f : T -> list (DomainRO * RangeRO) -> X.

    Definition ExpROM_gen_s s :=
      [t, s] <-$2 A _ _ (@randomFunc DomainRO RangeRO rndRange _) s;
      ret f t s.

    Definition ExpROM_gen := ExpROM_gen_s nil.

    Definition ExpROM :=
      [t, _] <-$2 A _ _ (@randomFunc DomainRO RangeRO rndRange _) nil;
      ret t.
  End WithProcs.

  Theorem ExpROM_gen_seq_eq : forall (A B C : Set)
    (eqdb : EqDec B)(eqdc : EqDec C)
    (c1a c1b : OracleComp DomainRO RangeRO A)
    (c2a c2b : A -> OracleComp DomainRO RangeRO B)
    (f : B -> (list (DomainRO*RangeRO)) -> C)
    v s,
    (forall x,
      evalDist (c1a _ _ (randomFunc rndRange DomainRO_EqDec) s) x ==
      evalDist (c1b _ _ (randomFunc rndRange DomainRO_EqDec) s) x) ->
    (forall x1 s v,
      evalDist (z <-$
     (c2a x1)
       (list (DomainRO * RangeRO))
       (list_EqDec
          (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
       (randomFunc rndRange DomainRO_EqDec) s;
     [a, s]<-2 z; ret (f a s)) v ==
     evalDist
    (z <-$
     (c2b x1)
       (list (DomainRO * RangeRO))
       (list_EqDec
          (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
       (randomFunc rndRange DomainRO_EqDec) s;
     [a, s]<-2 z; ret (f a s)) v
    ) ->
    evalDist (z <-$
   (x1 <--$ c1a; c2a x1)
     (list (DomainRO * RangeRO))
     (list_EqDec
        (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
     (randomFunc rndRange DomainRO_EqDec) s;
   [a, s]<-2 z; ret (f a s)) v ==
   evalDist
  (z <-$
   (x1 <--$ c1b; c2b x1)
     (list (DomainRO * RangeRO))
     (list_EqDec
        (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
     (randomFunc rndRange DomainRO_EqDec) s;
   [a, s]<-2 z; ret (f a s)) v.

    intuition idtac.
    Local Opaque evalDist.
    simpl.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    eauto.

    Local Transparent evalDist.

  Qed.

  Theorem ExpROM_seq_eq : forall (A B : Set)
    (eqdb : EqDec B)
    (c1a c1b : OracleComp DomainRO RangeRO A)
    (c2a c2b : A -> OracleComp DomainRO RangeRO B)
    v s,
    (forall x,
      evalDist (c1a _ _ (randomFunc rndRange DomainRO_EqDec) s) x ==
      evalDist (c1b _ _ (randomFunc rndRange DomainRO_EqDec) s) x) ->
    (forall x1 s v,
      evalDist (z <-$
     (c2a x1)
       (list (DomainRO * RangeRO))
       (list_EqDec
          (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
       (randomFunc rndRange DomainRO_EqDec) s;
     [a, _]<-2 z; ret a) v ==
     evalDist
    (z <-$
     (c2b x1)
       (list (DomainRO * RangeRO))
       (list_EqDec
          (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
       (randomFunc rndRange DomainRO_EqDec) s;
     [a, _]<-2 z; ret a) v
    ) ->
    evalDist (z <-$
   (x1 <--$ c1a; c2a x1)
     (list (DomainRO * RangeRO))
     (list_EqDec
        (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
     (randomFunc rndRange DomainRO_EqDec) s;
   [a, _]<-2 z; ret a) v ==
   evalDist
  (z <-$
   (x1 <--$ c1b; c2b x1)
     (list (DomainRO * RangeRO))
     (list_EqDec
        (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
     (randomFunc rndRange DomainRO_EqDec) s;
   [a, _]<-2 z; ret a) v.

    intuition idtac.
    Local Opaque evalDist.
    simpl.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    eauto.

    Local Transparent evalDist.

  Qed.

  Theorem randomFunc_lookup_Some_inv : forall (D R : Set)(eqdd : EqDec D)(rndR : Comp R) s1 s2 v x b a,
    In (v, s2) (getSupport (@randomFunc D R rndR _ s1 a)) ->
    arrayLookup _ s1 x = Some b ->
    arrayLookup _ s2 x = Some b.

    intuition idtac.
    unfold randomFunc in *.
    case_eq (arrayLookup eqdd s1 a); intuition idtac;
    rewrite H1 in H;
    repeat simp_in_support.
    trivial.
    simpl.
    case_eq (eqb x a); intuition idtac.
    rewrite eqb_leibniz in H.
    subst.
    rewrite H0 in H1.
    discriminate.

  Qed.

  (* If the function is a fold with a commutative accumulator, then independent statements
  can be swapped. *)

  Theorem sumList_permutation_body_eq:
    forall (A : Set) (f1 f2 : A -> Rat) (ls1 ls2 : list A),
    Permutation ls1 ls2 ->
    (forall a, In a ls2 -> (f1 a == f2 a)) ->
    sumList ls1 f1 == sumList ls2 f2.

    intros.
    eapply eqRat_trans.
    eapply sumList_permutation; eauto.
    eapply sumList_body_eq; intuition idtac.

  Qed.

  Variable leDom : DomainRO -> DomainRO -> bool.
  Hypothesis leDom_trans : forall a1 a2 a3, leDom a1 a2 = true -> leDom a2 a3 = true -> leDom a1 a3 = true.
  Hypothesis leDom_refl : forall a, leDom a a = true.
  Hypothesis leDom_antisymm : forall a1 a2, leDom a1 a2 = true -> leDom a2 a1 = true -> a1 = a2.
  Hypothesis leDOm_total : forall a1 a2, (leDom a1 a2) || (leDom a2 a1) = true.

  Theorem ExpROM_swap : forall (A B C : Set)
    (c1 : OracleComp DomainRO RangeRO A)
    (c2 : OracleComp DomainRO RangeRO B)
    (c3 : A -> B -> OracleComp DomainRO RangeRO C)
    (E : Set)(eqde : EqDec E)(f2 : C -> E -> (DomainRO * RangeRO) -> E)
    (init : E) s x,
    (forall c e d1 d2, f2 c (f2 c e d1) d2 = f2 c (f2 c e d2) d1) ->
    evalDist (ExpROM_gen_s (x1 <--$ c1; x2 <--$ c2; c3 x1 x2) _ (fun c ls => fold_left (fun e d => (f2 c e d)) ls init) s ) x ==
    evalDist (ExpROM_gen_s (x2 <--$ c2; x1 <--$ c1; c3 x1 x2) _ (fun c ls => fold_left (fun e d => (f2 c e d)) ls init) s ) x.

    intuition idtac.

    assert RangeRO as RangeRO_ex.
    eapply comp_base_exists; eauto.

    assert A as a_ex.
    eapply oc_base_exists; eauto.

    assert B as b_ex.
    eapply oc_base_exists; eauto.

    assert C as c_ex.
    eapply oc_base_exists.
    eapply c3; intuition idtac.
    intuition idtac.

    unfold ExpROM_gen_s.

    eapply (@eqRat_trans  _
      (evalDist (z <-$
     (x1 <--$ c1; x2 <--$ c2; c3 x1 x2)
       (list (DomainRO * RangeRO))
       (list_EqDec (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
       (sortedRandomFunc _ _ leDom rndRange) (sortDom leDom s);
     [t, s0]<-2 z;
     ret fold_left
           (fun (e : E) (d : DomainRO * RangeRO) => f2 t e d)
           s0 init) x)
    ).

    eapply comp_spec_eq_impl_eq.
    fcf_skip.
    eapply fcf_oracle_eq.
    2:{
    intros.
    assert ((fun x1 x2 => x2 = sortDom leDom x1) x1 x2).
    eapply H0.
    simpl in *.
    subst.
    eapply sortedRandomFunc_sorted_equiv; intuition idtac.
    }
    simpl in *.
    trivial.
    simpl in *; intuition idtac.
    destruct b0; simpl in *; subst.
    eapply comp_spec_ret; intuition idtac.
    eapply fold_left_comm_perm_eq; intuition idtac.
    eapply sortDom_perm.
    eauto.
    symmetry.
    eapply (@eqRat_trans  _
      (evalDist (z <-$
     (x1 <--$ c2; x2 <--$ c1; c3 x2 x1)
       (list (DomainRO * RangeRO))
       (list_EqDec (pair_EqDec DomainRO_EqDec RangeRO_EqDec))
       (sortedRandomFunc _ _ leDom rndRange) (sortDom leDom s);
     [t, s0]<-2 z;
     ret fold_left
           (fun (e : E) (d : DomainRO * RangeRO) => f2 t e d)
           s0 init) x)
    ).

    eapply comp_spec_eq_impl_eq.
    fcf_skip.
    eapply fcf_oracle_eq.
    2:{
    intros.
    assert ((fun x1 x2 => x2 = sortDom leDom x1) x1 x2).
    eapply H0.
    simpl in *.
    subst.
    eapply sortedRandomFunc_sorted_equiv; intuition idtac.
    }
    simpl in *.
    trivial.
    simpl in *; intuition idtac.
    destruct b0; simpl in *; subst.
    eapply comp_spec_ret; intuition idtac.
    eapply fold_left_comm_perm_eq; intuition idtac.
    eapply sortDom_perm.
    eauto.

    eapply comp_spec_eq_impl_eq.
    simpl.
    eapply (@comp_spec_eq_trans _ _ _
      (z <-$
     ([z, z2, s'0] <-$3 (z0 <-$
      c2 (list (DomainRO * RangeRO))
        (list_EqDec
           (pair_EqDec DomainRO_EqDec
              RangeRO_EqDec))
        (sortedRandomFunc DomainRO_EqDec
           RangeRO_EqDec leDom rndRange)
        (sortDom leDom s);
      [z, s']<-2 z0;
      z1 <-$
      c1 (list (DomainRO * RangeRO))
        (list_EqDec
           (pair_EqDec DomainRO_EqDec
              RangeRO_EqDec))
        (sortedRandomFunc DomainRO_EqDec
           RangeRO_EqDec leDom rndRange) s';
      [z2, s'0]<-2 z1;
      ret (z, z2, s'0));

      (c3 z2 z) (list (DomainRO * RangeRO))
        (list_EqDec
           (pair_EqDec DomainRO_EqDec
              RangeRO_EqDec))
        (sortedRandomFunc DomainRO_EqDec
           RangeRO_EqDec leDom rndRange) s'0);
     [t, s0]<-2 z;
     ret fold_left
           (fun (e : E) (d : DomainRO * RangeRO)
            => f2 t e d) s0 init)
    ).
    fcf_inline_first.
    fcf_skip.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    eapply comp_spec_eq_refl.

    eapply comp_spec_eq_symm.
    eapply (@comp_spec_eq_trans _ _ _
      (z <-$
     ([z, z2, s'0] <-$3 (z0 <-$
      c1 (list (DomainRO * RangeRO))
        (list_EqDec
           (pair_EqDec DomainRO_EqDec
              RangeRO_EqDec))
        (sortedRandomFunc DomainRO_EqDec
           RangeRO_EqDec leDom rndRange)
        (sortDom leDom s);
      [z, s']<-2 z0;
      z1 <-$
      c2 (list (DomainRO * RangeRO))
        (list_EqDec
           (pair_EqDec DomainRO_EqDec
              RangeRO_EqDec))
        (sortedRandomFunc DomainRO_EqDec
           RangeRO_EqDec leDom rndRange) s';
      [z2, s'0]<-2 z1;
      ret (z2, z, s'0));

      (c3 z2 z) (list (DomainRO * RangeRO))
        (list_EqDec
           (pair_EqDec DomainRO_EqDec
              RangeRO_EqDec))
        (sortedRandomFunc DomainRO_EqDec
           RangeRO_EqDec leDom rndRange) s'0);
     [t, s0]<-2 z;
     ret fold_left
           (fun (e : E) (d : DomainRO * RangeRO)
            => f2 t e d) s0 init)
    ).
    fcf_inline_first.
    fcf_skip.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    eapply comp_spec_eq_refl.

    eapply comp_spec_seq_eq; trivial.
    eapply comp_spec_seq_eq; trivial.

    intuition idtac.
    intuition idtac.

    eapply comp_spec_eq_symm.
    eapply ExpROM_swap_spec; intuition idtac.
    eapply sortedRandomFunc_swap; intuition idtac.
    intuition idtac.
    eapply comp_spec_eq_refl.
    intuition idtac.
    eapply comp_spec_eq_refl.

    Unshelve.

    eapply oc_EqDec.
    eapply c3; intuition idtac.
    intuition idtac.
    intuition idtac.

    eapply oc_EqDec.
    eapply c3; intuition idtac.
    intuition idtac.
    intuition idtac.

    eapply pair_EqDec.
    eapply oc_EqDec; eauto.
    eapply list_EqDec.
    eapply pair_EqDec; intuition idtac.

    eapply pair_EqDec.
    eapply oc_EqDec; eauto.
    eapply list_EqDec.
    eapply pair_EqDec; eauto.

    eapply pair_EqDec.
    eapply oc_EqDec; eauto.
    eapply list_EqDec.
    eapply pair_EqDec; eauto.

    eapply pair_EqDec.
    eapply oc_EqDec; eauto.
    eapply list_EqDec.
    eapply pair_EqDec; eauto.

    eapply pair_EqDec.
    eapply oc_EqDec; eauto.
    eapply list_EqDec.
    eapply pair_EqDec; eauto.
    eapply oc_EqDec; eauto.
    eapply oc_EqDec; eauto.
  Qed.

End ExperimentROM.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.

Generalizable All Variables.

Inductive TwoDObj : Type := TwoDX | TwoDY.

Inductive TwoDHom : TwoDObj → TwoDObj → Type :=
  | TwoDIdX : TwoDHom TwoDX TwoDX
  | TwoDIdY : TwoDHom TwoDY TwoDY.

Definition TwoDHom_inv_t : ∀ x y, TwoDHom x y → Prop.
Proof.
  intros [] [] f.
  - exact (f = TwoDIdX).
  - exact False.          (* Unused, any Prop is ok here *)
  - exact False.          (* Unused, any Prop is ok here *)
  - exact (f = TwoDIdY).
Defined.

Corollary TwoDHom_inv x y f : TwoDHom_inv_t x y f.
Proof. destruct f; reflexivity. Qed.

Lemma TwoDHom_X_Y_absurd : TwoDHom TwoDX TwoDY → False.
Proof. inversion 1. Qed.

#[export] Hint Extern 4 => contradiction TwoDHom_X_Y_absurd : two_laws.

Lemma TwoDHom_Y_X_absurd : TwoDHom TwoDY TwoDX → False.
Proof. inversion 1. Qed.

#[export] Hint Extern 4 => contradiction TwoDHom_Y_X_absurd : two_laws.

(* The discrete category 2 has two objects and their identity morphisms. *)

Program Definition Two_Discrete : Category := {|
  obj     := TwoDObj;
  hom     := TwoDHom;
  homset  := Morphism_equality;
  id      := fun x => match x with
    | TwoDX => TwoDIdX
    | TwoDY => TwoDIdY
    end;
  compose := fun x y z (f : TwoDHom y z) (g : TwoDHom x y) =>
    match x, y, z with
    | TwoDX, TwoDX, TwoDX => TwoDIdX
    | TwoDY, TwoDY, TwoDY => TwoDIdY
    | _,    _,    _    => _
    end
|}.
Next Obligation. destruct x, y, z; intuition. Qed.
Next Obligation.
  destruct x, y, z; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x, y, z; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x, y, z; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x, y, z; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x, y; auto with two_laws;
  symmetry; exact (TwoDHom_inv _ _ f).
Qed.
Next Obligation.
  destruct x, y; auto with two_laws;
  symmetry; exact (TwoDHom_inv _ _ f).
Qed.
Next Obligation.
  destruct x, y, z, w; auto with two_laws; intuition.
Qed.
Next Obligation.
  destruct x, y, z, w; auto with two_laws; intuition.
Qed.

Program Definition Pick_Two {C : Category} (a b : C) :
  Two_Discrete ⟶ C := {|
  fobj := λ x,
    match x with
    | TwoDX => a
    | TwoDY => b
    end;
  fmap := λ x y _,
    match x, y with
    | TwoDX, TwoDX => id
    | TwoDY, TwoDY => id
    | _,    _      => !
    end
|}.
Next Obligation.
  destruct x, y; auto with two_laws.
Qed.
Next Obligation.
  destruct x, y; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x, y; auto with two_laws;
  intuition; discriminate.
Qed.
Next Obligation.
  destruct x; auto with two_laws; cat.
Qed.
Next Obligation.
  destruct x, y, z; auto with two_laws; cat.
Qed.


Require Export Reals Psatz Fourier.
From discprob.basic Require Export exp_ext.
From discprob.prob Require Export prob countable stochastic_order markov indep bernoulli.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop.
From Coquelicot Require Import Derive Continuity.
From Coquelicot Require AutoDerive.
From Interval Require Import Interval_tactic.

(* See Chapter 4 of Mitzenmacher-Upfal, 2nd edition. *)

Lemma generic_chernoff_upper {A} {Ω: distrib A} (X: rrvar Ω) t a:
  t > 0 →
  ex_Ex (rvar_comp X (λ x, exp (t * x))) →
  pr_ge X a <= Ex (rvar_comp X (λ x, exp (t * x))) / (exp (t * a)).
Proof.
  intros Ht Hex.
  transitivity (pr_ge (rvar_comp X (λ x, exp (t * x))) (exp (t * a))).
  - right. apply pr_eq_pred' => x.
    destruct (Rge_dec) as [Hge|Hnge] => //=.
    * apply Rgt_lt in Ht.
      apply Rge_le in Hge.
      apply (Rmult_le_compat_l t) in Hge; last by nra.
      apply exp_increasing_le in Hge.
      destruct (Rge_dec) as [?|Hnge'] => //=.
      exfalso; apply Hnge'. by apply Rle_ge.
    * destruct (Rge_dec) as [Hge|Hnge'] => //=.
      exfalso. apply Hnge.
      apply Rge_le, exp_le_embedding in Hge.
      apply Rmult_le_reg_l in Hge;  auto.
      by apply Rle_ge.
  - apply markov => //=.
    * intros. apply Rle_ge; left; apply exp_pos.
    * intros. apply Rlt_gt; apply exp_pos.
Qed.

Local Open Scope R_scope.

Lemma chernoff_bernoulli_upper {A} {Ω: distrib A} (lX: list (rrvar Ω)) δ:
  (∀ X, In X lX → ∃ p, is_bernoulli X p) →
  independent lX →
  δ > 0 →
  pr_ge (sum_list_rrvar lX) ((1 + δ) * Ex (sum_list_rrvar lX))
    <= Rpower (exp(δ) / (Rpower (1 + δ) (1 + δ))) (Ex (sum_list_rrvar lX)).
Proof.
  intros Hbern Hindep Hdelta_pos.
  assert (Hext: ∀ a : A,
             (prod_list_rrvar (map (rvar_comp^~ (λ x : R_eqType, exp (ln (1 + δ) * x))) lX)) a =
             (rvar_comp (sum_list_rrvar lX) (λ x : [eqType of R], exp (ln (1 + δ) * x))) a).
  {
    * intros a => //=. induction lX.
      ** rewrite //=. by rewrite Rmult_0_r exp_0.
      ** rewrite //=. rewrite Rmult_plus_distr_l exp_plus. f_equal.
         eapply IHlX.
         *** intros.  eapply Hbern. by right.
         *** eapply independent_tl. eauto.
  }

  assert (Hex_Ex_prod:
            ex_Ex (prod_list_rrvar (map (rvar_comp^~ (λ x : R_eqType, exp (ln (1 + δ) * x))) lX))).
  {
    * apply ex_Ex_indep_prod_list.
      ** by apply indep_fn.
      ** intros ? (X&Heq&Hin)%in_map_iff.
         rewrite -Heq. edestruct (Hbern _ Hin) as (p&His_bern).
         eapply is_bernoulli_ex_Ex; eauto.
  }

  assert (Hpow_pos: 0 < Rpower (1 + δ) (1 + δ)).
  { rewrite /Rpower. apply exp_pos. }

  etransitivity; first eapply generic_chernoff_upper with (t := ln (1 + δ)).
  - rewrite -ln_1. apply Rlt_gt. apply ln_increasing; nra.
  - apply (ex_Ex_ext (prod_list_rrvar (map (λ X, rvar_comp X (λ x, exp (ln (1 + δ) * x))) lX )));
      eauto.
  - rewrite -(Ex_ext _ _ _ Hext) //. rewrite Ex_sum_list; last first.
    { intros ? Hin. edestruct (Hbern _ Hin) as (p&?); eapply is_bernoulli_ex_Ex with (f := id).
      eauto. }
    rewrite Ex_indep_prod_list.
    *
      rewrite /Rdiv -Rpower_mult_distr.
      assert (Hpow_opp': ∀ x y, 0 < x → Rpower (/ x) y = / Rpower x y).
      {
        intros x y.
        rewrite -Rpower_Ropp.
        rewrite /Rpower.
        intros; rewrite ln_Rinv //.
        f_equal. nra.
      }
      rewrite Hpow_opp'.
      rewrite /Rpower.
      assert (exp (ln (1 + δ) * ((1 + δ) * fold_right Rplus 0 (seq.map Ex lX))) =
              exp (fold_right Rplus 0 (seq.map Ex lX) * ln (exp ((1 + δ) * ln (1 + δ)))))
        as ->.
      {
        f_equal. rewrite ln_exp. nra.
      }
      apply Rmult_le_compat_r.
      ** left. apply Rinv_0_lt_compat, exp_pos.
      ** rewrite /Rpower. rewrite fold_right_plus_mult exp_fold_plus.
         rewrite ?seq_ext.map_legacy ?map_map => //=.
         apply fold_right_map_Rmult_le => X Hin.
         destruct (Hbern X Hin) as (p&HXbern).
         rewrite (EGF_is_bernoulli _ p HXbern (ln (1 + δ))).
         rewrite (Ex_is_bernoulli _ p HXbern).
         rewrite exp_ln; last by nra.
         destruct (is_bernoulli_range _ _ HXbern) as (?&?).
         split.
         *** nra.
         *** ring_simplify.
             rewrite ln_exp. rewrite Rplus_comm. apply exp_ineq1_le. nra.
      ** auto.
      ** apply exp_pos.
      ** by apply Rinv_0_lt_compat.
    * by apply indep_fn.
    * intros ? (X&Heq&Hin)%in_map_iff.
      rewrite -Heq. destruct (Hbern _ Hin) as (p&HXbern).
      eapply is_bernoulli_ex_Ex; eauto.
Qed.

Lemma Ex_sum_bernoulli_non_neg {A} {Ω: distrib A} (lX : list (rrvar Ω)):
  (∀ X, In X lX → ∃ p, is_bernoulli X p) →
  0 <= Ex (sum_list_rrvar lX).
Proof.
  intros Hbern. rewrite Ex_sum_list.
  - induction lX as [| X lX]=> //=; first reflexivity.
    destruct (Hbern X) as (p&HXbern); first by left.
    rewrite (Ex_is_bernoulli _ _ HXbern).
    destruct (is_bernoulli_range _ _ HXbern) as (?&?).
    rewrite -[a in a <= _]Rplus_0_r. apply Rplus_le_compat; auto.
    eapply IHlX. intros. apply Hbern. by right.
  - intros X Hin.
    destruct (Hbern X) as (p&HXbern); auto.
    eapply is_bernoulli_ex_Ex with (f := id); eauto.
Qed.

Lemma non_decr_function_le: ∀ (f : R → R) (a b : Rbar) (df : R → R),
       (∀ x : R, Rbar_le a x → Rbar_le x b → is_derive f x (df x))
       → (∀ x : R, Rbar_le a x → Rbar_le x b → df x >= 0)
         → ∀ x y : R, Rbar_le a x → x <= y → Rbar_le y b → f x <= f y.
Proof.
  intros f a b df Hderiv Hderiv_non_neg x y Hrange1 Hrange2 Hrange3.
  edestruct (MVT_gen f x y) as (c&(Hrange1'&Hrange2')&Heq).
  - intros x'. rewrite Rmin_left //= Rmax_right //=. intros [? ?]. eapply Hderiv.
    * eapply Rbar_le_trans; eauto. by rewrite /Rbar_le; left.
    * eapply Rbar_le_trans; eauto. by rewrite /Rbar_le; left.
  - intros x'. rewrite Rmin_left //= Rmax_right //=. intros [? ?].
    assert (continuous f x').
    apply: ex_derive_continuous; eauto.
    econstructor. eapply Hderiv; eauto.
    * eapply Rbar_le_trans; eauto.
    * eapply Rbar_le_trans; eauto. rewrite /Rbar_le; auto.
    * by apply continuity_pt_filterlim.
  - rewrite //= in Heq.
    assert (df c >= 0).
    { apply Hderiv_non_neg.
      * rewrite Rmin_left in Hrange1'; auto. eapply Rbar_le_trans; eauto.
      * rewrite Rmax_right in Hrange2'; auto. eapply Rbar_le_trans; eauto.
        rewrite /Rbar_le //=.
    }
    nra.
Qed.

Lemma chernoff_bernoulli_upper_alt {A} {Ω: distrib A} (lX: list (rrvar Ω)) δ:
  (∀ X, In X lX → ∃ p, is_bernoulli X p) →
  independent lX →
  0 < δ <= 1 →
  pr_ge (sum_list_rrvar lX) ((1 + δ) * Ex (sum_list_rrvar lX))
    <= exp (- Ex (sum_list_rrvar (lX)) * δ^2 / 3).
Proof.
  intros Hbern Hindep Hdelta.
  etransitivity; first eapply chernoff_bernoulli_upper; eauto; try nra; [].
  rewrite /Rpower.
  apply exp_increasing_le.
  rewrite ln_div ?ln_exp.
  - cut (0 <= - (δ - (1 + δ) * ln (1 + δ) + δ^2 / 3) ).
    { intros. specialize (Ex_sum_bernoulli_non_neg _ Hbern) => ?; nra. }
    set (f := λ δ, - (δ - (1 + δ) * ln (1 + δ) + δ^2 / 3)).
    rewrite -/(f δ). transitivity (f 0).
    * right. rewrite /f ?Rplus_0_r ln_1. nra.
    * set (f' := λ δ, - (1 - (1 + δ) / (1 + δ) - ln (1 + δ) + (2 / 3) * δ)).
      set (f'' := λ δ, - (- 1 / (1 + δ) + (2 / 3))).
      apply non_decr_function_le with (a := 0) (b := δ) (df := f').
      ** rewrite /Rbar_le //=. intros x Hr1 Hr2. rewrite /f/f'. AutoDerive.auto_derive; nra.
      ** rewrite /Rbar_le //=. intros x Hr1 Hr2.
         apply Rle_ge.
         assert (x < 1/2 ∨ x = 1/2 ∨ 1/2 < x) as [Hlt|[Heq|Hgt]] by nra.
         {
           transitivity (f' 0).
             { right. rewrite /f'. rewrite Rplus_0_r ln_1. field. }
             apply non_decr_function_le with (a := 0) (b := x) (df := f'').
           *** rewrite /Rbar_le //=. intros x' ??; rewrite /f'/f''. AutoDerive.auto_derive.
               **** repeat split; auto; try nra.
               **** field. nra.
           *** rewrite /Rbar_le //=. intros x' ??; rewrite /f'/f''.
               field_simplify; last by nra.
               apply Rle_ge. replace (0 / 1) with 0 by nra.
               apply Rdiv_le_0_compat; nra.
           *** rewrite //=. reflexivity.
           *** nra.
           *** rewrite //=. reflexivity.
         }
         { rewrite /f'. subst. interval. }
         {
           transitivity (f' 1).
           { rewrite /f'. interval. }
           cut (- f' x <= - f' 1); first by (intros; nra).
           apply non_decr_function_le with (f := λ x, - f' x) (a := 1/2) (b := 3/2) (df := λ x, - f'' x).
           *** rewrite /Rbar_le //=. intros x' ??; rewrite /f'/f''. AutoDerive.auto_derive.
               **** repeat split; auto; try nra.
               **** field. nra.
           *** rewrite /Rbar_le //=. intros x' ??; rewrite /f'/f''.
               field_simplify; last by nra.
               apply Rle_ge. replace (0 / 1) with 0 by nra.
               apply Rdiv_le_0_compat; nra.
           *** rewrite //=.  nra.
           *** nra.
           *** rewrite //=. nra.
         }
      ** rewrite //=. nra.
      ** rewrite //=. nra.
      ** rewrite //=. nra.
  - apply exp_pos.
  - apply exp_pos.
Qed.


Require Export XR_Rdiv.
Require Export XR_Ropp_mult_distr_l.

Local Open Scope R_scope.

Lemma Ropp_div : forall x y,
  -x / y = - (x / y).
Proof.
  intros x y.
  unfold Rdiv.
  rewrite <- Ropp_mult_distr_l.
  reflexivity.
Qed.


Require Import Arith.
Require Import Omega.
Require Import List.

Section Monoid.
Class Monoid(S:Set) : Type := {
  op : S -> S -> S;
  e : S;
  left_id : forall x, op e x = x;
  right_id : forall x, op x e = x;
  assoc : forall x y z, op (op x y) z = op x (op y z)
}.
Notation "a :+: b" := (op a b)
 (left associativity, at level 50).
Instance nat_monoid:Monoid nat:= {
  op := plus;
  e := O
}.
Proof.
(* Proof *)
Defined.

Eval compute in (2 :+: 3).

Class Monad (M:Type -> Type):Type := {
  return' : forall {A}, A -> M A;
  bind : forall {A B}, M A -> (A -> M B) -> M B;
  left_unit : forall A B (a:A)(f:A -> M B), bind (return' a) f = f a;
  right_unit : forall A (ma:M A), bind ma return' = ma;
  associativity : forall A B C (ma:M A)(f:A->M B)(g:B->M C),
    bind (bind ma f) g = bind ma (fun a => bind (f a) g)
}.

Notation "m >>= f" := (bind m f) (left associativity, at level 49).
Notation "'do' a <- e ; c" := (e >>= (fun a => c)) (at level 59, right associativity).

Definition id'(A:Type):Type := A.

Instance Identity : Monad id' := {
 return' A a := a;
 bind A B ma f := f ma
}.
Proof.
(* Proof *)
Defined.

Instance Maybe : Monad option := {
 return' A a := Some a;
 bind A B ma f :=
   match ma with
   | None => None
   | Some a => f a
   end
}.
Proof.
(* Proof *)
Defined.

Eval compute in (None >>= (fun x => Some (x + 1))).
Eval compute in (Some 1 >>= (fun x => Some (x + 1))).

Require Import List.

Lemma flat_map_app : forall (A B:Type)(xs ys:list A)(f:A -> list B),
 flat_map f (xs++ys) = flat_map f xs ++ flat_map f ys.
Proof.
induction xs.
 simpl. auto.
simpl. intros. erewrite IHxs. erewrite app_ass. auto.
Qed.

Instance List : Monad list := {
  return' A x := x :: nil;
  bind A B m f := flat_map f m
}.
Proof.
  intros A B a f. simpl. erewrite <- app_nil_end. auto.
 intros A m. induction m.
  simpl. auto.
 simpl. rewrite IHm. auto.
intros A B C m f g. induction m.
 simpl. auto.
simpl. rewrite <- IHm.
erewrite flat_map_app. auto.
Defined.

Class MonadPlus (M:Type -> Type) : Type := {
 (* MonadPlus is Monad *)
  monad :> Monad M ;
 (* field *)
  mzero : forall A, M A;
  mplus : forall A, M A -> M A -> M A;
 (* axiom *)
  mzero_left : forall A f, bind (@mzero A) f = (@mzero A);
  mzero_right : forall A B (ma:M A), bind ma (fun x => (@mzero B)) = (@mzero B);
  monoid_left_unit : forall A (ma:M A), mplus _ (@mzero A) ma = ma;
  monoid_right_unit : forall A (ma:M A), mplus _ ma (@mzero A) = ma;
  monoid_assoc : forall A (ma mb mc:M A), mplus _ (mplus _ ma mb) mc = mplus _ ma (mplus _ mb mc)
}.

Instance MaybePlus : MonadPlus option := {
 monad := Maybe;
 mzero A := @None A;
 mplus A m1 m2 :=
   match m1 with
   | None => m2
   | Some x => m1
   end
}.
Proof.
(* Proof *)
Defined.

Instance ListPlus : MonadPlus list := {
 monad := List;
 mzero A := @nil A;
 mplus A m1 m2 := m1 ++ m2
}.
Proof.
(* Proof. app_nil_end and app_ass are useful. *)
Defined.

Require Import Logic.FunctionalExtensionality.

Definition cont (R A:Type):Type := (A->R)->R.

Instance Cont R : Monad (cont R) := {
 return' A a := fun k:A->R => k a;
 bind A B m f := fun k:B->R => m (fun a => f a k)
}.
Proof.
  intros A B a f. unfold cont in *.
  erewrite <- eta_expansion.  reflexivity.
 intros A ma.  unfold cont in *.
 erewrite eta_expansion.  extensionality x.
 erewrite <- eta_expansion.  auto.
intros A B C ma f g.  reflexivity.
Defined.


Require Export A_6_2.

Module A6_3.

(* 定义：数列前n项和 *)
Fixpoint Σ (x : Seq) (n : nat) :=
  match n with
  | 0%nat => x[0%nat]
  | S n => Σ x n + x[S n]
  end.

(* 定义: 阶乘 *)
Fixpoint factorial (n : nat) :=
  match n with
  | 0%nat => 1%nat
  | S n => ((S n) * factorial n)%nat
  end.

Notation "n !" := (factorial n)(at level 10).

Lemma Lemma6_3_1 : ∀ n, (0 < n!)%nat.
Proof.
  intros n. induction n as [|n IHn].
  - simpl. apply Nat.lt_0_1.
  - simpl. apply Nat.add_pos_l.
    assumption.
Qed.

Lemma Lemma6_3_2 : ∀ n, n! = mult_NM n n.
Proof.
  intros n. induction n as [|n IHn].
  - simpl. reflexivity.
  - simpl. rewrite <- IHn.
    reflexivity.
Qed.

Lemma Lemma6_3_3 : ∀ n, (S n)! = mult_NM (S n) n.
Proof.
  intros n. induction n as [|n IHn].
  - simpl. reflexivity.
  - assert (H0 : ((S (S n)) ! =
      (S (S n)) * (S n)!)%nat).
    { simpl. reflexivity. }
    rewrite H0.
    assert (H1 : (mult_NM (S (S n)) (S n) =
      (S (S n)) * mult_NM (S n) n)%nat).
    { simpl. reflexivity. }
    rewrite H1. rewrite <- IHn.
    reflexivity.
Qed.

Lemma Lemma6_3_4 : ∀ n, (0 < n)%nat -> 0^^n = 0.
Proof.
  intros n H0. destruct n as [|n].
  - apply Nat.lt_irrefl in H0. contradiction.
  - simpl. field.
Qed.

Lemma Lemma6_3_5 : ∀ x n, x <> 0 -> x^^n <> 0.
Proof.
  intros x n. induction n as [|n IHn].
  - intros H0. simpl. lra.
  - intros H0. apply IHn in H0 as H1. simpl.
    apply Rmult_integral_contrapositive_currified; auto.
Qed.

(* 泰勒公式 *)
Theorem Theorem6_9 : ∀ (f : Fun) (n : nat) (x0 : R),
  (0 < n)%nat -> Function f -> x0 ∈ dom[dN f n] ->
    (∃ (o : Fun), InfinitesimalHigherOrder
      o {` λ x y, y = (x - x0)^^n `} x0 /\
      (∀ (x : R), f[x] =
      (Σ {` λ k v, v = (dN f k)[x0] /
      (INR (k!)) * (x - x0)^^k `} n) + o[x])).
Proof.
  intros f n x0 H0 H1 H2.
  assert (H3 : ∃ Rn, Rn = λ m, {` λ x y,
    y = f[x] - (Σ {` λ k v, v = (dN f k)[x0] /
      (INR (k!)) * (x - x0)^^k `} m) `}).
  { exists (λ m, {` λ x y, y =
    f[x] - (Σ {` λ k v, v = (dN f k)[x0] /
      (INR (k!)) * (x - x0)^^k `} m) `}).
    reflexivity. }
  destruct H3 as [Rn H3].
  exists (Rn n). assert (H4 : ∀ m, Function (Rn m)).
  { intros m. rewrite H3. intros x y z I1 I2.
    applyAxiomII' I1; applyAxiomII' I2.
    rewrite I2; assumption. }
  assert (H5 : ∀ x m, (Rn m)[x] = f[x] -
    (Σ {` λ k v, v = (dN f k)[x0] /
    (INR (k!)) * (x - x0)^^k `} m)).
  { intros x m. apply f_x; auto.
    rewrite H3. apply AxiomII'.
    reflexivity. }
  assert (H6 : ∀ x x0, Function
    {` λ k v, v = (dN f k) [x0]
    / INR (k !) * (x - x0)^^k `}).
  { intros x x2 x1 y1 z1 I1 I2.
    applyAxiomII' I1; applyAxiomII' I2.
    rewrite I2; assumption. }
  assert (H7 : ∀ x x0 k,
    {` λ k v, v = (dN f k) [x0]
    / INR (k !) * (x - x0)^^k `}[k]
    = (dN f k) [x0] / INR (k !) * (x - x0)^^k).
  { intros x x1 k.
    apply f_x; try apply H6.
    apply AxiomII'. reflexivity. }
  assert (H8 : ∀ m x, (Rn (S m))[x] =
    (Rn m)[x] - (dN f (S m)) [x0] /
    INR ((S m) !) * (x - x0) ^^ (S m)).
  { intros m x.
    rewrite H5. rewrite H5.
    simpl Σ. rewrite H7.
    field. apply not_0_INR.
    apply not_eq_sym. apply lt_0_neq.
    apply Lemma6_3_1. }
  assert (H9 : ∀ k, x0 ∈ dom[dN (Rn k) n]).
  { intros k. induction k as [|k IHk].
    - rewrite H3. assert (I1 : {` λ x y,
        y = f [x] - Σ {` λ k v,
        v = (dN f k) [x0] / INR (k !)
        * (x - x0) ^^ k `} 0 `} =
        {` λ x y, y = f[x] - {` λ x1 y1,
        y1 = f[x0] `}[x] `}).
      { apply AxiomI; intros [x y];
        split; intro I1;
        applyAxiomII' I1; apply AxiomII'.
        - rewrite H7 in I1. simpl in I1.
          rewrite Lemma5_11. simpl.
          rewrite I1. field.
        - simpl. rewrite H7.
          rewrite Lemma5_11 in I1.
          simpl. rewrite I1. field. }
      rewrite I1. clear I1.
      apply AxiomII. exists ((dN f n)[x0] -
        (dN {` λ x1 y1, y1 = f[x0] `} n)[x0]).
      apply Lemma5_13; auto. apply AxiomII.
      exists 0. rewrite Lemma5_14.
      apply AxiomII'. reflexivity. assumption.
    - assert (I1 : Rn (S k) =
        {` λ x y, y = (Rn k)[x] -
        {` λ x1 y1, y1 = (dN f (S k)) [x0]
        / INR ((S k) !) * (x1 - x0) ^^ S k
        `}[x] `}).
      { apply AxiomI. intros [x y].
        split; intro I1.
        - apply AxiomII'.
          apply f_x in I1; auto.
          rewrite <- I1. rewrite Lemma4'.
          apply H8.
        - apply -> AxiomII' in I1.
          lazy beta in I1.
          rewrite Lemma4' in I1.
          rewrite <- H8 in I1.
          rewrite I1. apply x_fx; auto.
          apply AxiomII. rewrite H3.
          exists (f[x] - Σ {` λ k0 v,
            v = (dN f k0) [x0] / INR (k0 !)
            * (x - x0) ^^ k0 `} (S k)).
          apply AxiomII'. reflexivity. }
      rewrite I1. clear I1. apply AxiomII.
      exists ((dN (Rn k) n)[x0] - (dN {` λ x1 y1,
        y1 = (dN f (S k)) [x0] / INR ((S k) !)
        * (x1 - x0) ^^ S k`} n)[x0]).
      apply Lemma5_13; auto.
      destruct (Nat.le_gt_cases n (S k))
        as [I1 | I1].
      + rewrite Lemma5_7; auto.
        apply AxiomII. exists ((dN f (S k)) [x0]
          / INR ((S k) !) * INR (mult_NM (S k) n)
          * (x0 - x0) ^^ (S k - n)).
        apply AxiomII'. reflexivity.
      + rewrite Lemma5_7'; auto. apply AxiomII.
        exists 0. apply AxiomII'. reflexivity. }
  assert (H10 : ∀ k, Function {` λ x y,
      y = Σ {` λ k1 v, v = (dN f k1)[x0] /
      (INR (k1!)) * (x - x0)^^k1 `} k `}).
  { intros k. intros x y z I1 I2.
    applyAxiomII' I1; applyAxiomII' I2.
    rewrite I2; assumption. }
  assert (H11 : ∀ k x, {` λ x y, y =
    Σ {` λ k1 v, v = (dN f k1)[x0] /
    (INR (k1!)) * (x - x0)^^k1 `} k `} [x]
    = Σ {` λ k1 v, v = (dN f k1)[x0] /
    (INR (k1!)) * (x - x0)^^k1 `} k).
  { intros k x. apply f_x;
    try apply H10.
    apply AxiomII'. reflexivity. }
  assert (H12 : ∀ x k m, (k < m)%nat ->
      [x, 0] ∈ (dN ({` λ x1 y1,
      y1 = Σ {` λ k1 v, v = (dN f k1)[x0] /
      (INR (k1!)) * (x1 - x0)^^k1 `} k `}) m)).
  { intros x k m. induction k as [|k IHk].
    - intros I1. simpl.
      assert (I2 : {` λ x y, y = {` λ k1 v,
        v = (dN f k1) [x0] / INR (k1 !)
        * (x - x0) ^^ k1 `}[0%nat] `} =
        {` λ x y, y = f[x0] `}).
      { apply AxiomI; intros [x1 y1];
        split; intro J1;
        applyAxiomII' J1; apply AxiomII'.
        - rewrite J1. rewrite H7.
          simpl. field.
        - rewrite H7. simpl. rewrite J1.
          field. }
      rewrite I2. clear I2.
      rewrite Lemma5_14; [apply AxiomII' | assumption].
      reflexivity.
    - intros I1. assert (I2 : {` λ x1 y1,
        y1 = Σ {` λ k1 v, v = (dN f k1) [x0]
        / INR (k1 !) * (x1 - x0) ^^ k1 `} (S k) `}
        = {` λ x2 y2, y2 = {` λ x1 y1,
        y1 = Σ {` λ k1 v, v = (dN f k1) [x0]
        / INR (k1 !) * (x1 - x0) ^^ k1 `} k `}[x2]
        + {` λ x1 y1, y1 = (dN f (S k)) [x0]
        / INR ((S k) !) * (x1 - x0) ^^ (S k) `}[x2]
        `} ).
      { apply AxiomI; intros [x1 y1];
        split; intro J1.
        - applyAxiomII' J1; apply AxiomII'.
          rewrite H11. rewrite Lemma4'.
          rewrite H7 in J1. assumption.
        - apply -> AxiomII' in J1.
          lazy beta in J1. apply AxiomII'.
          simpl. rewrite H7. rewrite H11 in J1.
          rewrite Lemma4' in J1.
          assumption. }
      rewrite I2. clear I2. assert (I2 : (k < m)%nat).
      { apply Nat.lt_succ_l; assumption. }
      apply IHk in I2 as I3.
      assert (I4 : (0 < m)%nat).
      { apply (Nat.lt_lt_0 k). assumption. }
      apply f_x in I3 as I5; try apply Lemma5_15; auto.
      assert (I6 : (dN {` λ x1 y1, y1 =
        (dN f (S k)) [x0] / INR ((S k) !)
        * (x1 - x0) ^^ (S k) `} m)[x] = 0).
      { apply f_x.
        - apply Lemma5_15; assumption.
        - rewrite Lemma5_7'; auto.
          apply AxiomII'. reflexivity. }
      assert (I7 : 0 = (dN {` λ x2 y2,
      y2 = Σ {` λ k1 v, v = (dN f k1) [x0]
      / INR (k1 !) * (x2 - x0) ^^ k1 `}
      k `} m) [x] + (dN {` λ x1 y1, y1 =
        (dN f (S k)) [x0] / INR ((S k) !)
        * (x1 - x0) ^^ (S k) `} m)[x]).
      { rewrite I5. rewrite I6. field. }
      rewrite I7. apply Lemma5_13'.
      + apply AxiomII. exists 0.
        assumption.
      + apply AxiomII. exists 0.
        rewrite Lemma5_7'; auto.
        apply AxiomII'. reflexivity. }
  assert (H13 : ∀ x k, [x, (dN f k)[x0]] ∈
      (dN ({` λ x y,
      y = Σ {` λ k1 v, v = (dN f k1)[x0] /
      (INR (k1!)) * (x - x0)^^k1 `} k `}) k)).
  { intros x k. destruct k as [|k].
    - simpl. apply AxiomII'.
      rewrite H7. simpl. field.
    - assert (I1 : {` λ x y, y = Σ {` λ k1 v,
        v = (dN f k1) [x0] / INR (k1 !)
        * (x - x0) ^^ k1 `} (S k) `} =
        {` λ x y, y = {` λ x1 y1, y1 =
          Σ {` λ k1 v,
          v = (dN f k1) [x0] / INR (k1 !)
          * (x1 - x0) ^^ k1 `} k `}[x] +
        {` λ x1 y1, y1 = (dN f (S k)) [x0]
          / INR ((S k) !) * (x1 - x0) ^^ (S k) `}[x]
        `}).
      { apply AxiomI. intros [x1 y1].
        split; intros J1.
        - applyAxiomII' J1. apply AxiomII'.
          rewrite H11. rewrite Lemma4'.
          rewrite H7 in J1. assumption.
        - apply -> AxiomII' in J1.
          lazy beta in J1. apply AxiomII'.
          simpl. rewrite H7. rewrite H11 in J1.
          rewrite Lemma4' in J1.
          assumption. }
      rewrite I1. clear I1.
      assert (I1 : (k < S k)%nat).
      { apply Nat.lt_succ_diag_r. }
      apply (H12 x) in I1.
      assert (I2 : [x, (dN f (S k)) [x0]]
          ∈ dN {` λ x y, y = (dN f (S k)) [x0]
          / INR ((S k) !) * (x - x0) ^^ (S k)
          `} (S k)).
      { rewrite Lemma5_7; try apply le_n.
        apply AxiomII'. rewrite <- Lemma6_3_2.
        rewrite Nat.sub_diag. simpl pow.
        field. apply not_0_INR.
        apply not_eq_sym. apply lt_0_neq.
        apply Lemma6_3_1. }
      assert (I3 : (dN f (S k)) [x0] = (dN {` λ x y,y =
        Σ {` λ k1 v, v = (dN f k1) [x0] / INR (k1 !)
        * (x - x0) ^^ k1 `} k `} (S k))[x] +
        (dN {` λ x y, y = (dN f (S k)) [x0]
        / INR ((S k) !) * (x - x0) ^^ S k `}
        (S k))[x]).
      { generalize (Nat.lt_0_succ k). intros J1.
        apply f_x in I1; try apply Lemma5_15; auto.
        apply f_x in I2; try apply Lemma5_15; auto.
        rewrite I1; rewrite I2. field. }
      pattern ((dN f (S k)) [x0]) at 1.
      rewrite I3. apply Lemma5_13'.
      + apply AxiomII. exists 0. assumption.
      + apply AxiomII. exists ((dN f (S k)) [x0]).
        assumption. }
  assert (H14 : ∀ k, (k <= n)%nat ->
    [x0, 0] ∈ (dN (Rn k) k)).
  { intros k I0. assert (I1 : Rn k = {` λ x y,
      y = f[x] - {` λ x1 y1, y1 = Σ {` λ k1 v,
      v = (dN f k1) [x0] / INR (k1 !) *
      (x1 - x0) ^^ k1 `} k `}[x] `}).
    { rewrite H3. apply AxiomI;
      intros [x y]; split; intro J1;
      applyAxiomII' J1; apply AxiomII'.
      - rewrite H11. assumption.
      - rewrite H11 in J1. assumption. }
    rewrite I1. clear I1.
    assert (I1 : x0 ∈ dom[ dN f k]).
    { apply le_lt_or_eq in I0 as [I0 | I0].
      - apply Lemma5_6 with (k := k)
          in H2 as J1; auto.
        destruct J1 as [δ [J1 J2]].
        apply J2. apply AxiomII.
        apply Abs_R; lra.
      - rewrite I0; assumption. }
    assert (I2 : Function (dN f k)).
    { apply Lemma5_16. assumption. }
    apply x_fx in I1 as I3; auto.
    generalize (H13 x0 k); intros I4.
    assert (I5 : 0 = (dN f k)[x0] -
      (dN {` λ x1 y1, y1 = Σ {` λ k1 v,
      v = (dN f k1) [x0] / INR (k1 !) *
      (x1 - x0) ^^ k1 `} k `} k)[x0]).
    { apply f_x in I4.
      - rewrite I4. field.
      - apply Lemma5_16. auto. }
    rewrite I5. apply Lemma5_13; auto.
    apply AxiomII. exists ((dN f k) [x0]).
    assumption. }
  assert (H15 : ∀ k, (k <= n)%nat ->
    [x0, 0] ∈ (dN (Rn n) k)).
  { clear H0.
    induction n as [|n IHn].
    - intros k I1. apply le_n_0_eq in I1.
      rewrite <- I1. simpl. rewrite H3.
      apply AxiomII'. simpl. rewrite H7.
      simpl. field.
    - intros k I1. assert (I2 : x0 ∈ dom[ dN f n]).
      { apply Lemma5_6 with (k := n) in H2 as J1.
        destruct J1 as [δ [J1 J2]]. apply J2.
        - apply AxiomII. apply Abs_R. lra.
        - apply Nat.lt_succ_diag_r. }
      assert (I3 : ∀k : nat,x0 ∈ dom[ dN (Rn k) n]).
      { intros m. generalize (H9 m); intros J1.
        apply Lemma5_6 with (k := n) in J1 as J2.
        destruct J2 as [δ [J2 J3]].
        - apply J3. apply AxiomII.
          apply Abs_R. lra.
        - apply Nat.lt_succ_diag_r. }
      assert (I4 : (∀ k, (k <= n)%nat ->
        [x0, 0] ∈ dN (Rn k) k)).
      { intros k0 J1. apply H14.
        apply le_S. assumption. }
      generalize (IHn I2 I3 I4); intros I5.
      apply Nat.le_succ_r in I1 as [I1 | I1].
      + generalize (I5 k I1); intros I6.
        assert (I7 : Rn (S n) = {` λ x y, y =
          (Rn n)[x] - {` λ x1 y1, y1 =
          (dN f (S n)) [x0] / INR ((S n) !)
          * (x1 - x0) ^^ S n `}[x] `}).
        { apply AxiomI; intros [x y];
          split; intro J1.
          - apply AxiomII'.
            apply f_x in J1; try apply H4.
            rewrite <- J1. rewrite Lemma4'.
            apply H8.
          - apply -> AxiomII' in J1.
            lazy beta in J1. rewrite Lemma4' in J1.
            rewrite <- H8 in J1.
            rewrite J1. apply x_fx; auto.
            apply AxiomII. rewrite H3.
            exists (f[x] - Σ {` λ k0 v, v =
              (dN f k0) [x0] / INR (k0 !) *
              (x - x0) ^^ k0 `} (S n)).
            apply AxiomII'. reflexivity. }
        rewrite I7. clear I7.
        assert (I7 : [x0, 0] ∈ dN {` λ x y, y =
          (dN f (S n)) [x0] / INR ((S n) !)
          * (x - x0) ^^ S n`} k).
        { rewrite Lemma5_7;
          try apply le_S; auto.
          apply AxiomII'.
          assert (I7 : x0 - x0 = 0). lra.
          rewrite I7. clear I7.
          assert (I8 : ∀ m, (0 < m)%nat -> 0^^m = 0).
          { intros m. induction m as [|m IHm].
            - intros J1. apply Nat.lt_irrefl in J1.
              contradiction.
            - intros J1. apply lt_n_Sm_le in J1 as J2.
              apply le_lt_or_eq in J2 as [J2 | J2].
              + apply IHm in J2. simpl. field.
              + rewrite <- J2. simpl. field. }
          assert (I9 : (0 < S n - k)%nat).
          { apply ArithProp.lt_minus_O_lt.
            apply le_lt_n_Sm. assumption. }
          rewrite I8; auto. field. apply not_0_INR.
          apply not_eq_sym. apply lt_0_neq.
          apply Lemma6_3_1. }
        assert (I8 : 0 = 0 - 0). lra.
        rewrite I8. apply Lemma5_18; auto.
        apply Lemma3'.
      + rewrite I1. apply H14.
        apply le_n. }
  assert (H16 : ∀ k, (S k - k = 1)%nat).
  { intros k. rewrite Nat.sub_succ_l.
    - rewrite Nat.sub_diag.
      reflexivity.
    - apply le_n. }
  assert (H17 : ∀ x k, (0 < k)%nat ->
    [x, (dN f (k-1))[x0] + (dN f k)[x0] * (x-x0)]
      ∈ (dN {` λ x y,
      y = Σ {` λ k1 v, v = (dN f k1)[x0] /
      (INR (k1!)) * (x - x0)^^k1 `} k `} (k-1))).
  { intros x k I1. destruct k as [|k].
    - apply Nat.lt_irrefl in I1.
      contradiction.
    - simpl minus. rewrite Nat.sub_0_r.
      assert (I2 : {` λ x y,
        y = Σ {` λ k1 v, v = (dN f k1)[x0] /
        (INR (k1!)) * (x - x0)^^k1 `} (S k) `} =
        {` λ x y, y = {` λ x1 y1,
        y1 = Σ {` λ k1 v, v = (dN f k1)[x0] /
        (INR (k1!)) * (x1 - x0)^^k1 `} k `}[x]
        + {` λ x1 y1, y1 = (dN f (S k))[x0] /
        (INR ((S k)!)) * (x1 - x0)^^(S k) `}[x] `}).
      { apply AxiomI; intros [x1 y1];
        split; intro J1.
        - applyAxiomII' J1; apply AxiomII'.
          rewrite H7 in J1. rewrite H11.
          rewrite Lemma4'. assumption.
        - apply -> AxiomII' in J1.
          lazy beta in J1. apply AxiomII'.
          simpl. rewrite H7.
          rewrite H11 in J1.
          rewrite Lemma4' in J1.
          assumption. }
      rewrite I2. clear I2.
      generalize (H13 x k); intros I2.
      assert (I3 : [x, (dN f (S k))[x0] * (x - x0)]
        ∈ dN {` λ x y, y = (dN f (S k))[x0] /
        (INR ((S k)!)) * (x - x0)^^(S k) `} k).
      { rewrite Lemma5_7;
        try apply (Nat.le_succ_diag_r k).
        apply AxiomII'.
        rewrite H16. rewrite <- Lemma6_3_3.
        simpl pow. field. apply not_0_INR.
        apply not_eq_sym.
        apply lt_0_neq. apply Lemma6_3_1. }
      apply Lemma5_18'; auto. apply Lemma3'. }
  assert (H18 : ∃ δ, 0 < δ /\ (∀ x, x ∈ Neighbor x0 δ
    -> (dN (Rn n) (n-1))[x] = (dN f (n-1))[x] -
    (dN f (n-1))[x0] - (dN f n)[x0] * (x - x0))).
  { generalize (Lemma5_6' f x0 n H2).
    intros [δ [I1 I2]].
    exists δ. split; [apply I1 | intros x I3].
    destruct n as [|n].
    - apply Nat.lt_irrefl in H0.
      contradiction.
    - simpl minus. rewrite Nat.sub_0_r.
      assert (I4 : [x, (dN f n)[x]] ∈
        dN f n).
      { apply x_fx.
        - apply Lemma5_16. assumption.
        - apply I2; auto. }
      generalize (H17 x (S n) H0).
      intros I5. simpl minus in I5.
      rewrite Nat.sub_0_r in I5.
      assert (I6 : Rn (S n) = {` λ x y,
        y = f[x] - {` λ x1 y1, y1 = Σ {` λ k v,
        v = (dN f k) [x0] / INR (k !) *
        (x1 - x0) ^^ k `} (S n) `}[x] `}).
      { rewrite H3. apply AxiomI;
        intros [x1 y1]; split; intro J1.
        - applyAxiomII' J1; apply AxiomII'.
          rewrite H11. assumption.
        - apply -> AxiomII' in J1;
          lazy beta in J1.
          apply AxiomII'. rewrite H11 in J1.
          assumption. }
      apply f_x.
      + apply Lemma5_16. apply H4.
      + assert (J1 : (dN f n)[x] - (dN f n)[x0]
          - (dN f (S n))[x0] * (x - x0) =
          (dN f n)[x] - ((dN f n)[x0]
          + (dN f (S n))[x0] * (x - x0))).
        field. rewrite J1. rewrite I6.
        apply Lemma5_18; auto. }
  destruct H18 as [δ1 [H18 H19]].
  assert (H20 : ∀ k, (k < n-1)%nat ->
    limit (dN (Rn n) k) x0 0 /\
    limit (dN {` λ x y, y = (x - x0)^^n `} k) x0 0).
  { intros k I1.
    assert (I2 : (S k <= n)%nat).
    { destruct n as [|n].
      - simpl in I1. apply Nat.nlt_0_r in I1.
        contradiction.
      - simpl in I1. rewrite Nat.sub_0_r in I1.
        apply Peano.le_n_S.
        apply Nat.lt_le_incl.
        assumption. }
    apply le_Sn_le in I2 as I3.
    split.
    - apply H15 in I2 as I4.
      simpl in I4. applyAxiomII' I4.
      assert (I5 : derivable (dN (Rn n) k) x0).
      { exists 0. assumption. }
      apply Theorem5_1 in I5 as [I6 I7].
      apply H15 in I3 as I8.
      apply f_x in I8.
      + rewrite I8 in I7. assumption.
      + apply Lemma5_16. auto.
    - rewrite Lemma5_7_1; auto.
      generalize (Lemma7' x0 (INR (mult_NM n k))
        x0 (n - k)).
      intros I4.
      assert (I5 : (INR (mult_NM n k) *
        (x0 - x0) ^^ (n - k)) = 0).
      { assert (J1 : x0 - x0 = 0). lra.
        rewrite J1. assert (J2 : (0 < n - k)%nat).
        { apply ArithProp.lt_minus_O_lt.
          apply le_S_gt. assumption. }
        rewrite Lemma6_3_4; auto.
        field. }
      rewrite I5 in I4.
      assumption. }
  assert (H21 : ∀ k, (0 < k <= n-1)%nat ->
    (∃ δ', δ' > 0 /\ Neighbor0 x0 δ' ⊂
    dom[dN (Rn n) k] /\ Neighbor0 x0 δ' ⊂
    dom[dN {` λ x y, y = (x - x0)^^n `} k] /\
    (∀ x, x ∈ Neighbor0 x0 δ' ->
    (dN {` λ x y, y = (x - x0)^^n `} k)[x] <> 0))).
  { intros k I1. assert (I2 : (k < n)%nat).
    { destruct n as [|n].
      - apply Nat.lt_irrefl in H0.
        contradiction.
      - simpl in I1. rewrite Nat.sub_0_r in I1.
        apply le_lt_n_Sm. apply I1. }
    generalize (Lemma5_6 (Rn n) x0 n (H9 n) k I2).
    intros [δ [I3 I4]]. exists δ.
    apply Nat.lt_le_incl in I2 as I5.
    repeat split; auto.
    - intros x J1. apply I4.
      applyAxiomII J1. apply AxiomII.
      apply J1.
    - rewrite Lemma5_7_1; auto.
      intros x J1. apply AxiomII.
      exists (INR (mult_NM n k) *
        (x - x0) ^^ (n - k)).
      apply AxiomII'. reflexivity.
    - intros x J1. rewrite Lemma5_7_1; auto.
      rewrite Lemma4'.
      apply Rmult_integral_contrapositive_currified.
      + apply not_0_INR. apply mult_NM_ne_0.
      + apply Lemma6_3_5. applyAxiomII J1.
        apply Lemma2 in J1. apply J1. }
  assert (H22 : limit {` λ x y, y = (dN (Rn n) (n-1))[x]
    / (dN {` λ x y, y = (x - x0)^^n `} (n-1))[x] `} x0 0).
  { assert (I1 : (n - 1 <= n)%nat).
    { destruct n as [|n].
      - simpl. apply le_n.
      - simpl. rewrite Nat.sub_0_r.
        apply Nat.le_succ_diag_r. }
    rewrite Lemma5_7_1; auto.
    assert (I2 : {` λ x y, y = (dN (Rn n) (n - 1)) [x]
      / {` λ x1 y0, y0 = INR (mult_NM n (n - 1)) *
      (x1 - x0) ^^ (n - (n - 1))`} [x] `} =
      {` λ x y, y = (dN (Rn n) (n - 1)) [x] /
        (INR (n!) * (x - x0)) `}).
    { assert (K1 :(n - (n - 1) = 1)%nat /\
          (mult_NM n (n - 1) = n!)%nat).
      { destruct n as [|n].
        - apply Nat.lt_irrefl in H0.
          contradiction.
        - assert (L1 : (S n - 1 = n)%nat).
          { simpl. apply Nat.sub_0_r. }
          split.
          + rewrite L1. apply H16.
          + rewrite L1. rewrite Lemma6_3_3.
            reflexivity. }
      destruct K1 as [K1 K2].
      apply AxiomI; intros [x y];
      split; intro J1;
      applyAxiomII' J1; apply AxiomII'.
      - rewrite Lemma4' in J1.
        rewrite K1 in J1.
        rewrite K2 in J1.
        simpl in J1.
        assert (K3 : (x - x0) * 1 = x - x0).
        field. rewrite K3 in J1.
        assumption.
      - rewrite K1; rewrite K2.
        rewrite Lemma4'. simpl.
        assert (K3 : (x - x0) * 1 = x - x0).
        field. rewrite K3.
        assumption. }
    rewrite I2. clear I2.
    assert (I2 : Function {` λ x y, y =
      (dN (Rn n) (n - 1)) [x] /
      (INR (n!) * (x - x0)) `}).
    { intros x y z J1 J2.
      applyAxiomII' J1; applyAxiomII' J2.
      rewrite J2; assumption. }
    split; auto.
    assert (I3 : (n = S (n - 1))%nat).
    { destruct n as [|n].
      - apply Nat.lt_irrefl in H0.
        contradiction.
      - assert (J1 : (S n - 1 = n)%nat).
        { simpl. apply Nat.sub_0_r. }
        rewrite J1. reflexivity. }
    assert (I4 : Function (dN f n)).
    { apply Lemma5_16; assumption. }
    apply x_fx in H2; auto.
    pattern n at 2 in H2.
    rewrite I3 in H2. simpl dN in H2.
    apply -> AxiomII' in H2.
    lazy beta in H2. unfold derivative in H2.
    destruct H2 as [I5 [[δ1' [I6 I7]] I8]].
    unfold limit in I8.
    destruct I8 as [I8 [δ' [I9 [I10 I11]]]].
    exists δ'. split; [assumption | split].
    - intros x J1. apply AxiomII.
      exists ((dN (Rn n) (n - 1)) [x] /
        (INR (n !) * (x - x0))).
      apply AxiomII'. reflexivity.
    - intros ε J1. generalize (I11 ε J1).
      intros [δ2 [[J2 J3] J4]].
      generalize (Lemma1 δ1 δ2 H18 J2).
      intros [δ [J5 [J6 J7]]].
      exists δ. split; [lra | intros x J8].
      assert (J9 :∀ x, {` λ x1 y, y =
        (dN (Rn n) (n - 1)) [x1] /
        (INR (n !) * (x1 - x0))`} [x] =
        (dN (Rn n) (n - 1)) [x] /
        (INR (n !) * (x - x0))).
      { intros t. apply f_x; auto.
        apply AxiomII'. reflexivity. }
      rewrite J9.
      assert (J10 : x ∈ Neighbor x0 δ1).
      { apply AxiomII. lra. }
      assert (J11 : 0 < Abs [x - x0] < δ2). lra.
      generalize (H19 x J10).
      intros J12. rewrite J12.
      generalize (J4 x J11).
      intros J13.
      assert (J14 : {` λ x y, y =
        ((dN f (n - 1)) [x] - (dN f (n - 1)) [x0])
        / (x - x0) `} [x] =
        ((dN f (n - 1)) [x] - (dN f (n - 1)) [x0])
        / (x - x0)).
      { apply f_x.
        - intros x1 y1 z1 K1 K2.
          applyAxiomII' K1; applyAxiomII' K2.
          rewrite K2; assumption.
        - apply AxiomII'. reflexivity. }
      rewrite J14 in J13. clear J14.
      assert (J14 : ∀ k,  1 <= INR (k!)).
      { intros k. assert (K1 : 1 = INR 1%nat).
        { simpl. reflexivity. }
        rewrite K1. apply le_INR.
        induction k as [|k IHk].
        - simpl. apply le_n.
        - simpl. apply le_plus_trans.
          assumption. }
      assert (J15 : 0 < INR (n !)).
      { apply lt_0_INR. apply Lemma6_3_1. }
      assert (J16 : INR (n !) <> 0).
      { apply not_eq_sym.
        apply Rlt_not_eq. auto. }
      assert (J17 : ((dN f (n - 1)) [x] -
        (dN f (n - 1)) [x0] - (dN f n) [x0]
        * (x - x0)) / (INR (n !) * (x - x0))
        - 0 = (((dN f (n - 1)) [x] -
        (dN f (n - 1)) [x0]) / (x - x0)
        - (dN f n) [x0]) / (INR (n !))).
      { field. split; auto.
        - apply Lemma2 in J8. apply J8. }
      rewrite J17. clear J17.
      rewrite Abs_div; auto.
      rewrite (Abs_gt (INR (n!))); auto.
      apply Rmult_lt_reg_r with (r := INR (n !)); auto.
      assert (J17 : Abs [((dN f (n - 1)) [x] -
        (dN f (n - 1)) [x0]) / (x - x0) -
        (dN f n) [x0]] / INR (n !) * INR (n !) =
        Abs [((dN f (n - 1)) [x] -
        (dN f (n - 1)) [x0]) / (x - x0) -
        (dN f n) [x0]]).
      { field. assumption. }
      rewrite J17. clear J17.
      assert (J17 : ε <= ε * INR (n !)).
      { pattern ε at 1. rewrite <- Rmult_1_r.
        apply Rmult_le_compat_l; auto. lra. }
      lra. }
  generalize (Lemma6_1 (Rn n) {` λ x y,
    y = (x - x0)^^n `} x0 0 (n-1) H20 H21 H22).
  intros H23. split.
  - unfold InfinitesimalHigherOrder.
    split; [auto | split];
    [apply Lemma3 | split]; auto.
    exists 1. split; [lra | repeat split].
    + intros x I1. rewrite H3. apply AxiomII.
      exists (f[x] - Σ {` λ k v, v =
        (dN f k)[x0] / INR (k !)
        * (x - x0) ^^ k`} n).
      apply AxiomII'. reflexivity.
    + intros x I1. apply AxiomII.
      exists ((x - x0) ^^ n).
      apply AxiomII'. reflexivity.
    + intros x I1. rewrite Lemma4.
      apply Lemma6_3_5. applyAxiomII I1.
      apply Lemma2 in I1.
      apply I1.
  - intros x. rewrite H5.
    field.
Qed.

End A6_3.

Export A6_3.