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

Require Export ZFC.Elements.EST8_7.
Import OrdinalClass 𝐎𝐍Operation.

Local Hint Resolve
  add_ran mul_ran exp_ran
  ordAdd_ran ordMul_ran preOrdExp_ran ordExp_ran : core.

(** 左迭代幂次 **)
(* see also LargeOrdinals/NormalTetration.v *)
Definition OrdTetL := λ α, Operation α (OrdExp α).
Notation "α ^^ᴸ β" := (OrdTetL α β) (at level 25) : OrdArith_scope.

Theorem ordTetL_0 : ∀α ⋵ 𝐎𝐍, α ^^ᴸ 0 = α.
Proof. intros α H. apply operation_0; auto. Qed.

Theorem ordTetL_suc : ∀ α β ⋵ 𝐎𝐍, α ^^ᴸ β⁺ = α ^ (α ^^ᴸ β).
Proof. intros α Hα β Hβ. apply operation_suc; auto. Qed.

Theorem ordTetL_limit : ∀α ⋵ 𝐎𝐍, continuous (OrdTetL α).
Proof. intros α Hα. apply operation_limit; auto. Qed.

Theorem ordTetL_ran : ∀ α β ⋵ 𝐎𝐍, α ^^ᴸ β ⋵ 𝐎𝐍.
Proof. intros α Hα β Hβ. apply operation_operative; auto. Qed.
Local Hint Resolve ordTetL_ran : core.

Theorem ordTetL_1_r : ∀α ⋵ 𝐎𝐍, α ^^ᴸ 1 = α ^ α.
Proof.
  intros α H. rewrite pred, ordTetL_suc, ordTetL_0; auto.
Qed.

Theorem ordTetL_1_l : ∀α ⋵ 𝐎𝐍, 1 ^^ᴸ α = 1.
Proof with neauto.
  ord_induction. intros α Hα IH.
  ord_destruct α.
  - subst. rewrite ordTetL_0...
  - destruct Hsuc as [β [Hβ Heq]]. subst.
    rewrite ordTetL_suc, ordExp_1_l...
  - rewrite ordTetL_limit... ext.
    + apply FUnionE in H as [β [Hβ H]]. rewrite IH in H...
    + rewrite one in H. apply SingE in H. subst.
      eapply FUnionI. apply ord_neq_0_gt_0...
      rewrite ordTetL_0, pred...
Qed.

Lemma ordTetL_eq_0 : ∀ α β ⋵ 𝐎𝐍, α ^^ᴸ β = 0 → α = 0.
Proof with eauto.
  intros α Hα. ord_induction. intros β Hβ IH H.
  ord_destruct β.
  - subst. rewrite ordTetL_0 in H...
  - destruct Hsuc as [γ [Hγ Heq]]. subst.
    rewrite ordTetL_suc in H...
    apply ordExp_eq_0 in H...
  - rewrite ordTetL_limit in H...
    apply union_eq_empty in H as [].
    + apply repl_eq_empty in H. exfalso...
    + apply EmptyNE in H0 as [γ Hγ].
      assert (Hoγ: γ ⋵ 𝐎𝐍). eapply ord_is_ords...
      apply sucord_in_limord in Hγ...
      eapply repl_eq_1 in Hγ as H0...
Qed.

Lemma ordAdd_eq_1 : ∀ α β ⋵ 𝐎𝐍, α + β = 1 →
  α = 0 ∧ β = 1 ∨ α = 1 ∧ β = 0.
Proof with neauto.
  intros α Hα β Hβ H.
  ord_destruct α; subst.
  - rewrite ordAdd_0_l in H...
  - destruct Hsuc as [γ [Hγ Heq]]. subst.
    ord_destruct β.
    + subst. rewrite ordAdd_0_r in H...
    + exfalso. destruct Hsuc as [δ [Hδ Heq]]. subst.
      rewrite <- (ordAdd_1_r δ), <- ordAdd_assoc in H...
      rewrite (ordAdd_1_r), pred in H...
      apply ord_suc_injective in H...
      apply ordAdd_eq_0 in H as []... eapply suc_neq_0...
    + exfalso. apply limord_ge_ω in Hlim...
      apply (ord_irrefl 1)... rewrite <- H at 2.
      eapply ord_trans_lt_le. auto. apply embed_ran.
      eapply ord_trans_le... apply ordAdd_enlarge_l...
  - exfalso.
    destruct (classic (β = 0)). {
      subst. rewrite ordAdd_0_r in H...
      apply (limord_iff_not_sucord α)... exists 0...
    }
    apply limord_ge_ω in Hlim...
    apply (ord_irrefl 1)... rewrite <- H at 2.
    eapply ord_trans. auto. apply embed_ran.
    eapply ord_trans_le_lt... apply ordAdd_enlarge_r...
Qed.

Lemma ordMul_eq_1 : ∀ α β ⋵ 𝐎𝐍, α ⋅ β = 1 → α = 1 ∧ β = 1.
Proof with neauto.
  intros α Hα β Hβ H. ord_destruct β.
  - subst. rewrite ordMul_0_r in H... exfalso...
  - destruct Hsuc as [γ [Hγ Heq]]. subst.
    rewrite ordMul_suc in H...
    apply ordAdd_eq_1 in H as [[H0 H1]|[H1 H0]]...
    + apply ordMul_eq_0 in H0 as []...
      * exfalso. subst...
      * split... subst...
    + rewrite H0 in H1. rewrite ordMul_0_l in H1... exfalso...
  - exfalso.
    destruct (classic (α = 0)). subst. rewrite ordMul_0_l in H...
    destruct (classic (α = 1)). {
      subst. rewrite ordMul_1_l in H...
      apply (limord_iff_not_sucord β)... exists 0...
    }
    apply limord_ge_ω in Hlim...
    apply (ord_irrefl 1)... rewrite <- H at 2.
    eapply ord_trans_lt_le. auto. apply embed_ran.
    eapply ord_trans_le... apply ordMul_enlarge_l...
Qed.

Lemma preOrdExp_eq_1 : ∀ α β ⋵ 𝐎𝐍, α ^ᵖ β = 1 →
  α = 1 ∨ β = 0 ∨ β ≠ 0 ∧ β ⋵ 𝐎𝐍ˡⁱᵐ ∧ α = 0.
Proof with neauto.
  intros α Hα β Hβ H. ord_destruct β...
  - destruct Hsuc as [γ [Hγ Heq]]. subst.
    rewrite preOrdExp_suc in H...
    apply ordMul_eq_1 in H as []...
  - destruct (classic (α = 0))...
    destruct (classic (α = 1))...
    exfalso. apply limord_ge_ω in Hlim...
    apply (ord_irrefl 1)... rewrite <- H at 2.
    eapply ord_trans_lt_le. auto. apply embed_ran.
    eapply ord_trans_le... apply preOrdExp_enlarge_l...
Qed.

Lemma ordExp_eq_1 : ∀ α β ⋵ 𝐎𝐍, α ^ β = 1 → α = 1 ∨ β = 0.
Proof with neauto.
  intros α Hα β Hβ H. ord_destruct β.
  - subst. rewrite ordExp_0_r in H...
  - destruct Hsuc as [γ [Hγ Heq]]. subst.
    rewrite ordExp_suc in H...
    apply ordMul_eq_1 in H as []...
  - destruct (classic (α = 1))...
    exfalso. unfold OrdExp in H.
    destruct (ixm (α = 0)); destruct (ixm (β = 0))...
    apply limord_ge_ω in Hlim...
    apply (ord_irrefl 1)... rewrite <- H at 2.
    eapply ord_trans_lt_le. auto.
    apply embed_ran. eapply ord_trans_le...
    apply preOrdExp_enlarge_l...
Qed.

Lemma ordTetL_gt_1 : ∀ α β ⋵ 𝐎𝐍, 1 ∈ α → 1 ∈ α ^^ᴸ β.
Proof with neauto.
  intros α Hα. ord_induction. intros β Hβ IH Hα1.
  ord_destruct β.
  - subst. rewrite ordTetL_0...
  - destruct Hsuc as [γ [Hγ Heq]]. subst.
    rewrite ordTetL_suc... eapply ord_trans...
    apply ordExp_enlarge_r...
  - rewrite ordTetL_limit...
    apply EmptyNE in H0 as [γ Hγ].
    assert (Hoγ: γ ⋵ 𝐎𝐍). eapply ord_is_ords...
    eapply FUnionI. apply sucord_in_limord...
    eapply ord_trans_lt_le. auto. apply IH...
    rewrite ordTetL_suc... apply ordExp_enlarge_l...
Qed.

Theorem ordTetL_eq_1 : ∀ α β ⋵ 𝐎𝐍, α ^^ᴸ β = 1 → α = 0 ∨ α = 1.
Proof with neauto.
  intros α Hα β Hβ H.
  destruct (classic (α = 0))...
  destruct (classic (α = 1))... exfalso.
  apply (ord_irrefl 1)... rewrite <- H at 2.
  apply ordTetL_gt_1...
Qed.

Fact ordTetL_is_limord_l : ∀α ⋵ 𝐎𝐍, ∀𝜆 ⋵ 𝐎𝐍ˡⁱᵐ, 𝜆 ≠ 0 → 𝜆 ^^ᴸ α ⋵ 𝐎𝐍ˡⁱᵐ.
Proof with nauto.
  ord_induction. intros α Hα IH 𝜆 H𝜆 H0.
  ord_destruct α.
  - subst. rewrite ordTetL_0...
  - destruct Hsuc as [β [Hβ Heq]]. subst.
    rewrite ordTetL_suc... apply ordExp_is_limord_l...
    apply ordTetL_gt_1... eapply ord_trans_lt_le. auto.
    apply embed_ran. apply limord_ge_ω...
  - rewrite ordTetL_limit...
    apply union_of_limords_is_limord. intros x Hx.
    apply ReplAx in Hx as [β [Hβ Hx]]. subst x. apply IH...
Qed.

Lemma tetL_ran : ∀ m n ∈ ω, m ^^ᴸ n ∈ ω.
Proof with auto.
  intros k Hk n Hn. ω_induction n.
  - rewrite ordTetL_0...
  - rewrite ordTetL_suc, fin_ordExp_eq_exp...
Qed.
Local Hint Resolve tetL_ran : core.

Lemma tetL_preserve_base_lt : ∀ m n p ∈ ω, m ≠ 0 → n ≠ 0 →
  m ∈ n ↔ m ^^ᴸ p ∈ n ^^ᴸ p.
Proof with eauto.
  assert (Hright: ∀ m n p ∈ ω, m ≠ 0 → n ≠ 0 → m ∈ n → m ^^ᴸ p ∈ n ^^ᴸ p). {
    intros m Hm n Hn p Hp Hm0 Hn0 H.
    generalize dependent n. generalize dependent m.
    ω_induction p; intros k Hk Hk0 n Hn Hn0 H.
    - rewrite ordTetL_0, ordTetL_0...
    - assert (Hmp: m⁺ ∈ ω). apply ω_inductive...
      assert (H0: k ^^ᴸ m ≠ 0). intros H0. apply ordTetL_eq_0 in H0...
      rewrite ordTetL_suc, ordTetL_suc...
      repeat rewrite fin_ordExp_eq_exp...
      eapply lt_le_trans. auto.
      apply exp_preserve_base_lt; revgoals...
      apply exp_preserve_exponent_le...
  }
  intros m Hm n Hn p Hp Hm0 Hn0. split. apply Hright...
  intros H. destruct (classic (m = n)).
  - subst. exfalso. eapply nat_irrefl; revgoals...
  - apply nat_connected in H0 as []...
    pose proof (Hright n Hn m Hm p Hp Hn0 Hm0 H0).
    exfalso. eapply nat_not_lt_gt; revgoals...
Qed.

Lemma tetL_enlarge_l : ∀ m n ∈ ω, 1 ∈ n → m ∈ n ^^ᴸ m.
Proof with neauto.
  intros k Hk. ω_induction k; intros n Hn Hn0.
  - rewrite ordTetL_0... apply ord_neq_0_gt_0...
    apply ord_gt_1_neq_0_1...
  - rewrite ordTetL_suc... pose proof (IH n Hn Hn0).
    apply lt_iff_suc_le in H...
    eapply ord_trans_le_lt. auto. apply H.
    rewrite fin_ordExp_eq_exp... apply exp_enlarge_l...
Qed.

Fact ordTetL_2_ω : 2 ^^ᴸ ω = ω.
Proof with neauto.
  ext.
  - rewrite ordTetL_limit in H...
    apply FUnionE in H as [k [Hk Hx]]. eapply ω_trans...
  - rewrite ordTetL_limit... eapply FUnionI...
    apply tetL_enlarge_l... rewrite (pred 2)...
Qed.

Theorem ordTetL_n_ascending : ∀α ⋵ 𝐎𝐍, 1 ∈ α → ∀n ∈ ω, α ^^ᴸ n ∈ α ^^ᴸ n⁺.
Proof with neauto.
  intros α Hα Hα1 n Hn. ω_induction n.
  - rewrite ordTetL_suc, <- zero, ordTetL_0... apply ordExp_enlarge_r...
  - rewrite ordTetL_suc, ordTetL_suc... apply ordExp_preserve_lt...
Qed.

Theorem ordTetL_n_monotone : ∀α ⋵ 𝐎𝐍, 1 ∈ α → ∀n ∈ ω, ∀m ∈ n, α ^^ᴸ m ∈ α ^^ᴸ n.
Proof with eauto.
  intros α Hα Hα1 n Hn. ω_induction n; intros k Hlt.
  - exfalso0.
  - assert (Hk: k ∈ ω). eapply ω_trans... apply ω_inductive...
    apply le_iff_lt_suc in Hlt as []...
    + eapply ord_trans. auto. apply IH...
      apply ordTetL_n_ascending...
    + subst. apply ordTetL_n_ascending...
Qed.

Theorem ordTetL_weakly_increasing : ∀ α β γ ⋵ 𝐎𝐍, α ≠ 0 → β ∈ γ → α ^^ᴸ β ⋸ α ^^ᴸ γ.
Proof with eauto.
  intros α Hα β Hβ. ord_induction. intros γ Hγ IH Hα0 Hlt.
  destruct (classic (α = 1)) as [|Hα1]. {
    subst. rewrite ordTetL_1_l, ordTetL_1_l...
  }
  ord_destruct γ.
  - subst. exfalso0.
  - destruct Hsuc as [δ [Hδ H]]. subst.
    apply ord_le_iff_lt_suc in Hlt as []...
    + rewrite ordTetL_suc... eapply ord_trans_le; revgoals. 3: auto.
      apply ordExp_preserve_le_r; revgoals. apply IH... 1-4: auto.
      apply ordExp_enlarge_l...
    + subst. rewrite ordTetL_suc... apply ordExp_enlarge_l...
  - apply ord_le_iff_sub... intros x Hx.
    rewrite ordTetL_limit... eapply FUnionI...
Qed.

Corollary ordTetL_enlarge_r : ∀ α β ⋵ 𝐎𝐍, 1 ∈ α → β ≠ 0 → α ∈ α ^^ᴸ β.
Proof with neauto.
  intros α Hα β Hβ Hα1 Hβ0.
  destruct (classic (β = 1)). {
    subst. rewrite ordTetL_1_r... apply ordExp_enlarge_r...
  }
  eapply (ord_trans_lt_le _ (α ^ α))... apply ordExp_enlarge_r...
  rewrite <- ordTetL_1_r... apply ordTetL_weakly_increasing...
  apply ord_gt_1_neq_0_1...
Qed.

Lemma ordTetL_exp_r_le_l : ∀α ⋵ 𝐎𝐍, 1 ∈ α →
  ∀n ∈ ω, n ≠ 0 → α ^^ᴸ n ^ α ⋸ α ^ α ^^ᴸ n.
Proof with nauto.
  intros α Hα Hα1 n Hn.
  ω_induction n; intros Hn0. exfalso...
  rewrite ordTetL_suc, ordExp_mul...
  apply ordExp_preserve_le_r...
  assert (Hα2: Embed 2 ⋸ α). apply ord_suc_correct...
  destruct (classic (m = 0)) as [|Hm0]. {
    subst. rewrite ordTetL_0, <- ordExp_2_r...
    apply ordExp_preserve_le_r...
  }
  assert (Ht0: α ^^ᴸ m ≠ 0). {
    intros H. apply ordTetL_eq_0 in H... subst. exfalso0.
  }
  assert (Ht1: α ^^ᴸ m ≠ 1). {
    intros H. apply ord_gt_1_neq_0_1 in Hα1 as []...
    apply ordTetL_eq_1 in H as []...
  }
  eapply ord_trans_le; revgoals. apply IH... 2: auto.
  eapply ord_trans_le. auto. left. apply ordMul_preserve_lt; revgoals.
  apply (ordTetL_enlarge_r α Hα m)... 1-4: auto.
  rewrite <- ordExp_2_r... apply ordExp_preserve_le_r...
Qed.

Lemma ordTetL_exp_r_lt_l : ∀α ⋵ 𝐎𝐍, 2 ∈ α →
  ∀n ∈ ω, n ≠ 0 → α ^^ᴸ n ^ α ∈ α ^ α ^^ᴸ n.
Proof with nauto.
  intros α Hα Hα2 n Hn.
  assert (Hα1: 1 ∈ α). {
    eapply ord_trans. auto. apply suc_has_n. apply Hα2.
  }
  ω_induction n; intros Hn0. exfalso...
  rewrite ordTetL_suc, ordExp_mul...
  apply ordExp_preserve_lt...
  destruct (classic (m = 0)) as [|Hm0]. {
    subst. rewrite ordTetL_0, <- ordExp_2_r...
    apply ordExp_preserve_lt...
  }
  assert (Ht0: α ^^ᴸ m ≠ 0). {
    intros H. apply ordTetL_eq_0 in H... subst. exfalso0.
  }
  assert (Ht1: α ^^ᴸ m ≠ 1). {
    intros H. apply ord_gt_1_neq_0_1 in Hα1 as []...
    apply ordTetL_eq_1 in H as []...
  }
  eapply ord_trans; revgoals. apply IH... 2: auto.
  eapply ord_trans. auto. apply ordMul_preserve_lt; revgoals.
  apply (ordTetL_enlarge_r α Hα m)... 1-4: auto.
  rewrite <- ordExp_2_r... apply ordExp_preserve_lt...
Qed.

(** 右迭代幂次 **)
Definition OrdTetR := λ α, Operation α (λ ξ, ξ ^ α).
Notation "α ^^ᴿ β" := (OrdTetR α β) (at level 25) : OrdArith_scope.

Theorem ordTetR_0 : ∀α ⋵ 𝐎𝐍, α ^^ᴿ 0 = α.
Proof. intros α H. apply operation_0; auto. Qed.

Theorem ordTetR_suc : ∀ α β ⋵ 𝐎𝐍, α ^^ᴿ β⁺ = (α ^^ᴿ β) ^ α.
Proof. intros α Hα β Hβ. apply operation_suc; auto. Qed.

Theorem ordTetR_limit : ∀α ⋵ 𝐎𝐍, continuous (OrdTetR α).
Proof. intros α Hα. apply operation_limit; auto. Qed.

Theorem ordTetR_ran : ∀ α β ⋵ 𝐎𝐍, α ^^ᴿ β ⋵ 𝐎𝐍.
Proof. intros α Hα β Hβ. apply operation_operative; auto. Qed.
Local Hint Resolve ordTetR_ran : core.

Theorem ordTetR_1_r : ∀α ⋵ 𝐎𝐍, α ^^ᴿ 1 = α ^ α.
Proof.
  intros α H. rewrite pred, ordTetR_suc, ordTetR_0; auto.
Qed.

Theorem ordTetR_1_l : ∀α ⋵ 𝐎𝐍, 1 ^^ᴿ α = 1.
Proof with neauto.
  ord_induction. intros α Hα IH.
  ord_destruct α.
  - subst. rewrite ordTetR_0...
  - destruct Hsuc as [β [Hβ Heq]]. subst.
    rewrite ordTetR_suc, ordExp_1_r...
  - rewrite ordTetR_limit... ext.
    + apply FUnionE in H as [β [Hβ H]]. rewrite IH in H...
    + rewrite one in H. apply SingE in H. subst.
      eapply FUnionI. apply ord_neq_0_gt_0...
      rewrite ordTetR_0, pred...
Qed.

Fact ordTetR_n_le_L : ∀α ⋵ 𝐎𝐍, α ≠ 0 → ∀n ∈ ω, n ≠ 0 → α ^^ᴿ n ⋸ α ^^ᴸ n.
Proof with nauto.
  intros α Hα Hα0 n Hn.
  ω_induction n; intros Hn0. exfalso...
  destruct (classic (α = 1)) as [|Hα1]. {
    subst. rewrite ordTetL_1_l, ordTetR_1_l...
  }
  destruct (classic (m = 0)) as [|Hm0]. {
    subst. rewrite ordTetL_1_r, ordTetR_1_r...
  }
  rewrite ordTetL_suc, ordTetR_suc...
  eapply ord_trans_le. auto.
  apply ordExp_preserve_le_l; revgoals.
  apply IH... 1-3: auto. apply ordTetL_exp_r_le_l...
Qed.

Fact ordTetR_n_lt_L : ∀α ⋵ 𝐎𝐍, 2 ∈ α → ∀n ∈ ω, 1 ∈ n → α ^^ᴿ n ∈ α ^^ᴸ n.
Proof with nauto.
  intros α Hα Hα2 n Hn.
  assert (Hα1: 1 ∈ α). {
    eapply ord_trans. auto. apply suc_has_n. apply Hα2.
  }
  ω_induction n; intros Hn1. exfalso0.
  apply ord_le_iff_lt_suc in Hn1 as []...
  - rewrite ordTetL_suc, ordTetR_suc...
    eapply ord_trans_le_lt. auto.
    apply ordExp_preserve_le_l; revgoals.
    left. apply IH... 1-3: auto.
    apply ordTetL_exp_r_lt_l... apply ord_gt_1_neq_0_1...
  - subst. rewrite ordTetL_suc, ordTetR_suc...
    rewrite ordTetL_1_r, ordTetR_1_r, ordExp_mul...
    apply ordExp_preserve_lt...
    rewrite <- ordExp_2_r... apply ordExp_preserve_lt...
Qed.

Fact ordTetR_normal_form : ∀ α β ⋵ 𝐎𝐍, α ≠ 0 → α ^^ᴿ β = α ^ α ^ β.
Proof with eauto.
  intros α Hα. ord_induction. intros β Hβ IH Hα0.
  destruct (classic (α = 1)) as [|Hα1]. {
    subst. rewrite ordTetR_1_l, ordExp_1_l...
  }
  ord_destruct β.
  - subst. rewrite ordTetR_0, ordExp_0_r, ordExp_1_r...
  - destruct Hsuc as [γ [Hγ H]]. subst.
    rewrite ordTetR_suc, IH, ordExp_mul, ordExp_suc...
  - rewrite ordTetR_limit, ordExp_limit...
    2: apply ordExp_is_limord_r...
    2: intros H; apply ordExp_eq_0 in H...
    ext.
    + apply FUnionE in H as [γ [Hγ H]].
      assert (Hoγ: γ ⋵ 𝐎𝐍). apply (ord_is_ords β)...
      rewrite IH in H... eapply FUnionI...
      apply ordExp_preserve_lt...
    + apply FUnionE in H as [γ [Hγ Hx]].
      assert (Hoγ: γ ⋵ 𝐎𝐍). apply (ord_is_ords (α ^ β))...
      rewrite ordExp_limit in Hγ...
      apply FUnionE in Hγ as [δ [Hδ Hγ]].
      assert (Hoδ: δ ⋵ 𝐎𝐍). apply (ord_is_ords β)...
      eapply FUnionI... rewrite IH...
      eapply ord_trans... apply ordExp_preserve_lt...
Qed.

(** 指定首项迭代幂次 **)
(* α ^ α ^ ... ^ α ^ ι *)
Definition OrdTet0 := λ α β ι, Operation ι (OrdExp α) β.
Notation "α ^^⁰ β" := (OrdTet0 α β) (at level 25) : OrdArith_scope.

Theorem ordTet0_0 : ∀ ι α ⋵ 𝐎𝐍, (α ^^⁰ 0) ι = ι.
Proof. intros ι Hι α Hα. apply operation_0; auto. Qed.

Theorem ordTet0_suc : ∀ ι α β ⋵ 𝐎𝐍, (α ^^⁰ β⁺) ι = α ^ (α ^^⁰ β) ι.
Proof. intros ι Hι α Hα β Hβ. apply operation_suc; auto. Qed.

Theorem ordTet0_limit : ∀ ι α ⋵ 𝐎𝐍, continuous (λ β, (α ^^⁰ β) ι).
Proof. intros ι Hι α Hα. apply operation_limit; auto. Qed.

Theorem ordTet0_ran : ∀ ι α β ⋵ 𝐎𝐍, (α ^^⁰ β) ι ⋵ 𝐎𝐍.
Proof. intros ι Hι α Hα β Hβ. apply operation_operative; auto. Qed.
Local Hint Resolve ordTet0_ran : core.

Theorem ordTet0_1 : ∀ ι α ⋵ 𝐎𝐍, (α ^^⁰ 1) ι = α ^ ι.
Proof.
  intros ι Hι α Hα. rewrite pred, ordTet0_suc, ordTet0_0; auto.
Qed.

Lemma ordTet0_lt_ordTetL_n : ∀ ξ ι ⋵ 𝐎𝐍, 1 ∈ ξ → ι ∈ ξ → ∀n ∈ ω, (ξ ^^⁰ n) ι ∈ ξ ^^ᴸ n.
Proof with nauto.
  intros ξ Hξ ι Hι Hξ1 Hιξ n Hn.
  ω_induction n.
  - rewrite ordTet0_0, ordTetL_0...
  - rewrite ordTet0_suc, ordTetL_suc...
    apply ordExp_preserve_lt...
Qed.

Lemma ordTet0_gt_ordTetL_n : ∀ ξ ι ⋵ 𝐎𝐍, 1 ∈ ι → ι ∈ ξ → ∀n ∈ ω, ξ ^^ᴸ n ∈ (ξ ^^⁰ n⁺) ι.
Proof with neauto.
  intros ξ Hξ ι Hι Hι1 Hιξ n Hn.
  ω_induction n.
  - rewrite ordTet0_1, ordTetL_0...
    apply ordExp_enlarge_r... eapply ord_trans...
  - rewrite ordTet0_suc, ordTetL_suc...
    apply ordExp_preserve_lt... eapply ord_trans...
Qed.

Lemma ordTet0_eq_ordTetL_ω : ∀ ξ ι ⋵ 𝐎𝐍, 1 ∈ ι → ι ∈ ξ → (ξ ^^⁰ ω) ι = ξ ^^ᴸ ω.
Proof with neauto.
  intros ξ Hξ ι Hι Hι1 Hιξ.
  rewrite ordTet0_limit, ordTetL_limit...
  ext; apply FUnionE in H as [n [Hn H]].
  - eapply FUnionI... eapply ord_trans...
    apply ordTet0_lt_ordTetL_n... eapply ord_trans...
  - apply (FUnionI _ _ n⁺). apply ω_inductive...
    eapply ord_trans... apply ordTet0_gt_ordTetL_n...
Qed.

(** 无限结合律，左侧严格放大 **)

Lemma ordAdd_arbitrary_assoc : ∀α ⋵ 𝐎𝐍, ∀n ∈ ω, α + α ⋅ n = α ⋅ n + α.
Proof with auto.
  intros α Hα n Hn. ω_induction n.
  - rewrite ordMul_0_r, ordAdd_0_r, ordAdd_0_l...
  - rewrite ordMul_suc... rewrite <- IH at 2... rewrite ordAdd_assoc...
Qed.

Lemma ordAdd_enlarge_l_strictly : ∀α ⋵ 𝐎𝐍, ∀n ∈ ω, ∀β ∈ α ⋅ n, β ∈ α + β.
Proof with neauto; try congruence.
  intros α Hα n Hn. ω_induction n; intros β Hβ.
  - rewrite <- zero, ordMul_0_r in Hβ... exfalso0.
  - destruct (classic (β ∈ α ⋅ m)). apply IH...
    assert (Hoβ: β ⋵ 𝐎𝐍). apply (ord_is_ords (α ⋅ m⁺))...
    rewrite ordMul_suc, <- ordAdd_arbitrary_assoc in Hβ...
    apply ord_le_iff_not_gt in H as []...
    apply (ordAdd_preserve_lt α) in H... eapply ord_trans...
Qed.

Lemma ordMul_arbitrary_assoc : ∀α ⋵ 𝐎𝐍, ∀n ∈ ω, α ⋅ α ^ n = α ^ n ⋅ α.
Proof with auto.
  intros α Hα n Hn. ω_induction n.
  - rewrite ordExp_0_r, ordMul_1_r, ordMul_1_l...
  - rewrite ordExp_suc... rewrite <- IH at 2... rewrite ordMul_assoc...
Qed.

Lemma ordMul_enlarge_l_strictly : ∀α ⋵ 𝐎𝐍, ∀n ∈ ω, ∀β ∈ α ^ n, β ≠ 0 → β ∈ α ⋅ β.
Proof with neauto; try congruence.
  intros α Hα n Hn β Hβ Hβ0.
  destruct (classic (α = 0)) as [|Hα0]. {
    subst. destruct (classic (n = 0)). {
      subst. rewrite ordExp_0_r in Hβ...
      rewrite one in Hβ. apply SingE in Hβ. exfalso...
    }
    rewrite ordExp_0_l in Hβ... exfalso0.
  }
  generalize dependent β.
  ω_induction n; intros β Hβ Hβ0.
  - rewrite <- zero, ordExp_0_r in Hβ...
    rewrite one in Hβ. apply SingE in Hβ. exfalso...
  - destruct (classic (β ∈ α ^ m)). apply IH...
    assert (Hoβ: β ⋵ 𝐎𝐍). apply (ord_is_ords (α ^ m⁺))...
    rewrite ordExp_suc, <- ordMul_arbitrary_assoc in Hβ...
    apply ord_le_iff_not_gt in H as []...
    apply (ordMul_preserve_lt α) in H... eapply ord_trans...
Qed.

Lemma ordExp_enlarge_l_strictly : ∀α ⋵ 𝐎𝐍, 1 ∈ α → ∀n ∈ ω, ∀β ∈ α ^^ᴸ n, β ∈ α ^ β.
Proof with neauto; try congruence.
  intros α Hα Hα1 n Hn. ω_induction n; intros x Hx.
  - destruct (classic (x = 0)). {
      subst. rewrite ordExp_0_r, pred, pred...
    }
    rewrite <- zero, ordTetL_0 in Hx...
    apply ordExp_enlarge_lt... 1-2: eapply ord_is_ords...
  - destruct (classic (x ∈ α ^^ᴸ m)). apply IH...
    assert (Hox: x ⋵ 𝐎𝐍). apply (ord_is_ords (α ^^ᴸ m⁺))...
    rewrite ordTetL_suc in Hx...
    apply ord_le_iff_not_gt in H as []...
    apply (ordExp_preserve_lt α) in H... eapply ord_trans...
Qed.

(** 吸收律 **)

(* Those α that ω ⋸ α are all fixed points for n_addition.
  Please see also LargeOrdinal/LowerFixedPoint.v *)
Theorem ordAdd_1_absorption : ∀α ⋵ 𝐎𝐍, ω ⋸ α → 1 + α = α.
Proof with neauto.
  ord_induction. intros α Hα IH Hle.
  destruct Hle; revgoals. {
    subst. apply ordAdd_1_ω.
  }
  ord_destruct α.
  - subst. exfalso0.
  - destruct Hsuc as [β [Hβ Heq]]. subst.
    rewrite ordAdd_suc, IH... apply ord_le_iff_lt_suc...
  - rewrite ordAdd_limit... ext ξ Hξ.
    + apply FUnionE in Hξ as [β [Hβ Hξ]].
      destruct (classic (β ∈ ω)).
      * eapply ord_trans... rewrite ordAdd_1_l...
        apply sucord_in_limord...
      * rewrite IH in Hξ... eapply ord_trans...
        apply ord_le_iff_not_gt... eapply ord_is_ords...
    + assert (Hξo: ξ ⋵ 𝐎𝐍). eapply ord_is_ords...
      destruct (classic (ξ ∈ ω)) as [|Hle].
      * eapply FUnionI... rewrite ordAdd_1_l...
      * apply ord_le_iff_not_gt in Hle...
        eapply FUnionI. apply sucord_in_limord...
        rewrite ordAdd_suc, IH...
Qed.

Corollary ordAdd_n_absorption : ∀α ⋵ 𝐎𝐍, ∀n ∈ ω, ω ⋸ α → n + α = α.
Proof with neauto.
  intros α Hα n Hn Hle.
  ω_induction n. rewrite ordAdd_0_l...
  rewrite <- ordAdd_1_r, ordAdd_assoc, ordAdd_1_absorption...
Qed.

(* ω幂对加法的吸收律 *)
Corollary ordAdd_ω_pow_absorption : ∀β ⋵ 𝐎𝐍, ∀α ∈ β, ω ^ α + ω ^ β = ω ^ β.
Proof with neauto.
  intros β Hβ α Hlt. assert (α ⋸ β)...
  assert (Hα: α ⋵ 𝐎𝐍). eapply ord_is_ords...
  apply ord_subtraction in H as [δ [[Hδ Hsum] _]]... subst.
  rewrite <- ordExp_add... rewrite <- (ordMul_1_r (ω ^ α)) at 1...
  rewrite <- ordMul_distr... f_equal. apply ordAdd_1_absorption...
  rewrite <- ordExp_1_r at 1 3... apply ordExp_preserve_le_r...
  apply ord_le_iff_not_gt... intros H.
  rewrite one in H. apply SingE in H. subst.
  rewrite ordAdd_0_r in Hlt... eapply ord_irrefl...
Qed.

Theorem ordMul_n_ω : ∀n ∈ ω, n ≠ 0 → n ⋅ ω = ω.
Proof with neauto.
  intros n Hn. ω_induction n; intros H0. exfalso...
  assert (Hmp: m⁺ ∈ ω). apply ω_inductive...
  ext.
  - rewrite ordMul_limit in H...
    apply FUnionE in H as [k [Hk Hx]].
    eapply ω_trans... rewrite fin_ordMul_eq_mul...
  - destruct (classic (m = 0)).
    + subst. rewrite ordMul_1_l...
    + rewrite <- IH, ordMul_limit in H... rewrite ordMul_limit...
      apply FUnionE in H as [k [Hk Hx]].
      eapply FUnionI... eapply ord_trans...
      rewrite fin_ordMul_eq_mul, fin_ordMul_eq_mul...
      apply mul_preserve_lt... intros H. subst.
      rewrite ordMul_0_r in Hx... exfalso0.
Qed.

Theorem ordExp_n_ω : ∀n ∈ ω, 1 ∈ n → n ^ ω = ω.
Proof with neauto.
  intros n Hn. ω_induction n; intros H1. exfalso0.
  assert (Hmp: m⁺ ∈ ω). apply ω_inductive...
  ext.
  - rewrite ordExp_limit in H...
    apply FUnionE in H as [k [Hk Hx]].
    eapply ω_trans... rewrite fin_ordExp_eq_exp...
  - destruct (classic (x = 0)) as [|Hx0]. {
      subst. apply ord_neq_0_gt_0... intros H0.
      apply ordExp_eq_0 in H0... eapply suc_neq_0...
    }
    destruct (classic (m = 0)) as [|Hm0]. {
      rewrite H0 in H1. exfalso. apply (nat_irrefl 1)...
    }
    destruct (classic (m = 1)) as [|Hm1]. {
      rewrite H0. rewrite <- ordExp_2_ω in H...
    }
    rewrite <- IH, ordExp_limit in H... rewrite ordExp_limit...
    apply FUnionE in H as [k [Hk Hx]].
    eapply FUnionI... eapply ord_trans...
    rewrite fin_ordExp_eq_exp, fin_ordExp_eq_exp...
    apply exp_preserve_base_lt... intros H. subst.
    rewrite ordExp_0_r in Hx...
    rewrite one in Hx. apply SingE in Hx...
Qed.

Theorem ordTetL_n_ω : ∀n ∈ ω, 1 ∈ n → n ^^ᴸ ω = ω.
Proof with neauto.
  intros n Hn. ω_induction n; intros H1. exfalso0.
  assert (Hmp: m⁺ ∈ ω). apply ω_inductive...
  ext.
  - rewrite ordTetL_limit in H...
    apply FUnionE in H as [k [Hk Hx]]. eapply ω_trans...
  - apply le_iff_lt_suc in H1 as []...
    + rewrite <- IH, ordTetL_limit in H...
      rewrite ordTetL_limit...
      apply FUnionE in H as [k [Hk Hx]].
      eapply FUnionI... eapply ord_trans...
      apply tetL_preserve_base_lt... apply ord_gt_1_neq_0_1...
    + subst. rewrite <- ordTetL_2_ω in H...
Qed.

Theorem ordTetR_n_ω : ∀n ∈ ω, 1 ∈ n → n ^^ᴿ ω = ω.
Proof with auto.
  intros n Hn Hn1. rewrite ordTetR_normal_form...
  2: apply ord_gt_1_neq_0_1 in Hn1 as []...
  rewrite ordExp_n_ω, ordExp_n_ω...
Qed.

Fact ordTetR_n_ω_eq_L : ∀n ∈ ω, n ≠ 0 → n ^^ᴿ ω = n ^^ᴸ ω.
Proof with auto.
  intros n Hn Hn0.
  destruct (classic (n = 1)) as [|Hn1]. {
    subst. rewrite ordTetL_1_l, ordTetR_1_l...
  }
  rewrite ordTetR_n_ω, ordTetL_n_ω...
Qed.

Fact ordTetR_ω_ω_eq_L : ω ^^ᴿ ω = ω ^^ᴸ 2.
Proof with nauto.
  rewrite ordTetR_normal_form...
  repeat rewrite pred, ordTetL_suc... rewrite ordTetL_0...
Qed.

Fact ordTetR_ω_ω_lt_L : ω ^^ᴿ ω ∈ ω ^^ᴸ ω.
Proof with nauto.
  rewrite ordTetL_limit, ordTetR_ω_ω_eq_L...
  apply (FUnionI _ _ 3)...
  apply ordTetL_n_ascending...
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e414m17_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e452m3_15limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e444m17_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e336m17_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e174m17_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Set Implicit Arguments.
Require Import List.
Scheme Equality for list.

(** * Model
  Each model is constructed by a list of {@code ModelElement} and {@ModelLink}. **)

Class Model (ModelElement: Type) (ModelLink: Type) :=
  {
    modelElements : list ModelElement;
    modelLinks : list ModelLink;
  }.

Definition allModelElements {ModelElement: Type} {ModelLink: Type} (m: Model ModelElement ModelLink) : list ModelElement :=
  (@modelElements _ _ m).

Definition allModelLinks {ModelElement: Type} {ModelLink: Type} (m: Model ModelElement ModelLink) : list ModelLink :=
  (@modelLinks _ _ m).

(*
 allModelElements and allModelLinks are fields of record Model.
 To use them on a Model m:
 @allModelElements _ _ a.
 *)

Definition Model_beq {ME ML: Type} (ME_beq: ME -> ME -> bool) (ML_beq: ML -> ML -> bool) (m1 m2: Model ME ML) :=
  andb (list_beq ME_beq (@modelElements _ _ m1) (@modelElements _ _ m2))
  (list_beq ML_beq (@modelLinks _ _ m1) (@modelLinks _ _ m2)).

Definition Model_wellFormed {ME ML: Type} (m: Model ME ML): Prop :=
  (@modelElements ME ML m = nil) -> (@modelLinks ME ML m = nil).

(*Definition Model_incl {ME ML: Type} (m1 m2: Model ME ML) :=
  forall (e:ME) (l:ML),
   count_occ' (@modelElements _ _ m1) e <= count_occ' (@modelElements _ _ m2) /\
   count_occ' (@modelLinks _ _ m1) e <= count_occ' (@modelLinks _ _ m2).

Definition Model_equiv {ME ML: Type} (m1 m2: Model ME ML)  :=
  forall (e:ME) (l:ML),
  count_occ' (@modelElements _ _ m1) e = count_occ' (@modelElements _ _ m2) /\
  count_occ' (@modelLinks _ _ m1) e = count_occ' (@modelLinks _ _ m2).*)

Definition Model_app {ME ML: Type} (m1 m2: Model ME ML) :=
  Build_Model
    (app (@modelElements _ _ m1) (@modelElements _ _ m2))
    (app (@modelLinks _ _ m1) (@modelLinks _ _ m2)).

Definition Model_concat {ME ML: Type} (ms: list (Model ME ML)) :=
  Build_Model
    (flat_map (@modelElements _ _) ms)
    (flat_map (@modelLinks _ _) ms).


(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to the
   correctness of simplification  algorithms for context-free grammars,
   namely empty rules elimination, unit rules elimination, useless symbol
   elimination and inaccessible symbol elimination.
   More information can be found in the paper "Formalization of
   simplification for context-free grammars", LSFA 2015.
   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - UNIT RULES                                           *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import useless.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - UNIT RULES - DEFINITIONS                             *)
(* --------------------------------------------------------------------- *)

Section UnitRules.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation nlist:= (list non_terminal).
Notation tlist:= (list terminal).

Inductive unit (g: cfg non_terminal terminal) (a: non_terminal): non_terminal -> Prop:=
| unit_rule: forall (b: non_terminal),
             rules g a [inl b] -> unit g a b
| unit_trans: forall b c: non_terminal,
              unit g a b ->
              unit g b c ->
              unit g a c.

Inductive g_unit_rules (g: cfg _ _): non_terminal -> sf -> Prop :=
| Lift_direct' :
       forall left: non_terminal,
       forall right: sf,
       (forall r: non_terminal,
       right <> [inl r]) -> rules g left right ->
       g_unit_rules g left right
| Lift_indirect':
       forall a b: non_terminal,
       unit g a b ->
       forall right: sf,
       rules g b right ->
       (forall c: non_terminal,
       right <> [inl c]) ->
       g_unit_rules g a right.

Lemma unit_exists_right:
forall g: cfg _ _,
forall a b: non_terminal,
unit g a b ->
exists c : sf, rules g a c.
Proof.
intros g a b H.
induction H.
- exists [inl b].
  exact H.
- exact IHunit1.
Qed.

Lemma unit_exists_left:
forall g: cfg _ _,
forall a c: non_terminal,
unit g a c ->
exists b : non_terminal, rules g a [inl b].
Proof.
intros g a c H.
induction H.
- exists b.
  exact H.
- exact IHunit1.
Qed.

Lemma g_unit_finite:
forall g: cfg _ _,
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In (start_symbol g) ntl /\
forall left: non_terminal,
forall right: sf,
g_unit_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite g) as [n [ntl [tl H1]]].
exists n, ntl, tl.
split.
- destruct H1 as [H1 _].
  exact H1.
- destruct H1 as [_ H1].
  intros left right H2.
  inversion H2.
  + subst.
    specialize (H1 left right H0).
    destruct H1 as [H4 [H5 H6]].
    split.
    * exact H4.
    * {
      split.
      - exact H5.
      - exact H6.
      }
  + subst.
    apply unit_exists_right in H.
    destruct H as [c H4].
    split.
    * specialize (H1 b right H0).
      destruct H1 as [H1 _].
      exact H1.
    * {
      split.
      - specialize (H1 left c H4).
        destruct H1 as [_ [H1 _]].
        exact H1.
      - specialize (H1 b right H0).
        destruct H1 as [_ [_ H1]].
        exact H1.
      }
Qed.

Definition g_unit (g: cfg _ _): cfg _ _ := {|
start_symbol:= start_symbol g;
rules:= g_unit_rules g;
rules_finite:= g_unit_finite g
|}.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - UNIT RULES - LEMMAS AND THEOREMS                     *)
(* --------------------------------------------------------------------- *)

Lemma unit_not_unit:
forall g: cfg _ _,
forall a b: non_terminal,
~ unit (g_unit g) a b.
Proof.
intros g a0 b0 H.
induction H.
- inversion H.
  + specialize (H0 b).
    destruct H0.
    reflexivity.
  + specialize (H2 b).
    destruct H2.
    reflexivity.
- exact IHunit1.
Qed.

Lemma unit_derives:
forall g: cfg _ _,
forall a b: non_terminal,
unit g a b ->
derives g [inl a] [inl b].
Proof.
intros g a b H.
induction H.
- apply derives_start.
  exact H.
- apply derives_trans with (s2:=[inl b]).
  + exact IHunit1.
  + exact IHunit2.
Qed.

Lemma rules_g_unit_g:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules (g_unit g) left right ->
rules g left right \/ derives g [inl left] right.
Proof.
intros g left right H.
simpl in H.
inversion H.
- left.
  exact H1.
- right.
  subst.
  replace right with ([] ++ right ++ []).
  + apply derives_step with (left:=b).
    * apply unit_derives in H0.
      exact H0.
    * exact H1.
  + rewrite app_nil_l.
    rewrite app_nil_r.
    reflexivity.
Qed.

Lemma rules_g_unit_g':
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules (g_unit g) left right ->
rules g left right \/
exists left': non_terminal, unit g left left' /\ rules g left' right.
Proof.
intros g left right H.
inversion H.
- left.
  exact H1.
- right.
  exists b.
  split.
  + exact H0.
  + exact H1.
Qed.

Lemma rules_g_unit_not_unit:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
(rules (g_unit g) left right) ->
(~ exists n: non_terminal, right = [inl n]).
Proof.
intros g left right H1 H2.
inversion H1.
- subst.
  destruct H2 as [n H2].
  specialize (H n).
  contradiction.
- subst.
  destruct H2 as [n H2].
  specialize (H3 n).
  contradiction.
Qed.

Lemma generates_g_unit_g:
forall g: cfg _ _,
forall s: sf,
generates (g_unit g) s -> generates g s.
Proof.
unfold generates.
intros g s H.
simpl in H.
remember [inl (start_symbol g)] as w1.
induction H.
- apply derives_refl.
- apply rules_g_unit_g in H0.
  destruct H0 as [H0 | H0].
  + apply derives_step with (left:=left).
    * apply IHderives.
      exact Heqw1.
    * exact H0.
  + apply derives_subs with (s3:=[inl left]).
    * apply IHderives.
      exact Heqw1.
    * exact H0.
Qed.

Lemma rules_g_g_unit:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules g left right ->
(forall n: non_terminal, right <> [inl n]) ->
rules (g_unit g) left right.
Proof.
intros g left right H1 H2.
simpl.
apply Lift_direct'.
- exact H2.
- exact H1.
Qed.

Lemma derives3_g_g_unit:
forall g: cfg _ _,
forall n: non_terminal,
forall s: sentence,
derives3 g n s -> derives3 (g_unit g) n s.
Proof.
intros g.
intros n s H.
apply derives3_ind_2 with (g:=g) (P:=derives3 (g_unit g)) (P0:=derives3_aux (g_unit g)).
- intros n0 lt H1.
  apply derives3_rule.
  apply rules_g_g_unit in H1.
  + exact H1.
  + destruct lt; discriminate.
- intros n0 ltnt lt H1 H2 H3.
  destruct ltnt.
  + apply rules_g_g_unit in H1.
    * inversion H2.
      subst.
      apply derives3_rule.
      exact H1.
    * discriminate.
  + destruct ltnt.
    * {
      destruct s0.
      - apply exists_rule_derives3_aux in H2.
        destruct H2 as [H2 | H2].
        + assert (H10: rules (g_unit g) n0 (map term_lift lt)).
            {
            apply Lift_indirect' with (b:=n1).
            * apply unit_rule.
              exact H1.
            * exact H2.
            * destruct lt; discriminate.
            }
          apply derives3_rule.
          exact H10.
        + destruct H2 as [right [H4 H5]].
          apply exists_rule_derives3_aux in H3.
          destruct H3 as [H3 | H3].
          * apply rules_g_unit_g' in H3.
            {
            destruct H3 as [H3 | H3].
            - assert (H10: rules (g_unit g) n0 (map term_lift lt)).
                {
                apply Lift_indirect' with (b:=n1).
                - apply unit_rule.
                  exact H1.
                - exact H3.
                - intros c0.
                  destruct lt.
                  + discriminate.
                  + discriminate.
                }
              apply derives3_rule.
              exact H10.
            - destruct H3 as [left' [H6 H7]].
              assert (H10: rules (g_unit g) n0 (map term_lift lt)).
                {
                apply Lift_indirect' with (b:=left').
                - apply unit_trans with (b:=n1).
                  + apply unit_rule.
                    exact H1.
                  + exact H6.
                - exact H7.
                - intros c0.
                  destruct lt; discriminate.
                }
              apply derives3_rule.
              exact H10.
            }
          * destruct H3 as [right0 [H6 H7]].
            assert (H6':=H6).
            apply rules_g_unit_not_unit in H6'.
            apply rules_g_unit_g' in H6.
            {
            destruct H6 as [H6 | H6].
            - apply derives3_step with (ltnt:=right0).
              + apply Lift_indirect' with (b:=n1).
                * apply unit_rule.
                  exact H1.
                * exact H6.
                * apply not_exists_forall_not.
                  exact H6'.
              + exact H7.
            - apply derives3_step with (ltnt:=right0).
              + destruct H6 as [left' [H8 H9]].
                apply Lift_indirect' with (b:=left').
                * {
                  apply unit_trans with (b:=n1).
                  - apply unit_rule.
                    exact H1.
                  - exact H8.
                  }
                * exact H9.
                * apply not_exists_forall_not.
                  exact H6'.
              + exact H7.
            }
      - apply rules_g_g_unit in H1.
        + apply derives3_step with (ltnt:=[inr t]).
          * exact H1.
          * exact H3.
        + discriminate.
      }
    * {
      apply rules_g_g_unit in H1.
      - apply derives3_step with (ltnt:=(s0 :: s1 :: ltnt)).
        + exact H1.
        + exact H3.
      - discriminate.
      }
- apply derives3_aux_empty.
- intros t ltnt lt H1 H2.
  apply derives3_aux_t.
  exact H2.
- intros n0 lt lt' ltnt H1 H2 H3 H4.
  apply derives3_aux_nt.
  + exact H2.
  + exact H4.
- exact H.
Qed.

Lemma derives_g_g_unit:
forall g: cfg _ _,
forall s: sentence,
forall n: non_terminal,
derives g [inl n] (map term_lift s) -> derives (g_unit g) [inl n] (map term_lift s).
Proof.
intros g s n.
repeat rewrite derives_equiv_derives3.
apply derives3_g_g_unit.
Qed.

Theorem g_equiv_unit:
forall g: cfg _ _,
g_equiv (g_unit g) g.
Proof.
unfold g_equiv.
unfold produces.
intros g s.
split.
- apply generates_g_unit_g.
- apply derives_g_g_unit.
Qed.

Definition has_no_unit_rules (g: cfg _ _): Prop:=
forall left n: non_terminal,
forall right: sf,
rules g left right -> right <> [inl n].

Lemma g_unit_has_no_unit_rules:
forall g: cfg _ _,
has_no_unit_rules (g_unit g).
Proof.
unfold has_no_unit_rules.
intros g left n right H.
destruct right.
- apply nil_cons.
- inversion_clear H.
  + specialize (H0 n).
    exact H0.
  + specialize (H2 n).
    exact H2.
Qed.

Theorem g_unit_correct:
forall g: cfg _ _,
g_equiv (g_unit g) g /\
has_no_unit_rules (g_unit g).
Proof.
intros g.
split.
- apply g_equiv_unit.
- apply g_unit_has_no_unit_rules.
Qed.

End UnitRules.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.
Require map.Occ.

(* Why3 assumption *)
Definition permut {a:Type} {a_WT:WhyType a} (m1:(map.Map.map Z a))
  (m2:(map.Map.map Z a)) (l:Z) (u:Z): Prop :=
  forall (v:a), ((map.Occ.occ v m1 l u) = (map.Occ.occ v m2 l u)).

(* Why3 goal *)
Lemma permut_trans :
forall {a:Type} {a_WT:WhyType a},
forall (a1:(map.Map.map Z a)) (a2:(map.Map.map Z a)) (a3:(map.Map.map Z a)),
 forall (l:Z) (u:Z),
  (permut a1 a2 l u) -> ((permut a2 a3 l u) -> (permut a1 a3 l u)).
intros a a_WT a1 a2 a3 l u h1 h2.
unfold permut in *.
intros. transitivity (Occ.occ v a2 l u); auto.
Qed.

(* Why3 goal *)
Lemma permut_exists :
forall {a:Type} {a_WT:WhyType a},
forall (a1:(map.Map.map Z a)) (a2:(map.Map.map Z a)) (l:Z) (u:Z) (i:Z),
 (permut a1 a2 l u) ->
 (((l <= i)%Z /\ (i < u)%Z) ->
  exists j:Z,
   ((l <= j)%Z /\ (j < u)%Z) /\ ((map.Map.get a1 j) = (map.Map.get a2 i))).
Proof.
intros a a_WT a1 a2 l u i h1 Hi.
pose (v := Map.get a2 i).
assert (0 < map.Occ.occ v a2 l u)%Z.
  apply map.Occ.occ_pos. assumption.
rewrite <- h1 in H.
generalize (map.Occ.occ_exists v a1 l u H).
intros (j, (hj1,hj2)).
exists j; intuition.
Qed.


(* hf 3 *)

Definition f_1 (g: bool -> bool) : bool := andb (g(true)) (g(false)).
Eval compute in f_1(fun x : bool => orb x (negb x)).

(* hf 4 *)

Inductive szavak : Set :=
  | Hello : szavak -> szavak
  | world : szavak.
Eval compute in Hello world.

Inductive Szavak : Set :=
  | hello : Szavak
  | World : Szavak.
Eval compute in (hello, World).

(* hf 5 *)

Definition f_2 (g: bool -> bool -> bool) : bool := andb (f_1(g(true))) (f_1(g(false))).
Eval compute in (f_2(fun x y => orb x y)).
Eval compute in (f_2(fun x y => implb (orb (negb x) (negb y)) (negb (andb x y)))).


(** * Maps: Total and Partial Maps *)

(** _Maps_ (or _dictionaries_) are ubiquitous data structures both
    generally and in the theory of programming languages in
    particular; we're going to need them in many places in the coming
    chapters.  They also make a nice case study using ideas we've seen
    in previous chapters, including building data structures out of
    higher-order functions (from [Basics] and [Poly]) and the use of
    reflection to streamline proofs (from [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we begin...

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

(** Tree Substitution Grammar parser, 1st try.

    We define the TSG parser in terms of the corresponding non-weighted
    inference rules.  The parser is thus a simplified, symbolic variant
    of the full ParTAGe parser.

    But... let's start with the CFG Earley parser!
*)

Definition non_terminal := string.
Definition terminal := string.

Inductive symbol : Type :=
  | non_term (x : non_terminal)
  | term (x : terminal).

(*
Inductive rule (X:Type) : Type :=
  | Rule (head : X) (body : list X).
*)

Inductive rule : Type :=
  | Rule (head : non_terminal) (body : list symbol).

Definition head (r : rule) : non_terminal :=
  match r with
  | Rule x y => x
  end.

(* Leading symbol in the body of the rule *)
Definition lead (r : rule) : option symbol :=
  match r with
  | Rule _ (h :: t) => Some h
  | _ => None
  end.

(* Shift the dot in the rule (if possible) *)
Definition shift (r : rule) : rule :=
  match r with
  | Rule x (h :: t) => Rule x t
  | _ => r
  end.

(** We just assume that the dot is in front of the body.
    In a dotted rule, the body may not contain all the
    symbols in the actualy body of the rule, just the
    symbols that are still to be matched.
*)
Definition dotted_rule := rule.

(** Position in the input sentence is just a natural number.
    Ideally, it should be constrained to the list of actual
    positions between the words.
*)
Definition pos := nat.

Inductive cfg : dotted_rule -> pos -> pos -> Prop :=
  | cfg_ax (r : rule) (i : pos) : cfg r i i
  | cfg_sc (r : rule) (i : pos) (j : pos)
      (sent: pos -> option symbol)
      (* JW: eventually, [S] should be of type [option terminal], but
         we would need to use the notion of a functor for that. *)
      (P: cfg r i j)
      (E: sent j = lead r) :
        cfg r i (S j)
  | cfg_co (l : rule) (r : rule) (i j k : pos)
      (L: cfg l i j)
      (R: cfg r j k)
      (E: lead l = Some (non_term (head r))) :
        cfg (shift l) i k.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/.

    The [Search] command is a good way to look for theorems involving
    objects of specific types.  Take a minute now to experiment with it. *)

(* ################################################################# *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  In [Lists.v] we introduced a fresh type [id] for a similar
    purpose; here and for the rest of _Software Foundations_ we will
    use the [string] type from Coq's standard library. *)

(** To compare strings, we define the function [eqb_string], which
    internally uses the function [string_dec] from Coq's string
    library. *)

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

(** (The function [string_dec] comes from Coq's string library.
    If you check the result type of [string_dec], you'll see that it
    does not actually return a [bool], but rather a type that looks
    like [{x = y} + {x <> y}], called a [sumbool], which can be
    thought of as an "evidence-carrying boolean."  Formally, an
    element of [sumbool] is either a proof that two things are equal
    or a proof that they are unequal, together with a tag indicating
    which.  But for present purposes you can think of it as just a
    fancy [bool].) *)

(** Now we need a few basic properties of string equality... *)
Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof. intros s. unfold eqb_string. destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

(** The following useful property follows from an analogous
    lemma about strings: *)

Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold eqb_string.
   destruct (string_dec x y) as [|Hs].
   - subst. split. reflexivity. reflexivity.
   - split.
     + intros contra. discriminate contra.
     + intros H. rewrite H in Hs. destruct Hs. reflexivity.
Qed.

(** Similarly: *)

Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This handy variant follows just by rewriting: *)

Theorem false_eqb_string : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
  intros x y. rewrite eqb_string_false_iff.
  intros H. apply H. Qed.

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about its behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the very same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps. *)

(** We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A : Type) := string -> A.

(** Intuitively, a total map over an element type [A] is just a
    function that can be used to look up [string]s, yielding [A]s. *)

(** The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any string. *)

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

(** This definition is a nice example of higher-order programming:
    [t_update] takes a _function_ [m] and yields a new function
    [fun x' => ...] that behaves like the desired map. *)

(** For example, we can build a map taking [string]s to [bool]s, where
    ["foo"] and ["bar"] are mapped to [true] and every other key is
    mapped to [false], like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

(** Next, let's introduce some new notations to facilitate working
    with maps. *)

(** First, we will use the following notation to create an empty
    total map with a default value. *)
Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Example example_empty := (_ !-> false).

(** We then introduce a convenient notation for extending an existing
    map with some bindings. *)
Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

(** The [examplemap] above can now be defined as follows: *)

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _     !-> false
  ).

(** This completes the definition of total maps.  Note that we
    don't need to define a [find] operation because it is just
    function application! *)

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave. *)

(** Even if you don't work the following exercises, make sure
    you thoroughly understand the statements of the lemmas! *)

(** (Some of the proofs require the functional extensionality axiom,
    which is discussed in the [Logic] chapter.) *)

(** **** Exercise: 1 star, standard, optional (t_apply_empty)

    First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_eq)

    Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_neq)

    On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_shadow)

    If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [eqb_id]. *)

(** **** Exercise: 2 stars, standard, optional (eqb_stringP)

    Use the proof of [eqbP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Now, given [string]s [x1] and [x2], we can use the tactic
    [destruct (eqb_stringP x1 x2)] to simultaneously perform case
    analysis on the result of [eqb_string x1 x2] and generate
    hypotheses about the equality (in the sense of [=]) of [x1]
    and [x2]. *)

(** **** Exercise: 2 stars, standard (t_update_same)

    With the example in chapter [IndProp] as a template, use
    [eqb_stringP] to prove the following theorem, which states that
    if we update a map to assign key [x] the same value as it already
    has in [m], then the result is equal to [m]: *)

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, recommended (t_update_permute)

    Use [eqb_stringP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

(** We introduce a similar notation for partial maps: *)
Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

(** We can also hide the last case when it is empty. *)
Notation "x '|->' v" := (update empty x v)
  (at level 100).

Example examplepmap :=
  ("Church" |-> true ; "Turing" |-> false).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.

(* Wed Jan 9 12:02:45 EST 2019 *)


From Coq.ssr Require Import ssreflect.
From iris.algebra Require Import gmap.

Section collect.
  Context {K} `{!EqDecision K} `{Countable K} {A : Type}
          {B : Type} `{!EqDecision B} `{Countable B}
          (f : K → A → gset B).

  Definition collect (g : gmap K A) : gset B :=
    map_fold (λ k a acc, (f k a) ∪ acc) ∅ g.

  Lemma collect_singleton k a :
    collect {[k := a]} = f k a.
  Proof.
    rewrite /collect.
    rewrite map_fold_insert_L.
    - simpl. rewrite map_fold_empty; set_solver.
    - set_solver.
    - done.
  Qed.

  Lemma collect_empty :
    collect ∅ = ∅.
  Proof. by rewrite /collect.
  Qed.

  Lemma collect_insert k a g :
    collect (<[k:=a]> g) = f k a ∪ collect (delete k g).
  Proof.
    generalize dependent a.
    generalize dependent k.
    pattern (collect g); pattern g.
    match goal with
    |- (λ x, (λ y, ?P) _) _ =>
      simpl; apply (map_fold_ind (M := gmap _) (B := gset B) (λ y, λ x, P))
    end; [ done | exact ∅ | |].
    - intros. rewrite collect_singleton; set_solver.
    - intros k' a' h acc Hk' IH k a.
      destruct (decide (k = k')) as [-> | Hneq].
      + rewrite insert_insert delete_insert_delete.
        set_solver.
      + rewrite delete_insert_ne; last done.
        assert ((<[k:=a]>(<[k':=a']> h)) = (<[k':=a']>(<[k:=a]> h))) as ->.
        { by rewrite insert_commute; last done. }
        rewrite /collect.
        rewrite {1} map_fold_insert_L.
        specialize (IH k a).
        rewrite /collect in IH.
        rewrite IH.
        rewrite {1} map_fold_insert_L.
        * set_solver.
        * set_solver.
        * by rewrite lookup_delete_ne.
        * set_solver.
        * by rewrite lookup_insert_ne; last done.
  Qed.

  Lemma collect_disjoint_union g h :
    g ##ₘ h →
    collect (g ∪ h) = collect g ∪ collect h.
  Proof.
    intros Hdisj.
    generalize dependent h.
    pattern (collect g); pattern g.
    match goal with
    |- (λ x, (λ y, ?P) _) _ =>
    simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P))
    end.
    - intros. by rewrite !left_id_L.
    - intros k a g' acc Hk IHM h' Hdisj.
      assert (f k a ∪ acc ∪ collect h' =
              acc ∪ (f k a ∪ collect h')) as -> by set_solver.
      rewrite insert_union_singleton_l.
      assert ({[k := a]} ∪ g' ∪ h' =  g' ∪ ({[k := a]} ∪ h')) as ->.
      { rewrite (map_union_comm {[k := a]} g').
          by rewrite map_union_assoc.
          by apply map_disjoint_singleton_l_2. }
      rewrite IHM.
      + rewrite -insert_union_singleton_l.
        rewrite collect_insert.
        simplify_map_eq.
        rewrite delete_notin; last done.
        done.
      + apply map_disjoint_union_r_2.
        * by apply map_disjoint_singleton_r_2.
        * simplify_map_eq. set_solver.
  Qed.

  Lemma collect_empty_f g :
    (forall k a, g !! k = Some a → f k a = ∅) → collect g = ∅.
  Proof.
    pattern (collect g); pattern g.
    match goal with
    |- (λ x, (λ y, ?P) _) _ =>
      simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P))
    end.
    - done.
    - intros k a g' M Hk IHM IHMi.
      rewrite empty_union_L; split.
      + specialize (IHMi k a). apply IHMi.
          by rewrite lookup_insert.
      + apply IHM. intros k' a' Hka'.
        specialize (IHMi k' a').
        apply IHMi.
        destruct (decide (k = k')) as [<-|Hneq]; by simplify_map_eq.
  Qed.

  Lemma elem_of_collect g :
    ∀ m, m ∈ collect g ↔ ∃ k a, g !! k = Some a ∧ m ∈ f k a.
  Proof.
    pattern (collect g); pattern g.
    match goal with
    |- (λ x, (λ y, ?P) _) _ =>
      simpl; apply (map_fold_ind (M := gmap _) (λ y, λ x, P))
    end.
    - intros m; split; first done.
      intros (?&?&?&?); done.
    - intros k a g' M Hk IHM m.
      split.
      + intros [Hm|Hm]%elem_of_union.
        * exists k, a; rewrite lookup_insert; done.
        * apply IHM in Hm as (k' & a' & Hk' & Hm).
          exists k', a'.
          rewrite lookup_insert_ne; first done.
          set_solver.
      + intros (k' & a' & Hk' & Hm).
        destruct (decide (k' = k)) as [->|].
        * rewrite lookup_insert in Hk'; simplify_eq.
          set_solver.
        * rewrite lookup_insert_ne in Hk'; last done.
          apply elem_of_union; right.
          apply IHM; eauto.
  Qed.

End collect.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.ModalLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import ModalLanguageNotation.

Class SystemK (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} := {
  axiom_K: forall x y, |-- boxp (x --> y) --> (boxp x --> boxp y); (* a.k.a. Distribution Axiom *)
  rule_N: forall x, |-- x -> |-- boxp x (* a.k.a. Necessitation Rule *)
}.

Class SystemT (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} := {
  axiom_T: forall x, |-- boxp x --> x
}.

Class System4 (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {TmGamma: SystemT L Gamma}:= {
  axiom_4: forall x, |-- boxp x --> boxp (boxp x)
}.

Class SystemD (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {cpGamma: ClassicalPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} := {
  axiom_D: forall x, |-- boxp x --> diamondp x
}.

Class SystemB (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {cpGamma: ClassicalPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} := {
  axiom_B: forall x, |-- x --> boxp (diamondp x)
}.

Class System5 (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {cpGamma: ClassicalPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {TmGamma: SystemT L Gamma} {s4mGamma: System4 L Gamma}:= {
  axiom_5: forall x, |-- diamondp x --> boxp (diamondp x)
}.

Class PropositionalTransparentModality (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} := {
  boxp_orp: forall x y, |-- boxp (x || y) <--> boxp x || boxp y
}.

Class StrongPropositionalTransparentModality (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {pmGamma: PropositionalTransparentModality L Gamma} := {
  boxp_impp: forall x y, |-- boxp (x --> y) <--> (boxp x --> boxp y)
}.

(*
(* TODO: Add Sequnt Calculus for it. *)
Lemma MakeSequentCalculus_DeMorganPropositionalLogic {L: Language} {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {Gamma: ProofTheory L} {minAX: MinimunAxiomatization L Gamma} (minAX': MinimunAxiomatization L (Build_AxiomaticProofTheory (@provable L Gamma))) (ipGamma: IntuitionisticPropositionalLogic L Gamma) {ipGamma': IntuitionisticPropositionalLogic L (Build_AxiomaticProofTheory (@provable L Gamma))} {dmpGamma: DeMorganPropositionalLogic L Gamma}:
  Typeclass_Rewrite (exist (fun X: Prop => X) (IntuitionisticPropositionalLogic L (Build_AxiomaticProofTheory (@provable L Gamma))) ipGamma' :: nil) ->
  forall (G: Prop) (l: list (sig (fun X: Prop => X))),
  (forall
     (dmpGamma: DeMorganPropositionalLogic L (Build_AxiomaticProofTheory (@provable L Gamma))),
     OpaqueProp (Typeclass_Rewrite l -> G)) <->
  OpaqueProp (Typeclass_Rewrite ((exist (fun X: Prop => X) (DeMorganPropositionalLogic L Gamma) dmpGamma) :: l) -> G).
Proof.
  unfold OpaqueProp.
  intros _.
  intros.
  split; intros.
  + clear H0.
    apply H; auto.
    - destruct dmpGamma; constructor; auto.
    - apply Typeclass_Rewrite_I.
  + apply H; auto.
    apply Typeclass_Rewrite_I.
Qed.

Hint Rewrite <- @MakeSequentCalculus_DeMorganPropositionalLogic using (instantiate (1 := _); apply Typeclass_Rewrite_I): AddSC.

Section ModalLogic.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {mL: ModalLanguage L}
        {Gamma: ProofTheory L}
        {AX: NormalAxiomatization L Gamma}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {KmGamma: SystemK L Gamma}.

Lemma derivable_axiom_K: forall Phi x y,
  Phi |-- boxp (x --> y) --> (boxp x --> boxp y).
Proof.
  intros.
  apply deduction_weaken0.
  apply axiom_K.
Qed.

Lemma deduction_axiom_K: forall Phi x y,
  Phi |-- boxp (x --> y) ->
  Phi |-- boxp x --> boxp y.
Proof.
  intros.
  eapply deduction_modus_ponens; eauto.
  apply derivable_axiom_K.
Qed.

Lemma derivable_axiom_T {TmGamma: SystemT L Gamma}: forall Phi x ,
  Phi |-- boxp x --> x.
Proof.
  intros.
  apply deduction_weaken0.
  apply axiom_T.
Qed.

Lemma deduction_axiom_T {TmGamma: SystemT L Gamma}: forall Phi x ,
  Phi |-- boxp x ->
  Phi |-- x.
Proof.
  intros.
  eapply deduction_modus_ponens; eauto.
  apply derivable_axiom_T.
Qed.

End ModalLogic.

*)


From Coq.Init Require Import Notations Datatypes.
Require Import Coq.Logic.FunctionalExtensionality.

From mathcomp Require Import ssreflect ssrfun eqtype fintype seq.
Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
From mathcomp Require Import ssrbool.
Set Warnings "parsing".

Module Quiver.
  Section Def.
    Record finNonEmptyVectorSet := finNeVectorSetPack {
      U_0 : finType;
      getOneVertex : U_0;
    }.
    Local Notation vType := finNonEmptyVectorSet.
    Local Notation vPack := finNeVectorSetPack.

    Record aType {U : vType} := aPack {
      Q_0 := U_0 U;
      Q_1 : finType;
      h : Q_1 -> Q_0;
      t : Q_1 -> Q_0;
    }.
    Record type := Pack {
      Q_U : vType;
      Q_Q : @aType Q_U;
    }.
    Definition Build {U : vType} (Q : @aType U) := Pack U Q.
    Local Coercion Q_U : type >-> vType.
    Local Coercion Q_Q : type >-> aType.
    Local Coercion Build : aType >-> type.

    Definition head {U} {Q : @aType U} (a : Q_1 Q) := h Q a.
    Definition tail {U} {Q : @aType U} (a : Q_1 Q) := t Q a.

    Definition Op {U} (Q : @aType U) :=
      aPack U (Q_1 Q)
        (fun a => t Q a)
        (fun a => h Q a).

    Lemma Op_Op (Q : type) : Op (Op Q) = Q.
    Proof. unfold Op . destruct Q. by destruct Q_Q. Qed.

    Definition EdgeGraph (Q : type) : rel (Q_1 Q) :=
      fun a1 a2 : Q_1 Q => head a1 == tail a2.

    Definition Doubled (Q : type) : type
    := aPack (Q_U Q) (sum_finType (Q_1 Q) (Q_1 (Op Q)))
      (fun a => match a with
      |inl a' => h Q a' |inr a' => h (Op Q) a'
      end)
      (fun a => match a with
      |inl a' => t Q a' |inr a' => t (Op Q) a'
      end).

    Definition ReversedAt {Q : type} (i : Q_0 Q) : type
    := aPack (Q_U Q) (Q_1 Q)
      (fun a => (if (head a == i) || (tail a == i) then tail else head) a)
      (fun a => (if (head a == i) || (tail a == i) then head else tail) a).

    Definition sink {Q : type} (i : Q_0 Q) : bool
    := [forall a, tail a != i].

    Definition source {Q : type} (i : Q_0 Q) : bool
    := [forall a, head a != i].

    Set Implicit Arguments.
    Unset Strict Implicit.
    Section Union.
      Section Union2.
        Variable (Q1 Q2 : type).
        Definition unionUniv2 := vPack (sum_finType (U_0 Q1) (U_0 Q2)) (inl (getOneVertex Q1)).
        Definition unionQuiv2 := aPack unionUniv2 (sum_finType (Q_1 Q1) (Q_1 Q2))
        (fun a => match a with inl a' => inl (head a')|inr a' => inr (head a') end)
        (fun a => match a with inl a' => inl (tail a')|inr a' => inr (tail a') end).
        Definition union2 := Pack unionUniv2 unionQuiv2.
      End Union2.
      Definition union (a : type) (L : seq type) : type := foldl union2 a L.
    End Union.
    Section AddArrows.
      Variable (Q : type) (n : nat) (h t : (ordinal_finType n) -> Q_0 Q).
      Program Definition addArrows := aPack Q (sum_finType (Q_1 Q) (ordinal_finType n))
        (fun a => match a with inl a' => (head a')|inr i => h i end)
        (fun a => match a with inl a' => (tail a')|inr i => t i end).
    End AddArrows.
  End Def.

  Module Exports.
    Notation finQuiverType := @type.
    Notation vType := finNonEmptyVectorSet.
    Notation vPack := finNeVectorSetPack.
    Coercion Q_U : type >-> vType.
    Coercion Q_Q : type >-> aType.
    Coercion Build : aType >-> type.
    Notation Q_0 := Q_0.
    Notation Q_1 := Q_1.
    Notation Qtail := t.
    Notation Qhead := h.
    Notation "\V_ Q " := (Q_0 Q) (at level 0).
    Notation "\A_ Q " := (Q_1 Q) (at level 0).
    Notation "\t_Q( a )" := (tail a) (at level 0).
    Notation "\h_Q( a )" := (head a) (at level 0).
    Notation "\Op_ Q " := (Op Q) (at level 0).
    Notation "\V_ Q " := (Q_0 Q) (at level 0).
    Notation "\Dbl_ Q " := (Doubled Q) (at level 0).
    Notation "\sigma_ Q ( i )" := (@ReversedAt \V_Q Q i) (at level 0).
  End Exports.
End Quiver.
Export Quiver.Exports.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo1.
Require Import Ranalysis1.
Require Import PSeries_reg.
Require Import Div2.
Require Import Even.
Require Import Max.
Require Import Omega.
Local Open Scope nat_scope.
Local Open Scope R_scope.

Definition E1 (x:R) (N:nat) : R :=
sum_f_R0 (fun k:nat => / INR (fact k) * x ^ k) N.

Lemma E1_cvg : forall x:R, Un_cv (E1 x) (exp x).
Proof. hammer_hook "Exp_prop" "Exp_prop.E1_cvg".
intro; unfold exp; unfold projT1.
case (exist_exp x); intro.
unfold exp_in, Un_cv; unfold infinite_sum, E1; trivial.
Qed.

Definition Reste_E (x y:R) (N:nat) : R :=
sum_f_R0
(fun k:nat =>
sum_f_R0
(fun l:nat =>
/ INR (fact (S (l + k))) * x ^ S (l + k) *
(/ INR (fact (N - l)) * y ^ (N - l))) (
pred (N - k))) (pred N).

Lemma exp_form :
forall (x y:R) (n:nat),
(0 < n)%nat -> E1 x n * E1 y n - Reste_E x y n = E1 (x + y) n.
Proof.
intros; unfold E1.
rewrite cauchy_finite.
unfold Reste_E; unfold Rminus; rewrite Rplus_assoc;
rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq;
intros.
rewrite binomial.
rewrite scal_sum; apply sum_eq; intros.
unfold C; unfold Rdiv; repeat rewrite Rmult_assoc;
rewrite (Rmult_comm (INR (fact i))); repeat rewrite Rmult_assoc;
rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; rewrite Rinv_mult_distr.
ring.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply H.
Qed.

Definition maj_Reste_E (x y:R) (N:nat) : R :=
4 *
(Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * N) /
Rsqr (INR (fact (div2 (pred N))))).

Lemma div2_double : forall N:nat, div2 (2 * N) = N.
Proof. hammer_hook "Exp_prop" "Exp_prop.div2_double".
intro; induction  N as [| N HrecN].
reflexivity.
replace (2 * S N)%nat with (S (S (2 * N))).
simpl; simpl in HrecN; rewrite HrecN; reflexivity.
ring.
Qed.

Lemma div2_S_double : forall N:nat, div2 (S (2 * N)) = N.
Proof. hammer_hook "Exp_prop" "Exp_prop.div2_S_double".
intro; induction  N as [| N HrecN].
reflexivity.
replace (2 * S N)%nat with (S (S (2 * N))).
simpl; simpl in HrecN; rewrite HrecN; reflexivity.
ring.
Qed.

Lemma div2_not_R0 : forall N:nat, (1 < N)%nat -> (0 < div2 N)%nat.
Proof. hammer_hook "Exp_prop" "Exp_prop.div2_not_R0".
intros; induction N as [| N HrecN].
- elim (lt_n_O _ H).
- cut ((1 < N)%nat \/ N = 1%nat).
{ intro; elim H0; intro.
+ destruct (even_odd_dec N) as [Heq|Heq].
* rewrite <- (even_div2 _ Heq); apply HrecN; assumption.
* rewrite <- (odd_div2 _ Heq); apply lt_O_Sn.
+ rewrite H1; simpl; apply lt_O_Sn. }
inversion H.
right; reflexivity.
left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ].
Qed.

Lemma Reste_E_maj :
forall (x y:R) (N:nat),
(0 < N)%nat -> Rabs (Reste_E x y N) <= maj_Reste_E x y N.
Proof.
intros; set (M := Rmax 1 (Rmax (Rabs x) (Rabs y))).
apply Rle_trans with
(M ^ (2 * N) *
sum_f_R0
(fun k:nat =>
sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N)))))
(pred (N - k))) (pred N)).
unfold Reste_E.
apply Rle_trans with
(sum_f_R0
(fun k:nat =>
Rabs
(sum_f_R0
(fun l:nat =>
/ INR (fact (S (l + k))) * x ^ S (l + k) *
(/ INR (fact (N - l)) * y ^ (N - l))) (
pred (N - k)))) (pred N)).
apply
(Rsum_abs
(fun k:nat =>
sum_f_R0
(fun l:nat =>
/ INR (fact (S (l + k))) * x ^ S (l + k) *
(/ INR (fact (N - l)) * y ^ (N - l))) (
pred (N - k))) (pred N)).
apply Rle_trans with
(sum_f_R0
(fun k:nat =>
sum_f_R0
(fun l:nat =>
Rabs
(/ INR (fact (S (l + k))) * x ^ S (l + k) *
(/ INR (fact (N - l)) * y ^ (N - l)))) (
pred (N - k))) (pred N)).
apply sum_Rle; intros.
apply
(Rsum_abs
(fun l:nat =>
/ INR (fact (S (l + n))) * x ^ S (l + n) *
(/ INR (fact (N - l)) * y ^ (N - l)))).
apply Rle_trans with
(sum_f_R0
(fun k:nat =>
sum_f_R0
(fun l:nat =>
M ^ (2 * N) * / INR (fact (S l)) * / INR (fact (N - l)))
(pred (N - k))) (pred N)).
apply sum_Rle; intros.
apply sum_Rle; intros.
repeat rewrite Rabs_mult.
do 2 rewrite <- RPow_abs.
rewrite (Rabs_right (/ INR (fact (S (n0 + n))))).
rewrite (Rabs_right (/ INR (fact (N - n0)))).
replace
(/ INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
(/ INR (fact (N - n0)) * Rabs y ^ (N - n0))) with
(/ INR (fact (N - n0)) * / INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
Rabs y ^ (N - n0)); [ idtac | ring ].
rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
repeat rewrite Rmult_assoc.
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
apply Rle_trans with
(/ INR (fact (S n0)) * Rabs x ^ S (n0 + n) * Rabs y ^ (N - n0)).
rewrite (Rmult_comm (/ INR (fact (S (n0 + n)))));
rewrite (Rmult_comm (/ INR (fact (S n0)))); repeat rewrite Rmult_assoc;
apply Rmult_le_compat_l.
apply pow_le; apply Rabs_pos.
rewrite (Rmult_comm (/ INR (fact (S n0)))); apply Rmult_le_compat_l.
apply pow_le; apply Rabs_pos.
apply Rinv_le_contravar.
apply INR_fact_lt_0.
apply le_INR; apply fact_le; apply le_n_S.
apply le_plus_l.
rewrite (Rmult_comm (M ^ (2 * N))); rewrite Rmult_assoc;
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
apply Rle_trans with (M ^ S (n0 + n) * Rabs y ^ (N - n0)).
do 2 rewrite <- (Rmult_comm (Rabs y ^ (N - n0))).
apply Rmult_le_compat_l.
apply pow_le; apply Rabs_pos.
apply pow_incr; split.
apply Rabs_pos.
apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
apply RmaxLess1.
unfold M; apply RmaxLess2.
apply Rle_trans with (M ^ S (n0 + n) * M ^ (N - n0)).
apply Rmult_le_compat_l.
apply pow_le; apply Rle_trans with 1.
left; apply Rlt_0_1.
unfold M; apply RmaxLess1.
apply pow_incr; split.
apply Rabs_pos.
apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
apply RmaxLess2.
unfold M; apply RmaxLess2.
rewrite <- pow_add; replace (S (n0 + n) + (N - n0))%nat with (N + S n)%nat.
apply Rle_pow.
unfold M; apply RmaxLess1.
replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
apply plus_le_compat_l.
replace N with (S (pred N)).
apply le_n_S; apply H0.
symmetry ; apply S_pred with 0%nat; apply H.
apply INR_eq; do 2 rewrite plus_INR; do 2 rewrite S_INR; rewrite plus_INR;
rewrite minus_INR.
ring.
apply le_trans with (pred (N - n)).
apply H1.
apply le_S_n.
replace (S (pred (N - n))) with (N - n)%nat.
apply le_trans with N.
apply (fun p n m:nat => plus_le_reg_l n m p) with n.
rewrite <- le_plus_minus.
apply le_plus_r.
apply le_trans with (pred N).
apply H0.
apply le_pred_n.
apply le_n_Sn.
apply S_pred with 0%nat.
apply plus_lt_reg_l with n.
rewrite <- le_plus_minus.
replace (n + 0)%nat with n; [ idtac | ring ].
apply le_lt_trans with (pred N).
apply H0.
apply lt_pred_n_n.
apply H.
apply le_trans with (pred N).
apply H0.
apply le_pred_n.
apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
rewrite scal_sum.
apply sum_Rle; intros.
rewrite <- Rmult_comm.
rewrite scal_sum.
apply sum_Rle; intros.
rewrite (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
rewrite Rmult_assoc; apply Rmult_le_compat_l.
apply pow_le.
apply Rle_trans with 1.
left; apply Rlt_0_1.
unfold M; apply RmaxLess1.
assert (H2 := even_odd_cor N).
elim H2; intros N0 H3.
elim H3; intro.
apply Rle_trans with (/ INR (fact n0) * / INR (fact (N - n0))).
do 2 rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
apply Rinv_le_contravar.
apply INR_fact_lt_0.
apply le_INR.
apply fact_le.
apply le_n_Sn.
replace (/ INR (fact n0) * / INR (fact (N - n0))) with
(C N n0 / INR (fact N)).
pattern N at 1; rewrite H4.
apply Rle_trans with (C N N0 / INR (fact N)).
unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ INR (fact N))).
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
rewrite H4.
apply C_maj.
rewrite <- H4; apply le_trans with (pred (N - n)).
apply H1.
apply le_S_n.
replace (S (pred (N - n))) with (N - n)%nat.
apply le_trans with N.
apply (fun p n m:nat => plus_le_reg_l n m p) with n.
rewrite <- le_plus_minus.
apply le_plus_r.
apply le_trans with (pred N).
apply H0.
apply le_pred_n.
apply le_n_Sn.
apply S_pred with 0%nat.
apply plus_lt_reg_l with n.
rewrite <- le_plus_minus.
replace (n + 0)%nat with n; [ idtac | ring ].
apply le_lt_trans with (pred N).
apply H0.
apply lt_pred_n_n.
apply H.
apply le_trans with (pred N).
apply H0.
apply le_pred_n.
replace (C N N0 / INR (fact N)) with (/ Rsqr (INR (fact N0))).
rewrite H4; rewrite div2_S_double; right; reflexivity.
unfold Rsqr, C, Rdiv.
repeat rewrite Rinv_mult_distr.
rewrite (Rmult_comm (INR (fact N))).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_r_sym.
rewrite Rmult_1_r; replace (N - N0)%nat with N0.
ring.
replace N with (N0 + N0)%nat.
symmetry ; apply minus_plus.
rewrite H4.
ring.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
unfold C, Rdiv.
rewrite (Rmult_comm (INR (fact N))).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_r_sym.
rewrite Rinv_mult_distr.
rewrite Rmult_1_r; ring.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
replace (/ INR (fact (S n0)) * / INR (fact (N - n0))) with
(C (S N) (S n0) / INR (fact (S N))).
apply Rle_trans with (C (S N) (S N0) / INR (fact (S N))).
unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ INR (fact (S N)))).
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
cut (S N = (2 * S N0)%nat).
intro; rewrite H5; apply C_maj.
rewrite <- H5; apply le_n_S.
apply le_trans with (pred (N - n)).
apply H1.
apply le_S_n.
replace (S (pred (N - n))) with (N - n)%nat.
apply le_trans with N.
apply (fun p n m:nat => plus_le_reg_l n m p) with n.
rewrite <- le_plus_minus.
apply le_plus_r.
apply le_trans with (pred N).
apply H0.
apply le_pred_n.
apply le_n_Sn.
apply S_pred with 0%nat.
apply plus_lt_reg_l with n.
rewrite <- le_plus_minus.
replace (n + 0)%nat with n; [ idtac | ring ].
apply le_lt_trans with (pred N).
apply H0.
apply lt_pred_n_n.
apply H.
apply le_trans with (pred N).
apply H0.
apply le_pred_n.
rewrite H4; ring.
cut (S N = (2 * S N0)%nat).
intro.
replace (C (S N) (S N0) / INR (fact (S N))) with (/ Rsqr (INR (fact (S N0)))).
rewrite H5; rewrite div2_double.
right; reflexivity.
unfold Rsqr, C, Rdiv.
repeat rewrite Rinv_mult_distr.
replace (S N - S N0)%nat with (S N0).
rewrite (Rmult_comm (INR (fact (S N)))).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_r_sym.
rewrite Rmult_1_r; reflexivity.
apply INR_fact_neq_0.
replace (S N) with (S N0 + S N0)%nat.
symmetry ; apply minus_plus.
rewrite H5; ring.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
rewrite H4; ring.
unfold C, Rdiv.
rewrite (Rmult_comm (INR (fact (S N)))).
rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
rewrite Rmult_1_r; rewrite Rinv_mult_distr.
reflexivity.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
unfold maj_Reste_E.
unfold Rdiv; rewrite (Rmult_comm 4).
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply pow_le.
apply Rle_trans with 1.
left; apply Rlt_0_1.
apply RmaxLess1.
apply Rle_trans with
(sum_f_R0 (fun k:nat => INR (N - k) * / Rsqr (INR (fact (div2 (S N)))))
(pred N)).
apply sum_Rle; intros.
rewrite sum_cte.
replace (S (pred (N - n))) with (N - n)%nat.
right; apply Rmult_comm.
apply S_pred with 0%nat.
apply plus_lt_reg_l with n.
rewrite <- le_plus_minus.
replace (n + 0)%nat with n; [ idtac | ring ].
apply le_lt_trans with (pred N).
apply H0.
apply lt_pred_n_n.
apply H.
apply le_trans with (pred N).
apply H0.
apply le_pred_n.
apply Rle_trans with
(sum_f_R0 (fun k:nat => INR N * / Rsqr (INR (fact (div2 (S N))))) (pred N)).
apply sum_Rle; intros.
do 2 rewrite <- (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt.
apply INR_fact_neq_0.
apply le_INR.
apply (fun p n m:nat => plus_le_reg_l n m p) with n.
rewrite <- le_plus_minus.
apply le_plus_r.
apply le_trans with (pred N).
apply H0.
apply le_pred_n.
rewrite sum_cte; replace (S (pred N)) with N.
cut (div2 (S N) = S (div2 (pred N))).
intro; rewrite H0.
rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR; rewrite Rsqr_mult.
rewrite Rinv_mult_distr.
rewrite (Rmult_comm (INR N)); repeat rewrite Rmult_assoc;
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
rewrite <- H0.
cut (INR N <= INR (2 * div2 (S N))).
intro; apply Rmult_le_reg_l with (Rsqr (INR (div2 (S N)))).
apply Rsqr_pos_lt.
apply not_O_INR; red; intro.
cut (1 < S N)%nat.
intro; assert (H4 := div2_not_R0 _ H3).
rewrite H2 in H4; elim (lt_n_O _ H4).
apply lt_n_S; apply H.
repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_r_sym.
rewrite Rmult_1_l.
change 4 with (Rsqr 2).
rewrite <- Rsqr_mult.
apply Rsqr_incr_1.
change 2 with (INR 2).
rewrite Rmult_comm, <- mult_INR; apply H1.
left; apply lt_INR_0; apply H.
left; apply Rmult_lt_0_compat.
apply lt_INR_0; apply div2_not_R0.
apply lt_n_S; apply H.
now apply IZR_lt.
cut (1 < S N)%nat.
intro; unfold Rsqr; apply prod_neq_R0; apply not_O_INR; intro;
assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4;
elim (lt_n_O _ H4).
apply lt_n_S; apply H.
assert (H1 := even_odd_cor N).
elim H1; intros N0 H2.
elim H2; intro.
pattern N at 2; rewrite H3.
rewrite div2_S_double.
right; rewrite H3; reflexivity.
pattern N at 2; rewrite H3.
replace (S (S (2 * N0))) with (2 * S N0)%nat.
rewrite div2_double.
rewrite H3.
rewrite S_INR; do 2 rewrite mult_INR.
rewrite (S_INR N0).
rewrite Rmult_plus_distr_l.
apply Rplus_le_compat_l.
rewrite Rmult_1_r.
simpl.
pattern 1 at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
apply Rlt_0_1.
ring.
unfold Rsqr; apply prod_neq_R0; apply INR_fact_neq_0.
unfold Rsqr; apply prod_neq_R0; apply not_O_INR; discriminate.
assert (H0 := even_odd_cor N).
elim H0; intros N0 H1.
elim H1; intro.
cut (0 < N0)%nat.
intro; rewrite H2.
rewrite div2_S_double.
replace (2 * N0)%nat with (S (S (2 * pred N0))).
replace (pred (S (S (2 * pred N0)))) with (S (2 * pred N0)).
rewrite div2_S_double.
apply S_pred with 0%nat; apply H3.
reflexivity.
omega.
omega.
rewrite H2.
replace (pred (S (2 * N0))) with (2 * N0)%nat; [ idtac | reflexivity ].
replace (S (S (2 * N0))) with (2 * S N0)%nat.
do 2 rewrite div2_double.
reflexivity.
ring.
apply S_pred with 0%nat; apply H.
Qed.

Lemma maj_Reste_cv_R0 : forall x y:R, Un_cv (maj_Reste_E x y) 0.
Proof.
intros; assert (H := Majxy_cv_R0 x y).
unfold Un_cv in H; unfold Un_cv; intros.
cut (0 < eps / 4);
[ intro
| unfold Rdiv; apply Rmult_lt_0_compat;
[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
elim (H _ H1); intros N0 H2.
exists (max (2 * S N0) 2); intros.
unfold R_dist in H2; unfold R_dist; rewrite Rminus_0_r;
unfold Majxy in H2; unfold maj_Reste_E.
rewrite Rabs_right.
apply Rle_lt_trans with
(4 *
(Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
INR (fact (div2 (pred n))))).
apply Rmult_le_compat_l.
left; prove_sup0.
unfold Rdiv, Rsqr; rewrite Rinv_mult_distr.
rewrite (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)));
rewrite
(Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n)))))
; rewrite Rmult_assoc; apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
apply Rle_trans with (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)).
rewrite Rmult_comm;
pattern (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)) at 2;
rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
apply pow_le; apply Rle_trans with 1.
left; apply Rlt_0_1.
apply RmaxLess1.
apply Rmult_le_reg_l with (INR (fact (div2 (pred n)))).
apply INR_fact_lt_0.
rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
apply (le_INR 1).
apply lt_le_S.
apply INR_lt.
apply INR_fact_lt_0.
apply INR_fact_neq_0.
apply Rle_pow.
apply RmaxLess1.
assert (H4 := even_odd_cor n).
elim H4; intros N1 H5.
elim H5; intro.
cut (0 < N1)%nat.
intro.
rewrite H6.
replace (pred (2 * N1)) with (S (2 * pred N1)).
rewrite div2_S_double.
omega.
omega.
assert (0 < n)%nat.
apply lt_le_trans with 2%nat.
apply lt_O_Sn.
apply le_trans with (max (2 * S N0) 2).
apply le_max_r.
apply H3.
omega.
rewrite H6.
replace (pred (S (2 * N1))) with (2 * N1)%nat.
rewrite div2_double.
replace (4 * S N1)%nat with (2 * (2 * S N1))%nat.
apply (fun m n p:nat => mult_le_compat_l p n m).
replace (2 * S N1)%nat with (S (S (2 * N1))).
apply le_n_Sn.
ring.
ring.
reflexivity.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply Rmult_lt_reg_l with (/ 4).
apply Rinv_0_lt_compat; prove_sup0.
rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_l; rewrite Rmult_comm.
replace
(Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
INR (fact (div2 (pred n)))) with
(Rabs
(Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
INR (fact (div2 (pred n))) - 0)).
apply H2; unfold ge.
cut (2 * S N0 <= n)%nat.
intro; apply le_S_n.
apply INR_le; apply Rmult_le_reg_l with (INR 2).
simpl; prove_sup0.
do 2 rewrite <- mult_INR; apply le_INR.
apply le_trans with n.
apply H4.
assert (H5 := even_odd_cor n).
elim H5; intros N1 H6.
elim H6; intro.
cut (0 < N1)%nat.
intro.
rewrite H7.
apply (fun m n p:nat => mult_le_compat_l p n m).
replace (pred (2 * N1)) with (S (2 * pred N1)).
rewrite div2_S_double.
replace (S (pred N1)) with N1.
apply le_n.
apply S_pred with 0%nat; apply H8.
replace (2 * N1)%nat with (S (S (2 * pred N1))).
reflexivity.
pattern N1 at 2; replace N1 with (S (pred N1)).
ring.
symmetry ; apply S_pred with 0%nat; apply H8.
apply INR_lt.
apply Rmult_lt_reg_l with (INR 2).
simpl; prove_sup0.
rewrite Rmult_0_r; rewrite <- mult_INR.
apply lt_INR_0.
rewrite <- H7.
apply lt_le_trans with 2%nat.
apply lt_O_Sn.
apply le_trans with (max (2 * S N0) 2).
apply le_max_r.
apply H3.
rewrite H7.
replace (pred (S (2 * N1))) with (2 * N1)%nat.
rewrite div2_double.
replace (2 * S N1)%nat with (S (S (2 * N1))).
apply le_n_Sn.
ring.
reflexivity.
apply le_trans with (max (2 * S N0) 2).
apply le_max_l.
apply H3.
rewrite Rminus_0_r; apply Rabs_right.
apply Rle_ge.
unfold Rdiv; apply Rmult_le_pos.
apply pow_le.
apply Rle_trans with 1.
left; apply Rlt_0_1.
apply RmaxLess1.
left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
discrR.
apply Rle_ge.
unfold Rdiv; apply Rmult_le_pos.
left; prove_sup0.
apply Rmult_le_pos.
apply pow_le.
apply Rle_trans with 1.
left; apply Rlt_0_1.
apply RmaxLess1.
left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
Qed.

Lemma Reste_E_cv : forall x y:R, Un_cv (Reste_E x y) 0.
Proof.
intros; assert (H := maj_Reste_cv_R0 x y).
unfold Un_cv in H; unfold Un_cv; intros; elim (H _ H0); intros.
exists (max x0 1); intros.
unfold R_dist; rewrite Rminus_0_r.
apply Rle_lt_trans with (maj_Reste_E x y n).
apply Reste_E_maj.
apply lt_le_trans with 1%nat.
apply lt_O_Sn.
apply le_trans with (max x0 1).
apply le_max_r.
apply H2.
replace (maj_Reste_E x y n) with (R_dist (maj_Reste_E x y n) 0).
apply H1.
unfold ge; apply le_trans with (max x0 1).
apply le_max_l.
apply H2.
unfold R_dist; rewrite Rminus_0_r; apply Rabs_right.
apply Rle_ge; apply Rle_trans with (Rabs (Reste_E x y n)).
apply Rabs_pos.
apply Reste_E_maj.
apply lt_le_trans with 1%nat.
apply lt_O_Sn.
apply le_trans with (max x0 1).
apply le_max_r.
apply H2.
Qed.

Lemma exp_plus : forall x y:R, exp (x + y) = exp x * exp y.
Proof. hammer_hook "Exp_prop" "Exp_prop.exp_plus".
intros; assert (H0 := E1_cvg x).
assert (H := E1_cvg y).
assert (H1 := E1_cvg (x + y)).
eapply UL_sequence.
apply H1.
assert (H2 := CV_mult _ _ _ _ H0 H).
assert (H3 := CV_minus _ _ _ _ H2 (Reste_E_cv x y)).
unfold Un_cv; unfold Un_cv in H3; intros.
elim (H3 _ H4); intros.
exists (S x0); intros.
rewrite <- (exp_form x y n).
rewrite Rminus_0_r in H5.
apply H5.
unfold ge; apply le_trans with (S x0).
apply le_n_Sn.
apply H6.
apply lt_le_trans with (S x0).
apply lt_O_Sn.
apply H6.
Qed.

Lemma exp_pos_pos : forall x:R, 0 < x -> 0 < exp x.
Proof. hammer_hook "Exp_prop" "Exp_prop.exp_pos_pos".
intros; set (An := fun N:nat => / INR (fact N) * x ^ N).
cut (Un_cv (fun n:nat => sum_f_R0 An n) (exp x)).
intro; apply Rlt_le_trans with (sum_f_R0 An 0).
unfold An; simpl; rewrite Rinv_1; rewrite Rmult_1_r;
apply Rlt_0_1.
apply sum_incr.
assumption.
intro; unfold An; left; apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat; apply INR_fact_lt_0.
apply (pow_lt _ n H).
unfold exp; unfold projT1; case (exist_exp x); intro.
unfold exp_in; unfold infinite_sum, Un_cv; trivial.
Qed.

Lemma exp_pos : forall x:R, 0 < exp x.
Proof. hammer_hook "Exp_prop" "Exp_prop.exp_pos".
intro; destruct (total_order_T 0 x) as [[Hlt|<-]|Hgt].
apply (exp_pos_pos _ Hlt).
rewrite exp_0; apply Rlt_0_1.
replace (exp x) with (1 / exp (- x)).
unfold Rdiv; apply Rmult_lt_0_compat.
apply Rlt_0_1.
apply Rinv_0_lt_compat; apply exp_pos_pos.
apply (Ropp_0_gt_lt_contravar _ Hgt).
cut (exp (- x) <> 0).
intro; unfold Rdiv; apply Rmult_eq_reg_l with (exp (- x)).
rewrite Rmult_1_l; rewrite <- Rinv_r_sym.
rewrite <- exp_plus.
rewrite Rplus_opp_l; rewrite exp_0; reflexivity.
apply H.
apply H.
assert (H := exp_plus x (- x)).
rewrite Rplus_opp_r in H; rewrite exp_0 in H.
red; intro; rewrite H0 in H.
rewrite Rmult_0_r in H.
elim R1_neq_R0; assumption.
Qed.

Lemma derivable_pt_lim_exp_0 : derivable_pt_lim exp 0 1.
Proof.
unfold derivable_pt_lim; intros.
set (fn := fun (N:nat) (x:R) => x ^ N / INR (fact (S N))).
cut (CVN_R fn).
intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }).
intro cv; cut (forall n:nat, continuity (fn n)).
intro; cut (continuity (SFL fn cv)).
intro; unfold continuity in H1.
assert (H2 := H1 0).
unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2;
unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
elim (H2 _ H); intros alp H3.
elim H3; intros.
exists (mkposreal _ H4); intros.
rewrite Rplus_0_l; rewrite exp_0.
replace ((exp h - 1) / h) with (SFL fn cv h).
replace 1 with (SFL fn cv 0).
apply H5.
split.
unfold D_x, no_cond; split.
trivial.
apply (not_eq_sym H6).
rewrite Rminus_0_r; apply H7.
unfold SFL.
case (cv 0) as (x,Hu).
eapply UL_sequence.
apply Hu.
unfold Un_cv, SP in |- *.
intros; exists 1%nat; intros.
unfold R_dist; rewrite decomp_sum.
rewrite (Rplus_comm (fn 0%nat 0)).
replace (fn 0%nat 0) with 1.
unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_r;
rewrite Rplus_0_r.
replace (sum_f_R0 (fun i:nat => fn (S i) 0) (pred n)) with 0.
rewrite Rabs_R0; apply H8.
symmetry ; apply sum_eq_R0; intros.
unfold fn.
simpl.
unfold Rdiv; do 2 rewrite Rmult_0_l; reflexivity.
unfold fn; simpl.
unfold Rdiv; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ].
unfold SFL, exp.
case (cv h) as (x0,Hu); case (exist_exp h) as (x,Hexp); simpl.
eapply UL_sequence.
apply Hu.
unfold Un_cv; intros.
unfold exp_in, infinite_sum in Hexp.
cut (0 < eps0 * Rabs h).
intro; elim (Hexp _ H9); intros N0 H10.
exists N0; intros.
unfold R_dist.
apply Rmult_lt_reg_l with (Rabs h).
apply Rabs_pos_lt; assumption.
rewrite <- Rabs_mult.
rewrite Rmult_minus_distr_l.
replace (h * ((x - 1) / h)) with (x - 1).
unfold R_dist in H10.
replace (h * SP fn n h - (x - 1)) with
(sum_f_R0 (fun i:nat => / INR (fact i) * h ^ i) (S n) - x).
rewrite (Rmult_comm (Rabs h)).
apply H10.
unfold ge.
apply le_trans with (S N0).
apply le_n_Sn.
apply le_n_S; apply H11.
rewrite decomp_sum.
replace (/ INR (fact 0) * h ^ 0) with 1.
unfold Rminus.
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
rewrite <- (Rplus_comm (- x)).
rewrite <- (Rplus_comm (- x + 1)).
rewrite Rplus_assoc; repeat apply Rplus_eq_compat_l.
replace (pred (S n)) with n; [ idtac | reflexivity ].
unfold SP.
rewrite scal_sum.
apply sum_eq; intros.
unfold fn.
replace (h ^ S i) with (h * h ^ i).
unfold Rdiv; ring.
simpl; ring.
simpl; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
apply lt_O_Sn.
unfold Rdiv.
rewrite <- Rmult_assoc.
symmetry ; apply Rinv_r_simpl_m.
assumption.
apply Rmult_lt_0_compat.
apply H8.
apply Rabs_pos_lt; assumption.
apply SFL_continuity; assumption.
intro; unfold fn.
replace (fun x:R => x ^ n / INR (fact (S n))) with
(pow_fct n / fct_cte (INR (fact (S n))))%F; [ idtac | reflexivity ].
apply continuity_div.
apply derivable_continuous; apply (derivable_pow n).
apply derivable_continuous; apply derivable_const.
intro; unfold fct_cte; apply INR_fact_neq_0.
apply (CVN_R_CVS _ X).
assert (H0 := Alembert_exp).
unfold CVN_R.
intro; unfold CVN_r.
exists (fun N:nat => r ^ N / INR (fact (S N))).
cut
{ l:R |
Un_cv
(fun n:nat =>
sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l }.
intros (x,p).
exists x; intros.
split.
apply p.
unfold Boule; intros.
rewrite Rminus_0_r in H1.
unfold fn.
unfold Rdiv; rewrite Rabs_mult.
cut (0 < INR (fact (S n))).
intro.
rewrite (Rabs_right (/ INR (fact (S n)))).
do 2 rewrite <- (Rmult_comm (/ INR (fact (S n)))).
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply H2.
rewrite <- RPow_abs.
apply pow_maj_Rabs.
rewrite Rabs_Rabsolu; left; apply H1.
apply Rle_ge; left; apply Rinv_0_lt_compat; apply H2.
apply INR_fact_lt_0.
cut ((r:R) <> 0).
intro; apply Alembert_C2.
intro; apply Rabs_no_R0.
unfold Rdiv; apply prod_neq_R0.
apply pow_nonzero; assumption.
apply Rinv_neq_0_compat; apply INR_fact_neq_0.
unfold Un_cv in H0.
unfold Un_cv; intros.
cut (0 < eps0 / r);
[ intro
| unfold Rdiv; apply Rmult_lt_0_compat;
[ assumption | apply Rinv_0_lt_compat; apply (cond_pos r) ] ].
elim (H0 _ H3); intros N0 H4.
exists N0; intros.
cut (S n >= N0)%nat.
intro hyp_sn.
assert (H6 := H4 _ hyp_sn).
unfold R_dist in H6; rewrite Rminus_0_r in H6.
rewrite Rabs_Rabsolu in H6.
unfold R_dist; rewrite Rminus_0_r.
rewrite Rabs_Rabsolu.
replace
(Rabs (r ^ S n / INR (fact (S (S n)))) / Rabs (r ^ n / INR (fact (S n))))
with (r * / INR (fact (S (S n))) * / / INR (fact (S n))).
rewrite Rmult_assoc; rewrite Rabs_mult.
rewrite (Rabs_right r).
apply Rmult_lt_reg_l with (/ r).
apply Rinv_0_lt_compat; apply (cond_pos r).
rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_l; rewrite <- (Rmult_comm eps0).
apply H6.
assumption.
apply Rle_ge; left; apply (cond_pos r).
unfold Rdiv.
repeat rewrite Rabs_mult.
repeat rewrite Rabs_Rinv.
rewrite Rinv_mult_distr.
repeat rewrite Rabs_right.
rewrite Rinv_involutive.
rewrite (Rmult_comm r).
rewrite (Rmult_comm (r ^ S n)).
repeat rewrite Rmult_assoc.
apply Rmult_eq_compat_l.
rewrite (Rmult_comm r).
rewrite <- Rmult_assoc; rewrite <- (Rmult_comm (INR (fact (S n)))).
apply Rmult_eq_compat_l.
simpl.
rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
ring.
apply pow_nonzero; assumption.
apply INR_fact_neq_0.
apply Rle_ge; left; apply INR_fact_lt_0.
apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
apply Rle_ge; left; apply INR_fact_lt_0.
apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
apply Rabs_no_R0; apply pow_nonzero; assumption.
apply Rinv_neq_0_compat; apply Rabs_no_R0; apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
unfold ge; apply le_trans with n.
apply H5.
apply le_n_Sn.
assert (H1 := cond_pos r); red; intro; rewrite H2 in H1;
elim (Rlt_irrefl _ H1).
Qed.

Lemma derivable_pt_lim_exp : forall x:R, derivable_pt_lim exp x (exp x).
Proof. hammer_hook "Exp_prop" "Exp_prop.derivable_pt_lim_exp".
intro; assert (H0 := derivable_pt_lim_exp_0).
unfold derivable_pt_lim in H0; unfold derivable_pt_lim; intros.
cut (0 < eps / exp x);
[ intro
| unfold Rdiv; apply Rmult_lt_0_compat;
[ apply H | apply Rinv_0_lt_compat; apply exp_pos ] ].
elim (H0 _ H1); intros del H2.
exists del; intros.
assert (H5 := H2 _ H3 H4).
rewrite Rplus_0_l in H5; rewrite exp_0 in H5.
replace ((exp (x + h) - exp x) / h - exp x) with
(exp x * ((exp h - 1) / h - 1)).
rewrite Rabs_mult; rewrite (Rabs_right (exp x)).
apply Rmult_lt_reg_l with (/ exp x).
apply Rinv_0_lt_compat; apply exp_pos.
rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
apply H5.
assert (H6 := exp_pos x); red; intro; rewrite H7 in H6;
elim (Rlt_irrefl _ H6).
apply Rle_ge; left; apply exp_pos.
rewrite Rmult_minus_distr_l.
rewrite Rmult_1_r; unfold Rdiv; rewrite <- Rmult_assoc;
rewrite Rmult_minus_distr_l.
rewrite Rmult_1_r; rewrite exp_plus; reflexivity.
Qed.