(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import SeqProp.
Require Import PartSum.
Require Import Max.
Local Open Scope R_scope.

(**********)
(** * Formalization of alternated series *)
Definition tg_alt (Un:nat -> R) (i:nat) : R := (-1) ^ i * Un i.
Definition positivity_seq (Un:nat -> R) : Prop := forall n:nat, 0 <= Un n.

Lemma CV_ALT_step0 :
  forall Un:nat -> R,
    Un_decreasing Un ->
    Un_growing (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
Proof.
  intros; unfold Un_growing; intro.
  cut ((2 * S n)%nat = S (S (2 * n))).
  intro; rewrite H0.
  do 4 rewrite tech5; repeat rewrite Rplus_assoc; apply Rplus_le_compat_l.
  pattern (tg_alt Un (S (2 * n))) at 1; rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
    rewrite Rmult_1_l.
  apply Rplus_le_reg_l with (Un (S (2 * S n))).
  rewrite Rplus_0_r;
    replace (Un (S (2 * S n)) + (Un (2 * S n)%nat + -1 * Un (S (2 * S n)))) with
      (Un (2 * S n)%nat); [ idtac | ring ].
  apply H.
  cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
  rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
Qed.

Lemma CV_ALT_step1 :
  forall Un:nat -> R,
    Un_decreasing Un ->
    Un_decreasing (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)).
Proof.
  intros; unfold Un_decreasing; intro.
  cut ((2 * S n)%nat = S (S (2 * n))).
  intro; rewrite H0; do 2 rewrite tech5; repeat rewrite Rplus_assoc.
  pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2; rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
    rewrite Rmult_1_l.
  apply Rplus_le_reg_l with (Un (S (2 * n))).
  rewrite Rplus_0_r;
    replace (Un (S (2 * n)) + (-1 * Un (S (2 * n)) + Un (2 * S n)%nat)) with
      (Un (2 * S n)%nat); [ idtac | ring ].
  rewrite H0; apply H.
  cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
  rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
Qed.

(**********)
Lemma CV_ALT_step2 :
  forall (Un:nat -> R) (N:nat),
    Un_decreasing Un ->
    positivity_seq Un ->
    sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; unfold tg_alt; simpl; rewrite Rmult_1_r.
  replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ].
  apply Rplus_le_reg_l with (Un 1%nat); rewrite Rplus_0_r.
  replace (Un 1%nat + (-1 * Un 1%nat + Un 2%nat)) with (Un 2%nat);
    [ apply H | ring ].
  cut (S (2 * S N) = S (S (S (2 * N)))).
  intro; rewrite H1; do 2 rewrite tech5.
  apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))).
  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2;
    rewrite <- Rplus_0_r.
  rewrite Rplus_assoc; apply Rplus_le_compat_l.
  unfold tg_alt; rewrite <- H1.
  rewrite pow_1_odd.
  cut (S (S (2 * S N)) = (2 * S (S N))%nat).
  intro; rewrite H2; rewrite pow_1_even; rewrite Rmult_1_l; rewrite <- H2.
  apply Rplus_le_reg_l with (Un (S (2 * S N))).
  rewrite Rplus_0_r;
    replace (Un (S (2 * S N)) + (-1 * Un (S (2 * S N)) + Un (S (S (2 * S N)))))
      with (Un (S (S (2 * S N)))); [ idtac | ring ].
  apply H.
  ring.
  apply HrecN.
  ring.
Qed.

(** A more general inequality *)
Lemma CV_ALT_step3 :
  forall (Un:nat -> R) (N:nat),
    Un_decreasing Un ->
    positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; unfold tg_alt; simpl; rewrite Rmult_1_r.
  apply Rplus_le_reg_l with (Un 1%nat).
  rewrite Rplus_0_r; replace (Un 1%nat + -1 * Un 1%nat) with 0;
    [ apply H0 | ring ].
  assert (H1 := even_odd_cor N).
  elim H1; intros.
  elim H2; intro.
  rewrite H3; apply CV_ALT_step2; assumption.
  rewrite H3; rewrite tech5.
  apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))).
  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2;
    rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  unfold tg_alt; simpl.
  replace (x + (x + 0))%nat with (2 * x)%nat; [ idtac | ring ].
  rewrite pow_1_even.
  replace (-1 * (-1 * (-1 * 1)) * Un (S (S (S (2 * x))))) with
    (- Un (S (S (S (2 * x))))); [ idtac | ring ].
  apply Rplus_le_reg_l with (Un (S (S (S (2 * x))))).
  rewrite Rplus_0_r; rewrite Rplus_opp_r.
  apply H0.
  apply CV_ALT_step2; assumption.
Qed.

  (**********)
Lemma CV_ALT_step4 :
  forall Un:nat -> R,
    Un_decreasing Un ->
    positivity_seq Un ->
    has_ub (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
Proof.
  intros; unfold has_ub; unfold bound.
  exists (Un 0%nat).
  unfold is_upper_bound; intros; elim H1; intros.
  rewrite H2; rewrite decomp_sum.
  replace (tg_alt Un 0) with (Un 0%nat).
  pattern (Un 0%nat) at 2; rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  apply CV_ALT_step3; assumption.
  unfold tg_alt; simpl; ring.
  apply lt_O_Sn.
Qed.

(** This lemma gives an interesting result about alternated series *)
Lemma CV_ALT :
  forall Un:nat -> R,
    Un_decreasing Un ->
    positivity_seq Un ->
    Un_cv Un 0 ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }.
Proof.
  intros.
  assert (H2 := CV_ALT_step0 _ H).
  assert (H3 := CV_ALT_step4 _ H H0).
  destruct (growing_cv _ H2 H3) as (x,p).
  exists x.
  unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
    unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p.
  intros; cut (0 < eps / 2);
    [ intro
      | unfold Rdiv; apply Rmult_lt_0_compat;
	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (H1 (eps / 2) H5); intros N2 H6.
  elim (p (eps / 2) H5); intros N1 H7.
  set (N := max (S (2 * N1)) N2).
  exists N; intros.
  assert (H9 := even_odd_cor n).
  elim H9; intros P H10.
  cut (N1 <= P)%nat.
  intro; elim H10; intro.
  replace (sum_f_R0 (tg_alt Un) n - x) with
    (sum_f_R0 (tg_alt Un) (S n) - x + - tg_alt Un (S n)).
  apply Rle_lt_trans with
    (Rabs (sum_f_R0 (tg_alt Un) (S n) - x) + Rabs (- tg_alt Un (S n))).
  apply Rabs_triang.
  rewrite (double_var eps); apply Rplus_lt_compat.
  rewrite H12; apply H7; assumption.
  rewrite Rabs_Ropp; unfold tg_alt; rewrite Rabs_mult;
    rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6;
      rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n)));
	apply H6.
  unfold ge; apply le_trans with n.
  apply le_trans with N; [ unfold N; apply le_max_r | assumption ].
  apply le_n_Sn.
  rewrite tech5; ring.
  rewrite H12; apply Rlt_trans with (eps / 2).
  apply H7; assumption.
  unfold Rdiv; apply Rmult_lt_reg_l with 2.
  prove_sup0.
  rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
    [ rewrite Rmult_1_r | discrR ].
  rewrite double.
  pattern eps at 1; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l;
    assumption.
  elim H10; intro; apply le_double.
  rewrite <- H11; apply le_trans with N.
  unfold N; apply le_trans with (S (2 * N1));
    [ apply le_n_Sn | apply le_max_l ].
  assumption.
  apply lt_n_Sm_le.
  rewrite <- H11.
  apply lt_le_trans with N.
  unfold N; apply lt_le_trans with (S (2 * N1)).
  apply lt_n_Sn.
  apply le_max_l.
  assumption.
Qed.

(*************************************************)
(** *       Convergence of alternated series     *)
Theorem alternated_series :
  forall Un:nat -> R,
    Un_decreasing Un ->
    Un_cv Un 0 ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }.
Proof.
  intros; apply CV_ALT.
  assumption.
  unfold positivity_seq; apply decreasing_ineq; assumption.
  assumption.
Qed.

Theorem alternated_series_ineq :
  forall (Un:nat -> R) (l:R) (N:nat),
    Un_decreasing Un ->
    Un_cv Un 0 ->
    Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l ->
    sum_f_R0 (tg_alt Un) (S (2 * N)) <= l <= sum_f_R0 (tg_alt Un) (2 * N).
Proof.
  intros.
  cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)) l).
  cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))) l).
  intros; split.
  apply (growing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N)))).
  apply CV_ALT_step0; assumption.
  assumption.
  apply (decreasing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N))).
  apply CV_ALT_step1; assumption.
  assumption.
  unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
    unfold R_dist in H1; intros.
  elim (H1 eps H2); intros.
  exists x; intros.
  apply H3.
  unfold ge; apply le_trans with (2 * n)%nat.
  apply le_trans with n.
  assumption.
  assert (H5 := mult_O_le n 2).
  elim H5; intro.
  cut (0%nat <> 2%nat);
    [ intro; elim H7; symmetry ; assumption | discriminate ].
  assumption.
  apply le_n_Sn.
  unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
    unfold R_dist in H1; intros.
  elim (H1 eps H2); intros.
  exists x; intros.
  apply H3.
  unfold ge; apply le_trans with n.
  assumption.
  assert (H5 := mult_O_le n 2).
  elim H5; intro.
  cut (0%nat <> 2%nat);
    [ intro; elim H7; symmetry ; assumption | discriminate ].
  assumption.
Qed.

(***************************************)
(** * Application : construction of PI *)
(***************************************)

Definition PI_tg (n:nat) := / INR (2 * n + 1).

Lemma PI_tg_pos : forall n:nat, 0 <= PI_tg n.
Proof.
  intro; unfold PI_tg; left; apply Rinv_0_lt_compat; apply lt_INR_0;
    replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
Qed.

Lemma PI_tg_decreasing : Un_decreasing PI_tg.
Proof.
  unfold PI_tg, Un_decreasing; intro.
  apply Rmult_le_reg_l with (INR (2 * n + 1)).
  apply lt_INR_0.
  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (2 * S n + 1)).
  apply lt_INR_0.
  replace (2 * S n + 1)%nat with (S (2 * S n)); [ apply lt_O_Sn | ring ].
  rewrite (Rmult_comm (INR (2 * S n + 1))); rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  do 2 rewrite Rmult_1_r; apply le_INR.
  replace (2 * S n + 1)%nat with (S (S (2 * n + 1))).
  apply le_trans with (S (2 * n + 1)); apply le_n_Sn.
  ring.
  apply not_O_INR; discriminate.
  apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
    [ discriminate | ring ].
Qed.

Lemma PI_tg_cv : Un_cv PI_tg 0.
Proof.
  unfold Un_cv; unfold R_dist; intros.
  cut (0 < 2 * eps);
    [ intro | apply Rmult_lt_0_compat; [ prove_sup0 | assumption ] ].
  assert (H1 := archimed (/ (2 * eps))).
  cut (0 <= up (/ (2 * eps)))%Z.
  intro; assert (H3 := IZN (up (/ (2 * eps))) H2).
  elim H3; intros N H4.
  cut (0 < N)%nat.
  intro; exists N; intros.
  cut (0 < n)%nat.
  intro; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r;
    rewrite Rabs_right.
  unfold PI_tg; apply Rlt_trans with (/ INR (2 * n)).
  apply Rmult_lt_reg_l with (INR (2 * n)).
  apply lt_INR_0.
  replace (2 * n)%nat with (n + n)%nat; [ idtac | ring ].
  apply lt_le_trans with n.
  assumption.
  apply le_plus_l.
  rewrite <- Rinv_r_sym.
  apply Rmult_lt_reg_l with (INR (2 * n + 1)).
  apply lt_INR_0.
  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
  rewrite (Rmult_comm (INR (2 * n + 1))).
  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  do 2 rewrite Rmult_1_r; apply lt_INR.
  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_n_Sn | ring ].
  apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
    [ discriminate | ring ].
  replace n with (S (pred n)).
  apply not_O_INR; discriminate.
  symmetry ; apply S_pred with 0%nat.
  assumption.
  apply Rle_lt_trans with (/ INR (2 * N)).
  apply Rinv_le_contravar.
  rewrite mult_INR; apply Rmult_lt_0_compat;
    [ simpl; prove_sup0 | apply lt_INR_0; assumption ].
  apply le_INR.
  now apply mult_le_compat_l.
  rewrite mult_INR.
  apply Rmult_lt_reg_l with (INR N / eps).
  apply Rdiv_lt_0_compat with (2 := H).
  now apply (lt_INR 0).
  replace (_ */ _) with (/(2 * eps)).
  replace (_ / _ * _) with (INR N).
  rewrite INR_IZR_INZ.
  now rewrite <- H4.
  field.
  now apply Rgt_not_eq.
  simpl (INR 2); field; split.
  now apply Rgt_not_eq, (lt_INR 0).
  now apply Rgt_not_eq.
  apply Rle_ge; apply PI_tg_pos.
  apply lt_le_trans with N; assumption.
  elim H1; intros H5 _.
  destruct (lt_eq_lt_dec 0 N) as [[| <- ]|H6].
  assumption.
  rewrite H4 in H5.
  simpl in H5.
  cut (0 < / (2 * eps)); [ intro | apply Rinv_0_lt_compat; assumption ].
  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H6 H5)).
  elim (lt_n_O _ H6).
  apply le_IZR.
  left; apply Rlt_trans with (/ (2 * eps)).
  apply Rinv_0_lt_compat; assumption.
  elim H1; intros; assumption.
Qed.

Lemma exist_PI :
  { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l }.
Proof.
  apply alternated_series.
  apply PI_tg_decreasing.
  apply PI_tg_cv.
Qed.

(** Now, PI is defined *)
Definition Alt_PI : R := 4 * (let (a,_) := exist_PI in a).

(** We can get an approximation of PI with the following inequality *)
Lemma Alt_PI_ineq :
  forall N:nat,
    sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= Alt_PI / 4 <=
    sum_f_R0 (tg_alt PI_tg) (2 * N).
Proof.
  intro; apply alternated_series_ineq.
  apply PI_tg_decreasing.
  apply PI_tg_cv.
  unfold Alt_PI; case exist_PI; intro.
  replace (4 * x / 4) with x.
  trivial.
  unfold Rdiv; rewrite (Rmult_comm 4); rewrite Rmult_assoc;
    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | discrR ].
Qed.

Lemma Alt_PI_RGT_0 : 0 < Alt_PI.
Proof.
  assert (H := Alt_PI_ineq 0).
  apply Rmult_lt_reg_l with (/ 4).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite Rmult_0_r; rewrite Rmult_comm.
  elim H; clear H; intros H _.
  unfold Rdiv in H;
    apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))).
  simpl; unfold tg_alt; simpl; rewrite Rmult_1_l;
    rewrite Rmult_1_r; apply Rplus_lt_reg_l with (PI_tg 1).
  rewrite Rplus_0_r;
    replace (PI_tg 1 + (PI_tg 0 + -1 * PI_tg 1)) with (PI_tg 0);
      [ unfold PI_tg | ring ].
  simpl; apply Rinv_lt_contravar.
  rewrite Rmult_1_l; replace (2 + 1) with 3; [ prove_sup0 | ring ].
  rewrite Rplus_comm; pattern 1 at 1; rewrite <- Rplus_0_r;
    apply Rplus_lt_compat_l; prove_sup0.
  assumption.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

Require Import BBST.Theory.Ordinal.
Local Hint Resolve 𝐎𝐍为传递类 : core.
Local Hint Immediate ω为序数集 : core.

Notation 有限递增 F := (∀n ∈ ω, F n ∈ F n⁺).
Notation 有限保序 F := (∀n ∈ ω, ∀m ∈ n, F m ∈ F n).

Notation 有限弱递增 F := (∀n ∈ ω, F n ⋸ F n⁺).
Notation 有限弱保序 F := (∀n ∈ ω, ∀m ∈ n, F m ⋸ F n).

Notation 为序数运算 F := (∀α ⋵ 𝐎𝐍, F α ⋵ 𝐎𝐍).
Notation 后继处递增 F := (∀α ⋵ 𝐎𝐍, F α ∈ F α⁺).
Notation 极限处连续 F := (∀α ⋵ 𝐋𝐈𝐌, α ≠ ∅ → F α = sup{F β | β ∊ α}).
Definition 为序数嵌入 := λ F, 为序数运算 F ∧ 后继处递增 F ∧ 极限处连续 F.

Definition 保序 := λ F, ∀α ⋵ 𝐎𝐍, ∀β ∈ α, F β ∈ F α.
Definition 双向保序 := λ F, ∀ α β ⋵ 𝐎𝐍, α ∈ β ↔ F α ∈ F β.
Definition 非无穷降链 := λ F, ∀α ⋵ 𝐎𝐍, α ⋸ F α.

Lemma 弱递增无穷序列极限与起始无关 : ∀n ∈ ω, ∀ F, 为序数运算 F → 有限弱递增 F →
  sup {F k | k ∊ ω - n⁺} = sup {F k⁺ | k ∊ ω - n}.
Proof with auto.
  intros n Hn F 运算 递增. 外延.
  - apply 集族并除去 in H as [k [Hk H]]. apply 分离除去 in Hk as [Hk Hk'].
    apply 集族并介入 with k. apply 分离介入... apply 序数传递_右弱 with (F k)...
  - apply 集族并除去 in H as [k [Hk H]]. apply 分离除去 in Hk as [Hk Hk'].
    apply 集族并介入 with k⁺⁺. apply 分离介入... 2: apply 序数传递_右弱 with (F k⁺)...
    intros H'. apply Hk'. apply 后继保序... apply 序数传递 with k⁺⁺...
Qed.

Lemma 弱保序无穷序列极限与起始无关 : ∀n ∈ ω, ∀ F, 为序数运算 F → 有限弱保序 F →
  sup {F k | k ∊ ω} = sup {F k | k ∊ ω - n}.
Proof with auto.
  intros n Hn F 运算 保序. 外延.
  - apply 集族并除去 in H as [k [Hk H]]. 排中 (k ∈ n).
    + apply 集族并介入 with n. apply 分离介入...
      apply 序数传递_右弱 with (F k)...
    + apply 集族并介入 with k... apply 分离介入...
  - apply 集族并除去 in H as [k [Hk H]].
    apply 分离之父集 in Hk. apply 集族并介入 with k...
Qed.

Theorem 序数嵌入保序 : ∀ F, 为序数嵌入 F → 保序 F.
Proof with auto.
  intros F [运算 [递增 连续]]. unfold 保序.
  超限归纳. intros β 小于. 超限讨论 α.
  - 空集归谬.
  - apply 后继除去 in 小于 as []. apply 序数传递 with (F α)... subst...
  - rewrite (连续 α)... apply 集族并介入 with β⁺.
    apply 极限序数有其任意元素的后继... apply 递增. eauto.
Qed.

Theorem 保序运算双向保序 : ∀ F, 为序数运算 F → 保序 F → 双向保序 F.
Proof with auto.
  intros F HF 保序 α Hα β Hβ. split...
  intros Hlt. destruct (序数三歧 α Hα β Hβ) as [|[]]...
  - exfalso. subst. apply 序数反自反 with (F β)...
  - exfalso. apply 保序 in H... apply 序数可换 in H...
Qed.

Corollary 序数嵌入双向保序 : ∀ F, 为序数嵌入 F → 双向保序 F.
Proof. intros. apply 保序运算双向保序. apply H. apply 序数嵌入保序, H. Qed.

Theorem 保序运算非无穷降链 : ∀ F, 为序数运算 F → 保序 F → 非无穷降链 F.
Proof with auto.
  intros F 运算 保序 α Hα. 反证. apply 序数可换 in 反设...
  generalize dependent α. 超限归纳. intros Hlt. apply 归纳假设 with (F α)...
Qed.

Corollary 序数嵌入非无穷降链 : ∀ F, 为序数嵌入 F → 非无穷降链 F.
Proof. intros. apply 保序运算非无穷降链. apply H. apply 序数嵌入保序, H. Qed.

Theorem 保序运算为类单射 : ∀ F, 为序数运算 F → 保序 F → 为类单射 𝐎𝐍 F.
Proof with auto.
  intros F 运算 保序 α Hα β Hβ 相等.
  destruct (序数三歧 α Hα β Hβ) as [|[]]; auto; exfalso; apply 保序 in H...
  apply 小于则不等 with (F β) (F α)...
  apply 小于则不等 with (F α) (F β)...
Qed.

Corollary 序数嵌入为类单射 : ∀ F, 为序数嵌入 F → 为类单射 𝐎𝐍 F.
Proof. intros. apply 保序运算为类单射. apply H. apply 序数嵌入保序, H. Qed.

Theorem 序数嵌入在极限处的值为极限 : ∀ F, 为序数嵌入 F → ∀α ⋵ 𝐋𝐈𝐌, α ≠ ∅ → F α ⋵ 𝐋𝐈𝐌.
Proof with auto.
  intros F [运算 [递增 连续]] α 极限 H0. copy 极限 as [Hα _].
  rewrite 连续... split.
  - apply 序数集的并为序数. intros y Hy.
    apply 替代除去 in Hy as [ξ [Hξ HFξ]]. subst y. apply 运算. eauto.
  - 外延 β Hβ.
    + apply 并集除去 in Hβ as [γ [Hγ Hβ]].
      apply 集族并除去 in Hγ as [ξ [Hξ HFξ]].
      apply 集族并介入 with ξ... apply 序数传递 with γ... apply 运算. eauto.
    + apply 集族并除去 in Hβ as [ξ [Hξ HFξ]]. apply 并集介入 with (F ξ)...
      apply 集族并介入 with ξ⁺... apply 极限序数有其任意元素的后继... apply 递增... eauto.
Qed.

Theorem 上确界的嵌入等于嵌入集的上确界 : ∀ F, 为序数嵌入 F →
  ∀ A, A ≠ ∅ → A ⪽ 𝐎𝐍 → F (sup A) = sup {F α | α ∊ A}.
Proof with auto.
  intros F HF A H0 HA.
  assert (Hs: sup A ⋵ 𝐎𝐍). apply 序数集的并为序数...
  assert (HFs: F (sup A) ⋵ 𝐎𝐍). apply HF...
  assert (Hr: {F α | α ∊ A} ⪽ 𝐎𝐍). {
    intros x Hx. apply 替代除去 in Hx as [α [Hα H]]. subst x. apply HF...
  }
  assert (Hsr: sup {F α | α ∊ A} ⋵ 𝐎𝐍). apply 序数集的并为序数...
  apply 包含的反对称性.
  - remember (sup A) as σ. 超限讨论 σ.
    + apply 小于等于即包含... apply 序数集的并为上界... apply 替代介入_自动... rewrite H1.
      apply 仅零或一之并为零 in H1 as []. exfalso... subst...
    + apply 小于等于即包含... apply 序数集的并为上界... apply 替代介入_自动.
      apply 为后继的上确界在序数集内... exists σ...
    + intros x Hx. copy HF as [_ [_ 连续]]. rewrite 连续 in Hx...
      apply 集族并除去 in Hx as [α [Hα Hx]]. rewrite Heqσ in Hα.
      apply 并集除去 in Hα as [β [Hβ Hα]]. apply 集族并介入 with β...
      apply 序数传递 with (F α)... apply 序数嵌入保序...
  - intros x Hx. apply 集族并除去 in Hx as [α [Hα Hx]].
    apply 序数集的并为上界 in HA as [_ Hle]. apply Hle in Hα as [].
    apply 序数传递 with (F α)... apply 序数嵌入保序... congruence.
Qed.

Section 序数递归.
Import 超限递归模板_三指定.
Variable y₀ : 集合.
Variable F : 函数类型.

Definition 序数递归 := 三指定 y₀ F (λ f, sup (ran f)).
Local Notation 𝗥 := 序数递归.

Theorem 序数递归_0 : 𝗥 ∅ = y₀.
Proof. apply 三指定_0. Qed.

Theorem 序数递归_后继 : ∀α ⋵ 𝐎𝐍, 𝗥 α⁺ = F (𝗥 α).
Proof. apply 三指定_后继. Qed.

Theorem 序数递归_极限 : 极限处连续 𝗥.
Proof. intros α 极限 非零. rewrite <- 类函数限制之值域. apply 三指定_极限; auto. Qed.

End 序数递归.

Theorem 序数运算的递归为序数运算 : ∀y₀ ⋵ 𝐎𝐍, ∀ F, 为序数运算 F → 为序数运算 (序数递归 y₀ F).
Proof with auto.
  intros y₀ Hy₀ F H. 超限归纳. 超限讨论 α.
  - rewrite 序数递归_0...
  - rewrite 序数递归_后继...
  - rewrite 序数递归_极限...
    apply 序数集的并为序数. intros x Hx.
    apply 替代除去 in Hx as [β [Hβ Hx]]. subst. apply 归纳假设...
Qed.

Section 缺零递归.
Import 超限递归模板_三指定.
Variable y₀ : 集合.
Variable F : 函数类型.

Definition 缺零递归 := 三指定 y₀ F (λ f, sup (ran (f ↾ (dom f - {∅,})))).
Local Notation 𝗥 := 缺零递归.

Theorem 缺零递归_0 : 𝗥 ∅ = y₀.
Proof. apply 三指定_0. Qed.

Theorem 缺零递归_后继 : ∀α ⋵ 𝐎𝐍, 𝗥 α⁺ = F (𝗥 α).
Proof. apply 三指定_后继. Qed.

Theorem 缺零递归_极限 : ∀α ⋵ 𝐋𝐈𝐌, α ≠ ∅ → 𝗥 α = sup{𝗥 β | β ∊ α - {∅,}}.
Proof with auto.
  intros α 极限 非零. rewrite <- 类函数限制之值域. set (𝗥 ↑ α) as f.
  replace (𝗥 ↑ α - {∅,}) with (f ↾ (dom f - {∅,})). apply 三指定_极限...
  unfold f. rewrite 类函数限制之定义域. apply 类函数限制到父再子...
Qed.

End 缺零递归.

Theorem 序数运算的缺零递归为序数运算 : ∀y₀ ⋵ 𝐎𝐍, ∀ F, 为序数运算 F → 为序数运算 (缺零递归 y₀ F).
Proof with auto.
  intros y₀ Hy₀ F H. 超限归纳. 超限讨论 α.
  - rewrite 缺零递归_0...
  - rewrite 缺零递归_后继...
  - rewrite 缺零递归_极限...
    apply 序数集的并为序数. intros x Hx. apply 替代除去 in Hx as [β [Hβ Hx]].
    apply 分离之父集 in Hβ. subst. apply 归纳假设...
Qed.

Section 任意不动点.
Variable F : 函数类型.
Variable F嵌入 : 为序数嵌入 F.
Variable α : 集合.
Variable Hα : α ⋵ 𝐎𝐍.

Local Notation G := (序数递归 α F).
Local Notation A := {G n | n ∊ ω}.
Definition 任意不动点 := sup A.
Local Notation β := 任意不动点.

Local Lemma A非空 : A ≠ ∅.
Proof. apply 非空除去. exists (G ∅). apply 替代介入_自动; auto. Qed.

Local Lemma A为序数集 : A ⪽ 𝐎𝐍.
Proof with auto.
  intros x Hx. apply 替代除去 in Hx as [n [Hn HGn]]. subst x.
  apply 序数运算的递归为序数运算... apply F嵌入.
Qed.

Local Lemma β为序数 : β ⋵ 𝐎𝐍.
Proof. apply 序数集的并为序数. apply A为序数集. Qed.

Local Lemma β任意大 : α ⋸ β.
Proof with auto.
  apply 序数集的并为上界. apply A为序数集.
  apply 替代介入. exists ∅. split... rewrite 序数递归_0...
Qed.

Local Lemma β为不动点 : F β = β.
Proof with auto.
  unfold β. rewrite (上确界的嵌入等于嵌入集的上确界 F F嵌入 A A非空 A为序数集). 外延.
  - apply 集族并除去 in H as [γ [Hγ H]].
    apply 替代除去 in Hγ as [n [Hn Hγ]]. subst.
    apply 并集介入 with (G n⁺). apply 替代介入_自动... rewrite 序数递归_后继...
  - apply 并集除去 in H as [γ [Hγ Hx]].
    apply 替代除去 in Hγ as [n [Hn Hγ]]. subst.
    apply 集族并介入 with (G n). apply 替代介入_自动... copy F嵌入 as [HF _].
    assert (G n ⋵ 𝐎𝐍). apply 序数运算的递归为序数运算...
    generalize dependent x. apply 小于等于即包含...
    apply 保序运算非无穷降链... apply 序数嵌入保序...
Qed.

Lemma 不动点为之 : β ⋵ 𝐎𝐍 ∧ F β = β ∧ α ⋸ β.
Proof. split3. apply β为序数. apply β为不动点. apply β任意大. Qed.

(* Veblen不动点定理：序数嵌入存在任意大的不动点 *)
Theorem 不动点定理 : ∃β ⋵ 𝐎𝐍, F β = β ∧ α ⋸ β.
Proof. exists β. apply 不动点为之. Qed.

End 任意不动点.

Section 最小不动点.
Variable F : 函数类型.
Variable F嵌入 : 为序数嵌入 F.

Local Notation β := (任意不动点 F ∅).

Definition 最小不动点 := inf {γ ∊ β⁺ | F γ = γ}.
Local Notation β₀ := 最小不动点.

Lemma 最小不动点为之 : β₀ ⋵ 𝐎𝐍 ∧ F β₀ = β₀ ∧ ∀γ ⋵ 𝐎𝐍, F γ = γ → β₀ ⋸ γ.
Proof. apply 满足条件的最小序数为之. apply β为序数; auto. apply β为不动点; auto. Qed.

Theorem 存在最小不动点 : ∃β ⋵ 𝐎𝐍, F β = β ∧ ∀γ ⋵ 𝐎𝐍, F γ = γ → β ⋸ γ.
Proof. exists β₀. apply 最小不动点为之. Qed.

End 最小不动点.

Section 后继不动点.
Variable F : 函数类型.
Variable F嵌入 : 为序数嵌入 F.
Variable α : 集合.
Variable Hα : α ⋵ 𝐎𝐍.

Definition 后继不动点 := 任意不动点 F α⁺.
Local Notation β := 后继不动点.
Local Notation 𝗥 := 序数递归.

Lemma 后继不动点为之 : β ⋵ 𝐎𝐍 ∧ F β = β ∧ α ∈ β ∧
  ∀γ ⋵ 𝐎𝐍, F γ = γ → α ∈ γ → β ⋸ γ.
Proof with auto.
  assert (Hβ: β ⋵ 𝐎𝐍). apply β为序数...
  split3... apply β为不动点... split. apply 小于即后继小于等于... apply β任意大...
  intros γ Hγ 不动点γ Hαγ. 反证. apply 序数可换 in 反设...
  apply 集族并除去 in 反设 as [n [Hn H]].
  generalize dependent H. 归纳 n; intros H.
  - rewrite 序数递归_0 in H. apply 序数不稠密 with γ α...
  - apply 归纳假设. apply 序数嵌入双向保序 with F...
    apply 序数运算的递归为序数运算... apply F嵌入.
    rewrite 不动点γ, <- 序数递归_后继...
Qed.

Theorem 存在后继不动点 : ∃β ⋵ 𝐎𝐍, F β = β ∧ α ∈ β ∧
  ∀γ ⋵ 𝐎𝐍, F γ = γ → α ∈ γ → β ⋸ γ.
Proof. exists β. apply 后继不动点为之. Qed.

End 后继不动点.

Section 不动点枚举.
Variable F : 函数类型.
Variable F嵌入 : 为序数嵌入 F.
Variable F非平凡 : ∀α ⋵ 𝐎𝐍, F α⁺ ≠ α⁺.

Local Notation α₀ := (最小不动点 F).
Local Notation S := (后继不动点 F).
Definition 不动点枚举 := 序数递归 α₀ S.
Local Notation G := 不动点枚举.

Lemma 最小不动点为序数 : α₀ ⋵ 𝐎𝐍.
Proof. apply 最小不动点为之. auto. Qed.

Lemma 后继不动点为序数运算 : 为序数运算 S.
Proof. intros. apply 后继不动点为之; auto. Qed.

Lemma 不动点枚举为序数运算 : 为序数运算 G.
Proof. apply 序数运算的递归为序数运算. apply 最小不动点为序数. apply 后继不动点为序数运算. Qed.

Lemma 不动点枚举_0 : G ∅ = α₀.
Proof. apply 序数递归_0. Qed.

Lemma 不动点枚举_后继 : ∀α ⋵ 𝐎𝐍, G α⁺ = S (G α).
Proof. apply 序数递归_后继. Qed.

Lemma 不动点枚举_极限 : 极限处连续 G.
Proof. apply 序数递归_极限. Qed.

Lemma 不动点枚举在后继处递增 : 后继处递增 G.
Proof with auto.
  intros. rewrite 不动点枚举_后继... apply 后继不动点为之... apply 不动点枚举为序数运算...
Qed.

Theorem 不动点枚举为序数嵌入 : 为序数嵌入 G.
Proof. split3. apply 不动点枚举为序数运算. apply 不动点枚举在后继处递增. apply 不动点枚举_极限. Qed.

Corollary 存在不动点的不动点 : ∀α ⋵ 𝐎𝐍, ∃β ⋵ 𝐎𝐍, G β = β ∧ α ⋸ β.
Proof. intros. apply 不动点定理; auto. apply 不动点枚举为序数嵌入. Qed.

Theorem 不动点枚举枚举之 : ∀α ⋵ 𝐎𝐍, F (G α) = G α.
Proof with auto.
  超限归纳. 超限讨论 α.
  - rewrite 不动点枚举_0. apply 最小不动点为之...
  - rewrite 不动点枚举_后继... apply 后继不动点为之... apply 不动点枚举为序数运算...
  - rewrite 不动点枚举_极限, 上确界的嵌入等于嵌入集的上确界...
    2: { apply 非空除去. exists (不动点枚举 ∅). apply 替代介入. exists ∅... }
    2: { intros x Hx. apply 替代除去 in Hx as [β [Hβ Hx]]. subst.
      apply 不动点枚举为序数运算. eauto. }
    f_equal. 外延 x Hx.
    + apply 替代除去 in Hx as [β [Hβ Hx]]. subst.
      apply 替代除去 in Hβ as [γ [Hγ Hβ]]. subst.
      apply 替代介入. exists γ...
    + apply 替代除去 in Hx as [β [Hβ Hx]]. subst.
      apply 替代介入. exists (不动点枚举 β). split... symmetry...
Qed.

Theorem 不动点不为零 : ∀α ⋵ 𝐎𝐍, F ∅ ≠ ∅ → G α ≠ ∅.
Proof.
  intros α Hα HF0. pose proof (不动点枚举枚举之 α Hα).
  intros H0. rewrite H0 in H. auto.
Qed.

Lemma 最小不动点为极限 : G ∅ ⋵ 𝐋𝐈𝐌.
Proof with auto.
  rewrite 不动点枚举_0.
  destruct (序数要么为后继要么为极限 α₀ 最小不动点为序数)...
  exfalso. destruct H as [α [Hα H]]. apply F非平凡 with α...
  rewrite <- H. apply 最小不动点为之...
Qed.

Lemma 后继不动点为极限 : ∀α ⋵ 𝐎𝐍, G α⁺ ⋵ 𝐋𝐈𝐌.
Proof with auto.
  intros. destruct (序数要么为后继要么为极限 (不动点枚举 α⁺))... apply 不动点枚举为序数运算...
  exfalso. destruct H0 as [β [Hβ Heq]].
  apply F非平凡 with β... rewrite <- Heq. apply 不动点枚举枚举之...
Qed.

Theorem 不动点为极限 : ∀α ⋵ 𝐎𝐍, G α ⋵ 𝐋𝐈𝐌.
Proof with auto.
  intros α Hα. 超限讨论 α. apply 最小不动点为极限. apply 后继不动点为极限...
  apply 序数嵌入在极限处的值为极限... apply 不动点枚举为序数嵌入.
Qed.

Local Notation E := 不动点枚举.
Local Notation A := 任意不动点.

End 不动点枚举.

Definition 对上确界封闭 := λ C, ∀ A, A ≠ ∅ → A ⪽ C → sup A ⋵ C.
Definition 有界 := λ C, ∃α ⋵ 𝐎𝐍, ∀β ⋵ C, β ⋸ α.
Definition 无界 := λ C, ∀α ⋵ 𝐎𝐍, ∃β ⋵ C, α ∈ β.

Theorem 𝐎𝐍无界子类为真类 : ∀ C, C ⫃ 𝐎𝐍 → 无界 C → 为真类 C.
Proof.
  intros C 子类 无界 [A 为集合]. apply 𝐎𝐍为真类.
  exists (sup A). intros α Hα. apply 无界 in Hα as [β [Hβ Hα]].
  apply 并集介入 with β; auto.
Qed.

Section 无界子类枚举.
Variable C : 类.
Variable C为子类 : C ⫃ 𝐎𝐍.
Variable C无界 : 无界 C.

Local Definition G关系 := λ f y, y ⋵ C ∧ y ∉ ran f ∧ ∀x ⋵ C, x ∉ ran f → y ⋸ x.

Local Lemma G关系有函数性 : ∀ f, ∃! y, G关系 f y.
Proof with auto.
  intros. rewrite <- unique_existence. split.
  - assert (∃α ⋵ C, α ∉ ran f). {
      反证. apply 𝐎𝐍无界子类为真类 with C... exists (ran f)...
      intros α Hα. 反证. firstorder.
    }
    destruct H as [α Hα]. assert (Hαo: α ⋵ 𝐎𝐍). destruct Hα...
    set (λ β, β ⋵ C ∧ β ∉ ran f) as P.
    pose proof (存在满足条件的最小序数 α Hαo P Hα) as [μ [Hμo [Hμ Hle]]].
    destruct Hμ as [Hμ Hμ']. exists μ.
    split... split... intros x Hx Hx'. 排中 (x ⋸ α).
    + apply Hle... split...
    + apply 序数可换 in H... apply 序数传递_弱 with α...
  - intros x y [HxC [Hx H1]] [HyC [Hy H2]].
    apply H1 in Hy... apply H2 in Hx...
    destruct Hx; destruct Hy... exfalso. apply 序数可换 with x y...
Qed.
Local Hint Immediate G关系有函数性 : core.

Local Definition G := λ f, 描述 (G关系 f).

Local Lemma G规范 : ∀ f, dom f ⋵ 𝐎𝐍 → G关系 f (G f).
Proof. intros. unfold G. apply 描述公理. apply G关系有函数性. Qed.

Definition 枚举 := 超限递归 G.

(* 枚举是𝐎𝐍到其子类的映射 *)
Lemma 枚举规范甲 : ∀α ⋵ 𝐎𝐍, 枚举 α ⋵ C.
Proof with auto.
  intros. unfold 枚举. rewrite 超限递归定理...
  apply G规范. rewrite 类函数限制之定义域...
Qed.

Corollary 枚举为序数运算 : 为序数运算 枚举.
Proof. intros. apply C为子类, 枚举规范甲; auto. Qed.

(* 枚举值与之前不同 *)
Lemma 枚举规范乙 : ∀α ⋵ 𝐎𝐍, ∀β ∈ α, 枚举 α ∉ {枚举 β | β ∊ α}.
Proof with auto.
  intros α Hα β Hβα. intros H. unfold 枚举 in H.
  rewrite 超限递归定理 in H... apply G规范 with (超限递归 G ↑ α).
  rewrite 类函数限制之定义域... rewrite 类函数限制之值域...
Qed.

(* 枚举值是与之前不同的最小序数 *)
Lemma 枚举规范丙 : ∀α ⋵ 𝐎𝐍, ∀ξ ⋵ C, ξ ∉ {枚举 β | β ∊ α} → 枚举 α ⋸ ξ.
Proof with auto.
  intros α Hα ξ Hξ H. unfold 枚举. rewrite 超限递归定理...
  apply G规范... rewrite 类函数限制之定义域... rewrite 类函数限制之值域...
Qed.

Theorem 枚举运算保序 : 保序 枚举.
Proof with auto.
  intros α Hα β Hβα. assert (Hβ: β ⋵ 𝐎𝐍). eauto.
  assert (枚举 α ∉ {枚举 γ | γ ∊ β}). {
    intros H. apply 替代除去 in H as [γ [Hγ H]].
    apply 枚举规范乙 with α β... apply 替代介入.
    exists γ. split... apply 序数传递 with β...
  }
  apply 枚举规范丙 in H as []... 2: apply 枚举规范甲...
  exfalso. apply 枚举规范乙 with α β... apply 替代介入. exists β...
Qed.

End 无界子类枚举.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_sel_rfn_sel_neq_reduce :
  forall T1 x1 L1 Ts1 T1', T1 = (t_rfn_sel x1 L1 Ts1 T1') ->
                      forall T2 x2 L2 Ts2 T2', T2 = (t_rfn_sel x2 L2 Ts2 T2') ->
                                          (x1 <> x2 \/ L1 <> L2) ->
                                          subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

  destruct H1 as [Heq|Heq].

  apply eq_var_neq in Heq;
    rewrite Heq in Heqsub_fn.

  rewrite andb_false_l, orb_false_l in Heqsub_fn.
  auto.

  apply eq_label_neq in Heq;
    rewrite Heq in Heqsub_fn.
  rewrite andb_false_r, andb_false_l, orb_false_l in Heqsub_fn.
  auto.
Qed.


(** Formalisation of "Noninterference, Transitivity, and Channel-Control Security Policies" by J. Rushby
    www.csl.sri.com/papers/csl-92-2/
*)

(** printing -> #→# *)
(** printing (policy a b) #a ⇝ b# *)

From stdpp Require Import list relations collections fin_collections.
Parameter FinSet : Type -> Type.
(** begin hide **)
Context `{forall A, ElemOf A (FinSet A)}.
Context `{forall A, Empty (FinSet A)}.
Context `{forall A, Singleton A (FinSet A)}.
Context `{forall A, Union (FinSet A)}.
Context `{forall A, Intersection (FinSet A)}.
Context `{forall A, Difference (FinSet A)}.
Context `{forall A, Elements A (FinSet A)}.
Context `{forall A, Collection A (FinSet A)}.
(* TODO: i wrote this line down so that there is a Collection -> SimpleCollection -> JoinSemiLattice instance for FinSet; how come this is not automatically picked up by the next assumption? *)
Context `{forall A (H : EqDecision A), FinCollection A (FinSet A)}.
(** end hide **)

(** * Mealy machines *)

(** A Mealy machine is a state machine with labels and outputs on arrows *)

Class Mealy (state action out : Type) := {
  initial : state;
  step : state -> action -> state;
  output : state -> action -> out
}.

(** ** Auxiliary functions

We define a [run] of a machine [M], which is an extension of
the [step] function to lists of actions. We use a shortcut
[do_actions] for running the machine from the [initial] state. *)

Fixpoint run `{Mealy state action out} (s : state) (ls : list action) : state :=
  match ls with
    | nil => s
    | a::tl => run (step s a) tl
  end.

Definition do_actions `{Mealy state action out} : list action -> state := run initial.

(** The [test] function runs the required list of actions and examines the output of the resulting state on a specified action. *)
Definition test `{Mealy state action out} (ls : list action) : action -> out := output (do_actions ls).

Section Rushby.

(** We assume for the rest of the formalisation that we have a Mealy
machine [M]. Thus, we parameterize our main development module by a machine [M].  *)

Context `{MM : Mealy state action out}.

(** * Security policies *)
Section Policy.

(** In order to define the notion of security, we assume a type [domain] of security domains. Those can be, e.g. clearance levels. For each action [a] we assign a domain [dom a] of that action. For instance, if we interpret domains as clearance levels, the domain of an action can signify the clearance level required to observe/preform the action.

A *security policy* is defined to be a reflexive decidable relation on the type of domains. For instance, the policy relation can state that the clearance level [u] is below the clearance level [v]. *)
Class Policy (domain : Type) := {
  dom : action -> domain;

  (** Sidenote: I had a lot of issues with Coq not finding relevant
  typeclass instances because the next field was declared as
  [domain_dec : TYPE] instead of [domain_dec :> TYPE]. So we actually
  do need implicit coercions to get automatic resolution of typeclass
  instances. *)

  domain_dec :> EqDecision domain;
  policy :> relation domain;
  policy_dec :> RelDecision policy;
  policy_refl :> Reflexive policy
}.

(** TODO: Make this notation span over different sections? *)
Delimit Scope policy_scope with P.
Open Scope policy_scope.
Infix "⇝" := policy (at level 70) : policy_scope.

(** Quoting Rushby:

<<
     We wish to define security in terms of information flow, so the
     next step is to capture the idea of the "flow of information"
     formally. The key observation is that information can be said to
     flow from a domain [u] to a domain [v] exactly when the acions
     submitted by domain [u] cause the behavior of the system
     percieved by domain [v] to be different from that perceived when
     those actions are not present.
>>

Hence, we define a function [purge] that removes from the given list
all the actions that are not supposed to "influence" the domain [v].
*)

Fixpoint purge `{Policy domain} (ls : list action) (v : domain) : list action :=
  match ls with
    | [] => []
    | a::tl => if (decide (dom a ⇝ v)) then a::(purge tl v)
               else purge tl v
  end.

(** Then, the system is _secure_ w.r.t. a given policy if for any set
of actions that can be performed, the system cannot tell the
difference between preforming the given actions and only performing
the actions that are supposed to influence the outcome *)

Definition security `{Policy domain} := forall (ls : list action) (a : action),
   test ls a = test (purge ls (dom a)) a.

End Policy.

(** * View partitions

As we have seen, the non-interference notion of security is defined by
quantifying over all the possible paths of the system. We wish to
develop techniques for establishing the security property by putting
conditions on individual state transformations.

As a first step, we define a notion of a "view partition", which is an
equivalence relation on the type of states of the system, siginfying
that two states are "identitcal" or indistinguishable for a given
domain.

*)

Section view_partitions.

(** Formally, a view partition is an assignment of an equivalence
relation [≈{u}] for every domain [u] *)

Class ViewPartition (domain : Type) := {
  view_partition :> domain -> relation state;
  view_partition_is_equiv :> forall v, Equivalence (view_partition v)
}.

Notation "S ≈{ U } T" := (view_partition U S T)
                           (at level 70, format "S  ≈{ U }  T") : policy_scope.
Open Scope policy_scope.
(** We say that a system is _output consistent_ if for every two
states [s, t] that are indistinguishable w.r.t. the domain [dom a],
the output of the system [output s a] is the same as [output t a] *)

Class OutputConsistent `{P : Policy domain} `(ViewPartition domain) :=
  output_consistent : (forall a s t, s ≈{dom a} t -> output s a = output t a).

(** Our first lemma states that if we have a view partitioned system
that is output consistent and satisfies

[[(do_actions ls) ≈{u} (do_actions (purge ls u))]]

then the system is secure. *)

(* Lemma 1 *)
Lemma output_consist_security `{P : Policy domain} `{VP : ViewPartition domain} {OC : @OutputConsistent domain P VP} : (forall ls u,
  (do_actions ls) ≈{u} (do_actions (purge ls u)))
  -> security.
Proof.
  intros L ls a.  apply output_consistent.
  apply (L _ (dom a)).
Qed.

(** Note that the conditions of Lemma [output_consist_security] still
require us to quantify over all possible paths of the system. We wish
to replace this condition with the following two "local" conditions.

The first condition, stating that the view partitioned system _locally
respects policy_: if the domain [dom a] is not suppose to interfere
with the domain [u], then, from the point of view of [u], the states
[s] and [step s a] are indistinguishable.
*)

Definition locally_respects_policy `{Policy domain} `{ViewPartition domain} := forall a u s,
  ¬(policy (dom a) u) -> s ≈{u} (step s a).

(** We say that the system is *step consistent*, if the view partition
is closed under the [step] function. *)

Definition step_consistent `{Policy domain} `{ViewPartition domain} := forall a s t u,
  s ≈{u} t -> (step s a) ≈{u} (step t a).

(** Given those two conditions we can prove that the system is secure,
by applying the previous lemma *)

(* Theorem 1 *)
Theorem unwinding `{P: Policy domain} `{VP: ViewPartition domain} `{@OutputConsistent  domain P VP} : locally_respects_policy -> step_consistent -> security.
Proof.
  intros LRP SC. apply output_consist_security.
  assert (forall ls u s t, view_partition u s t -> view_partition u (run s ls) (run t (purge ls u))) as General. (* TODO: a simple generalize would not suffice, because we actually need the s ≈ t assumption *)
    induction ls; simpl; auto.
    intros u s t HI.
    destruct (decide (policy (dom a) u)).
    (* DOESNT WORK (Lexer) : destruct (decide ((dom a) ⇝ u)). *)
    (** Case [(dom a) ~> u] *)
      apply IHls. apply SC; assumption.
    (** Case [(dom a) ~/> u] *)
      apply IHls.
      transitivity s. symmetry. unfold locally_respects_policy in LRP. apply LRP; assumption. assumption.
  unfold do_actions. intros ls u. apply General. reflexivity.
Qed.

End view_partitions.

(** * Access control interpretation of the view partition.  *)

Section ACI.

(** In this section we consider a formalisation of the access control mechansisms.

We say that the machine has _structured state_ if we have a collection
of [name]s and [value]s (the latter being decidable), and some sort of
the memory assigned to each state, which is formally given by the
[contents] function. For each domain [u] we assign sets [observe u]
and [alter u] of names that are allowed to be observed and altered,
respectively, by the domain [u]. *)

Class StructuredState (domain : Type)  := {
  name : Type;
  value : Type;
  contents : state -> name -> value;
  value_dec :> EqDecision value;
  observe : domain -> FinSet name;
  alter : domain -> FinSet name
}.

(** This induces the view partition relation as follows: two state [s]
and [t] are indistinguishable for the given domain, if all the
observable contents at [s] is the same as the observable content at
[t] *)

Definition RMA_partition `{@StructuredState domain} (u : domain) s t := (forall n,  (n ∈ observe u) -> contents s n = contents t n).

Transparent RMA_partition.

Instance RMA `{@StructuredState domain} : ViewPartition domain := { view_partition := RMA_partition }.
(* begin hide *)
  intro u. split; unfold RMA_partition.
  (* Reflexivity *) unfold Reflexive. auto.
  (* Symmetry *) unfold Symmetric. intros x y Sy.
  symmetry. apply Sy. assumption.
  (* Transitivity *) unfold Transitive. intros x y z T1 T2 n.
  transitivity (contents y n); [apply T1 | apply T2]; assumption.
Defined. (* We have to use 'Defined' here instead of 'Qed' so that we can unfold 'RMA' later on *)
(* end hide *)

Hint Resolve RMA.

(** ** Reference monitor assumptions *)
(* TODO: explain those assumptions *)
Class RefMonAssumptions `{Policy domain} `{StructuredState domain} :=
  { rma1 : forall (a : action) s t,
             view_partition (dom a) s t -> output s a = output t a
  ; rma2 : forall a s t n,
             view_partition (dom a) s t ->
             ((contents (step s a) n) ≠ (contents s n)
                ∨ (contents (step t a) n) ≠ (contents t n))
             -> contents (step s a) n = contents (step t a) n
  ; rma3 :  forall a s n,
               contents (step s a) n ≠ contents s n -> n ∈ alter (dom a)
}.

(** If the reference monitor assumptions are satisfied, then the system is output-consistent *)
Global Instance OC `{RefMonAssumptions}: OutputConsistent RMA.
exact rma1. Defined.

(** The reference mointor assumptions provide the security for the system, if, furthermore, two additional requirements are satisfied:

- [u ~> v] implies [observe u ⊆ observe v]; that is, if [u] is supposed to interfere with [v], then [v] can observe at least as much as [u]
- if [n ∈ alter u] and [n ∈ observe v], then [u ~> v]; that is, if [u] is allowed to alter a location that is observable by [v], then [u] is allowed to interfere with [v]
*)

(* Theorem 2 *)
Theorem RMA_secutity `{RefMonAssumptions} :
  (forall u v, (policy u v) → observe u ⊆ observe v)
  -> (forall u v n, (n ∈ alter u) → (n ∈ observe v) → (policy u v))
  -> security.
Proof.
  intros Cond1 Cond2. apply unwinding.
  (** We apply the unwinding theorem, so we have to verify that
     we locally respect policy and that we have step-consistency *)
  unfold locally_respects_policy.
  intros a u s.

  (** In order to prove that the system locally respects the policy
  relation, we first state the contrapositive, which we can prove
  because the policy relation and type of values are decidable *)

  assert ((exists n, (n ∈ observe u ∧ (contents s n ≠ contents (step s a) n))) -> policy (dom a) u) as CP.
    intros opH. destruct opH as [n [??]].
    eapply Cond2. eapply rma3. eauto. assumption.
  intros NPolicy.
  unfold view_partition, RMA, RMA_partition.
  (* TODO: why can't decide automatically pick the instance value_dec? *)
  intros. destruct (decide (contents s n = contents (step s a) n)) as [e|Ne]. assumption. exfalso. apply NPolicy. apply CP.
  exists n; split; assumption.

  (** In order to prove step-consistency we wish to apply the second
  reference monitor assumption. For that we must distinguish three
  cases: (contents (step s a) n ≠ contents s n), (contents (step t a)
  n ≠ contents t n), or if both of the equalities hold *)
  intros a s t u A.
  unfold view_partition, RMA, RMA_partition in *.
  intros n nO.
  destruct (decide (contents (step s a) n = contents s n)) as [E1 | NE1].
  destruct (decide (contents (step t a) n = contents t n)) as [E2 | NE2].
  (* Both equalities hold *)
  rewrite E1, E2. apply A; assumption.
  (* NE2 *)
  (* We use the Second RM assmption to deal with this case *)
  apply rma2. (* for this we have to show that s ~_(dom a) t *)
  unfold view_partition, RMA, RMA_partition.
  intros m L. apply A.
  apply Cond1 with (u:=dom a).
  apply Cond2 with (n:=n); [eapply rma3 | ]; eassumption.
  assumption.
  right. auto.
  (* NE1 case is similar *)
  (* TODO: repetition *)
  apply rma2. (* for this we have to show that s ~_(dom a) t *)
  unfold view_partition, RMA, RMA_partition.
  intros m L. apply A.
  apply Cond1 with (u:=dom a).
  apply Cond2 with (n:=n); [eapply rma3| ]; eassumption.
  assumption.
  left. auto.
Qed.

End ACI.

(** * Intransitive security policy *)
Section Intransitive.

(** Auxiliary  definitions *)
Fixpoint sources `{Policy domain} (ls : list action) (d : domain) : FinSet domain :=
  match ls with
    | [] => {[ d ]}
    | a::tl => let src := sources tl d in
               if (decide (exists (v: domain), ((v ∈ src) ∧ (policy (dom a) v))))
               then src ∪ {[ dom a ]} else src
  end.

(** The two properties of the [sources] function: it is monotone and [d \in sources ls d] *)
Lemma sources_mon `{Policy} : forall a ls d, sources ls d ⊆ sources (a::ls) d.
Proof.
  intros. simpl.
  destruct (decide _); [apply union_subseteq_l |]; auto.
Qed.

Hint Resolve sources_mon.

Lemma sources_monotone `{Policy} : forall ls js d, sublist ls js → sources ls d ⊆ sources js d.
Proof.
  intros ls js d M.
  induction M. simpl. reflexivity.
  simpl. destruct (decide (∃ v : domain, v ∈ sources l1 d ∧ policy (dom x) v)); destruct (decide (∃ v : domain, v ∈ sources l2 d ∧ policy (dom x) v)).
  - apply union_mono_r. assumption.
  - exfalso. apply n. destruct e as [v [e1 e2]]. exists v; split; try (apply (IHM v)); assumption.
  - transitivity (sources l2 d). assumption. apply union_subseteq_l.
  - assumption.
  - transitivity (sources l2 d); auto.
Qed.

Lemma sources_in `{Policy} : forall ls d, d ∈ sources ls d.
Proof.
  intros. induction ls; simpl.  apply elem_of_singleton_2; auto.
  destruct (decide (∃ v : domain, v ∈ sources ls d ∧ policy (dom a) v)); simpl.
  apply elem_of_union_l. assumption. assumption.
Qed.

Hint Resolve sources_in.

(* TODO: why is this not picked up automatically? *)
Instance sources_elem_of_dec `{Policy} (v : domain) ls d : Decision (v ∈ sources ls d).
Proof. apply elem_of_dec_slow. Qed.

Fixpoint ipurge `{Policy} (ls : list action) (d : domain) {struct ls} : list action :=
  match ls with
    | [] => []
    | a::tl => if (decide ((dom a) ∈ sources ls d))
               then a::(ipurge tl d)
               else ipurge tl d
  end.

(** The non-interference notion of security for intransitive policies
is very similar to the transitive case, bu uses the [ipurge] function
instead of [purge] *)

Definition isecurity `{Policy} := forall ls a,
  test ls a = test (ipurge ls (dom a)) a.

(** We can prove lemmas similar to the transitive case *)

Lemma output_consist_isecurity `{P : Policy domain} `{VP : ViewPartition domain} {OC : @OutputConsistent domain P VP} : (forall ls u,
  view_partition u (do_actions ls) (do_actions (ipurge ls u)))
  -> isecurity.
Proof.
  unfold isecurity. intros H ls a.
  unfold test.
  apply output_consistent.
  apply (H ls (dom a)).
Qed.

Definition view_partition_general `{ViewPartition domain} (C : FinSet domain) s t := forall (u: domain), u ∈ C -> view_partition u s t.

Global Instance view_partition_general_equiv `{ViewPartition domain}:
  forall V, Equivalence (view_partition_general V).
Proof.
  intro V. split.
  intros x v A. reflexivity.
  intros x y A1 v A2. symmetry. apply (A1 v); assumption.
  intros x y z A1 A2 v A3. transitivity y. apply (A1 v); assumption. apply  (A2 v); assumption.
Qed.

Definition weakly_step_consistent `{Policy domain} `{ViewPartition domain} :=
  forall s t u a, view_partition u s t -> view_partition (dom a) s t -> view_partition u (step s a) (step t a).

Ltac exists_inside v :=
  let H := fresh "Holds" in
  let nH := fresh "notHolds" in
  destruct (decide _) as [H | []];
  [ try reflexivity | exists v; try auto].

Local Hint Resolve sources_mon.
Local Hint Extern 1 (_ ∈ sources (_::_) _) => eapply sources_mon.
Local Hint Immediate elem_of_singleton.
(* Local Hint Extern 1 (_ ∈ {[ _ ]}) => apply elem_of_singleton; trivial. *)
Local Hint Resolve elem_of_union.

(* Lemma 3 *)
Lemma weakly_step_consistent_general `{Policy domain} `{ViewPartition domain} (s t : state) (a : action) ls (u: domain) : weakly_step_consistent -> locally_respects_policy ->
  view_partition_general (sources (a::ls) u) s t
  -> view_partition_general (sources ls u) (step s a) (step t a).
Proof.
  intros WSC LRP P v vIn.
  unfold view_partition_general in P.
  unfold locally_respects_policy in LRP.
  destruct (decide (policy (dom a) v)).
  (* Case [dom a ~> v] *)
  apply WSC; apply P. auto.
  (* we need to show that [dom a ∈ sources (a::ls) v] *)
  simpl. exists_inside v. apply elem_of_union. right. auto.  apply elem_of_singleton; trivial.
  (* Case [dom a ~/> v] *)
  transitivity s. symmetry. apply LRP; assumption.
  transitivity t. apply P. auto.
  apply LRP; assumption.
Qed.

(* Lemma 4 *)
Lemma locally_respects_gen `{Policy domain} `{ViewPartition domain} (WSC: weakly_step_consistent) (LRP : locally_respects_policy) s a ls u :
  ¬ ((dom a) ∈ sources (a::ls) u) ->
  view_partition_general (sources ls u) s (step s a).
Proof.
  intros domN v vIn.
  apply LRP. intro.
  (* If [dom a ~> v], then [dom a ∈ sources (a::ls) u], because [v ∈ sources ls u] *) (* again, a clusterfuck *)
  apply domN. simpl.
  exists_inside v; auto. apply elem_of_union; right; apply elem_of_singleton; reflexivity.
Qed.

(* Lemma 5 *)
Lemma unwinding_gen `{Policy domain} `{ViewPartition domain} (WSC: weakly_step_consistent) (LRP : locally_respects_policy) s t ls u :
  view_partition_general (sources ls u) s t
  -> view_partition u (run s ls) (run t (ipurge ls u)).
Proof.
  generalize dependent s.
  generalize dependent t.
  induction ls; intros s t.
  simpl. intro A. apply (A u). apply elem_of_singleton; reflexivity.
  intro VPG. simpl. unfold sources. fold (sources (a::ls) u).

  destruct (decide _).
  (** Case [dom a ∈ sources (a::ls) u] *)
  simpl. apply IHls. apply weakly_step_consistent_general; auto.
  (** Case [dom a ∉ sources (a::ls) u] *)
  apply IHls. symmetry. transitivity t.
  - intros v vIn. symmetry. apply VPG. apply sources_mon; exact vIn.
  - apply locally_respects_gen; try(assumption).
Qed.

Theorem unwinding_intrans `{P : Policy domain} `{VP : ViewPartition domain}
 `{OC : @OutputConsistent domain P VP} (WSC : weakly_step_consistent) (LRP : locally_respects_policy) : isecurity.
Proof.
  apply output_consist_isecurity.
  intros.
  apply unwinding_gen; try assumption.
  reflexivity.
Qed.

Theorem rma_secure_intransitive `{RefMonAssumptions} : (forall u v n, n ∈ alter u -> n ∈ observe v -> policy u v) -> isecurity.
Proof. intro policyA.
  apply @unwinding_intrans with (VP:=RMA). exact rma1.
  intros s t u a A1 A2.
  unfold view_partition. unfold RMA_partition; simpl. intros n L.
  destruct (decide (contents (step s a) n = contents s n)) as [E1 | NE1].
  destruct (decide (contents (step t a) n = contents t n)) as [E2 | NE2].
  (* Case [contents (step s a) n = contents s n /\ contents (step t a) n = contents t n] *)
  rewrite E1, E2. apply A1; assumption.
  (* Case [contents (step t a) n ≠ contents t n] *)
  apply rma2; [ | right]; assumption.
  (* Case [contents (step s a) n ≠ contents s n] *)
  apply rma2; [ | left]; assumption.

  intros a u s A.
  assert ((exists n, (n ∈ observe u ∧ (contents s n ≠ contents (step s a) n))) -> policy (dom a) u) as CP.
    intros opH. destruct opH as [n [??]].
    eapply policyA. eapply rma3. eauto. assumption.
  intros n L. destruct (decide (contents s n = contents (step s a) n)). assumption. exfalso. apply A.
  apply CP. exists n. auto.
Qed.

End Intransitive.

End Rushby.


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

Require Export alignement.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter barycentre : PP -> PP -> PO.

Axiom
  add_PP_barycentre :
    forall (a b : R) (A B : PO),
    a + b <> 0 ->
    add_PP (cons a A) (cons b B) =
    cons (a + b) (barycentre (cons a A) (cons b B)).

Lemma permute_barycentre :
 forall (a b : R) (A B : PO),
 a + b <> 0 ->
 barycentre (cons a A) (cons b B) = barycentre (cons b B) (cons a A).
intros a b A B H; try assumption.
apply conversion_PP with (a := a + b) (b := b + a); try ring; auto.
repeat rewrite <- add_PP_barycentre; auto.
RingPP.
unfold not in |- *; intros H1; apply H; auto; rewrite <- H1; ring; auto.
Qed.

Lemma barycentre_zero :
 forall (a : R) (A B : PO), a <> 0 -> barycentre (cons a A) (cons 0 B) = A.
intros a A B H; try assumption.
apply conversion_PP with (a := a + 0) (b := a); try ring; auto.
repeat rewrite <- add_PP_barycentre; auto.
RingPP.
unfold not in |- *; intros H1; apply H; auto; rewrite <- H1; ring; auto.
replace (a + 0) with a; try ring; auto.
Qed.

Lemma bary_assoc :
 forall (a b c : R) (A B C : PO),
 a + b <> 0 ->
 b + c <> 0 ->
 a + (b + c) <> 0 ->
 barycentre (cons a A) (cons (b + c) (barycentre (cons b B) (cons c C))) =
 barycentre (cons (a + b) (barycentre (cons a A) (cons b B))) (cons c C).
intros a b c A B C H H0 H1; try assumption.
apply conversion_PP with (a := a + (b + c)) (b := a + b + c); try ring; auto.
repeat rewrite <- add_PP_barycentre; auto.
Ringvec.
unfold not in |- *; intros H2; apply H1; auto; rewrite <- H2; ring; auto.
Qed.

Lemma homogene_barycentre :
 forall (a b k : R) (A B : PO),
 a + b <> 0 ->
 k <> 0 ->
 barycentre (cons (k * a) A) (cons (k * b) B) =
 barycentre (cons a A) (cons b B).
intros a b k A B H H0; try assumption.
apply conversion_PP with (a := k * a + k * b) (b := k * (a + b)); try ring;
 auto.
repeat rewrite <- add_PP_barycentre; auto.
rewrite distrib_mult_cons.
rewrite <- def_mult_PP.
repeat rewrite <- add_PP_barycentre; auto.
replace (k * a + k * b) with (k * (a + b)); try ring.
auto with *.
replace (k * a + k * b) with (k * (a + b)); try ring.
auto with *.
Qed.

Lemma def_vecteur_bary :
 forall (a b : R) (A B G : PO),
 a + b <> 0 ->
 G = barycentre (cons a A) (cons b B) ->
 add_PP (mult_PP a (vec G A)) (mult_PP b (vec G B)) = zero.
intros.
cut (zero = mult_PP (a + b) (vec G G)); intros; auto.
rewrite H1.
apply add_PP_vecteur; auto.
rewrite (add_PP_barycentre (a:=a) (b:=b) A B); auto.
rewrite <- H0; auto.
Ringvec.
Qed.

Lemma def_vecteur_bary_rec :
 forall (a b : R) (A B G : PO),
 a + b <> 0 ->
 add_PP (mult_PP a (vec G A)) (mult_PP b (vec G B)) = zero ->
 G = barycentre (cons a A) (cons b B).
unfold vec in |- *; intros.
apply conversion_PP with (a := a + b) (b := a + b); auto.
rewrite <- (add_PP_barycentre (a:=a) (b:=b) A B); auto.
replace (cons (a + b) G) with (add_PP (cons (a + b) G) zero).
rewrite <- H0.
RingPP.
RingPP.
Qed.

Lemma prop_vecteur_bary :
 forall (a b : R) (A B G M : PO),
 a + b <> 0 ->
 G = barycentre (cons a A) (cons b B) ->
 add_PP (mult_PP a (vec M A)) (mult_PP b (vec M B)) =
 mult_PP (a + b) (vec M G).
intros.
apply add_PP_vecteur; auto.
rewrite (add_PP_barycentre (a:=a) (b:=b) A B); auto.
rewrite <- H0; auto.
Qed.

Lemma prop_vecteur_bary_rec :
 forall (a b : R) (A B G M : PO),
 a + b <> 0 ->
 add_PP (mult_PP a (vec M A)) (mult_PP b (vec M B)) =
 mult_PP (a + b) (vec M G) -> G = barycentre (cons a A) (cons b B).
unfold vec in |- *; intros.
apply conversion_PP with (a := a + b) (b := a + b); auto.
rewrite <- (add_PP_barycentre (a:=a) (b:=b) A B); auto.
cut
 (add_PP (cons (- (a + b)) M) (cons (a + b) G) =
  add_PP (mult_PP a (add_PP (cons (-1) M) (cons 1 A)))
    (mult_PP b (add_PP (cons (-1) M) (cons 1 B))));
 intros.
RingPP2 H1.
RingPP.
rewrite H0.
RingPP.
Qed.
#[export] Hint Resolve add_PP_barycentre: geo.

Lemma barycentre_alignes :
 forall (a b : R) (A B : PO),
 a + b <> 0 -> alignes A B (barycentre (cons a A) (cons b B)).
intros a b A B H; try assumption.
apply add_PP_alignes with (a := a) (b := b); auto with geo.
Qed.

Lemma colineaire_barycentre :
 forall (k : R) (A B C : PO),
 vec A C = mult_PP k (vec A B) ->
 C = barycentre (cons (1 + - k) A) (cons k B).
unfold vec in |- *; intros.
elim
 cons_inj
  with
    (a := 1)
    (b := 1 + - k + k)
    (A := C)
    (B := barycentre (cons (1 + - k) A) (cons k B));
 intros; auto with *.
repeat rewrite <- add_PP_barycentre; auto.
RingPP2 H.
RingPP.
replace (1 + - k + k) with 1; try ring; auto with *.
Qed.

Lemma alignes_barycentre :
 forall A B C : PO,
 A <> B ->
 alignes A B C -> exists k : R, C = barycentre (cons k A) (cons (1 + - k) B).
unfold alignes, alignes1 in |- *; intros.
elim H0;
 [ intros H1; tauto
 | intros H1; elim H1; [ intros k H2; try clear H1 H0; try exact H2 ] ].
exists k; auto.
apply conversion_PP with (a := 1) (b := k + (1 + - k)); try ring; auto with *.
rewrite H2; auto.
repeat rewrite <- add_PP_barycentre; auto.
replace (k + (1 + - k)) with 1; try ring; auto with *.
Qed.
#[export] Hint Resolve barycentre_alignes prop_vecteur_bary def_vecteur_bary_rec
  def_vecteur_bary homogene_barycentre barycentre_zero: geo.

Lemma existence_representant_vecteur :
 forall A B C : PO, ex (fun D : PO => vec A D = vec B C :>PP).
unfold vec in |- *; intros.
exists (barycentre (cons (-1) B) (cons 2 (barycentre (cons 1 A) (cons 1 C)))).
replace 2 with (1 + 1) by ring.
pattern 1 at 1 in |- *.
RReplace 1 (-1 + 2).
rewrite <-!add_PP_barycentre; try lra.
RingPP.
Qed.

Lemma existence_representant_mult_vecteur :
 forall (A B C : PO) (k : R),
 ex (fun D : PO => vec A D = mult_PP k (vec B C) :>PP).
intros.
elim (classic (k = -1)); intros.
rewrite H.
elim existence_representant_vecteur with (A := A) (B := C) (C := B);
 intros D H0; try clear existence_representant_vecteur;
 try exact H0.
exists D.
rewrite H0; Ringvec.
unfold vec in |- *.
exists
 (barycentre (cons (- k) B) (cons (1 + k) (barycentre (cons 1 A) (cons k C)))).
pattern 1 at 1 in |- *.
RReplace 1 (- k + (1 + k)).
repeat rewrite <- add_PP_barycentre; try lra.
RingPP.
Qed.

Lemma existence_representant_som_vecteur :
 forall A B C D : PO,
 ex (fun E : PO => vec A E = add_PP (vec A B) (vec C D) :>PP).
intros.
unfold vec in |- *.
exists (barycentre (cons (-1) C) (cons 2 (barycentre (cons 1 B) (cons 1 D)))).
pattern 1 at 1 in |- *.
RReplace 1 (-1 + 2).
rewrite <- add_PP_barycentre; try lra.
RReplace 2 (1 + 1).
rewrite <- add_PP_barycentre; try lra.
RingPP.
Qed.

Lemma existence_representant_comb_lin_vecteur :
 forall (A B C D : PO) (a b : R),
 ex
   (fun E : PO =>
    vec A E = add_PP (mult_PP a (vec A B)) (mult_PP b (vec C D)) :>PP).
intros.
elim
 existence_representant_mult_vecteur with (A := A) (B := A) (C := B) (k := a);
 intros B' H; try clear existence_representant_mult_vecteur;
 rewrite <- H.
elim
 existence_representant_mult_vecteur with (A := C) (B := C) (C := D) (k := b);
 intros C' H0; try clear existence_representant_mult_vecteur;
 rewrite <- H0.
elim
 existence_representant_som_vecteur
  with (A := A) (B := B') (C := C) (D := C'); intros E H1;
 try clear existence_representant_som_vecteur; rewrite <- H1.
exists E; auto.
Qed.

Lemma distinct_mult_vecteur :
 forall (A B C D : PO) (a : R),
 A <> B :>PO ->
 a <> 0 :>R -> vec C D = mult_PP a (vec A B) :>PP -> C <> D :>PO.
intros.
elim
 existence_representant_mult_vecteur with (A := A) (B := A) (C := B) (k := a);
 intros E H2; try clear existence_representant_mult_vecteur;
 try exact H2.
cut (A <> E); intros.
apply distinct_egalite_vecteur with (1 := H3); auto.
rewrite H1; auto.
apply distinct_produit_vecteur with (3 := H2); auto.
Qed.

Lemma unicite_coor_bar :
 forall (k k' : R) (A B I : PO),
 A <> B ->
 cons 1 I = add_PP (cons k A) (cons (1 + - k) B) ->
 cons 1 I = add_PP (cons k' A) (cons (1 + - k') B) -> k = k'.
intros.
elim produit_vecteur_nul with (a := k + - k') (A := A) (B := B);
 [ intros H2; try clear produit_vecteur_nul; try exact H2
 | intros H2; try clear produit_vecteur_nul
 | try clear produit_vecteur_nul ].
RReplace k (k + - k' + k').
rewrite H2.
ring.
absurd (A = B); auto.
VReplace (mult_PP (k + - k') (vec A B))
 (add_PP (add_PP (cons k' A) (cons (1 + - k') B))
    (add_PP (cons (- k) A) (cons (-1 + k) B))).
rewrite <- H1.
rewrite H0.
RingPP.
Qed.

Lemma unicite_coef_bar :
 forall (x x0 : R) (A B : PO),
 A <> B ->
 1 + x <> 0 ->
 1 + x0 <> 0 ->
 barycentre (cons 1 A) (cons x B) = barycentre (cons 1 A) (cons x0 B) ->
 x = x0.
intros.
cut
 (barycentre (cons (/ (1 + x) * 1) A) (cons (/ (1 + x) * x) B) =
  barycentre (cons (/ (1 + x0) * 1) A) (cons (/ (1 + x0) * x0) B));
 intros.
cut (1 + x = 1 + x0); intros.
RReplace x (-1 + (1 + x)).
rewrite H4.
ring.
cut (/ (1 + x) = / (1 + x0)); intros.
replace (1 + x) with (/ / (1 + x)).
rewrite H4.
auto with *.
auto with *.
replace (/ (1 + x)) with (/ (1 + x) * 1).
replace (/ (1 + x0)) with (/ (1 + x0) * 1).
apply
 (unicite_coor_bar (k:=/ (1 + x) * 1) (k':=/ (1 + x0) * 1) (A:=A) (B:=B)
    (I:=barycentre (cons (/ (1 + x) * 1) A) (cons (/ (1 + x) * x) B)));
 auto.
pattern 1 at 1 in |- *.
replace 1 with (/ (1 + x) * 1 + / (1 + x) * x).
rewrite <- add_PP_barycentre; auto.
replace (1 + - (/ (1 + x) * 1)) with (/ (1 + x) * x); auto.
auto with *.
pattern 1 at 2 in |- *.
replace 1 with (/ (1 + x) * (1 + x)); auto.
ring.
auto with *.
replace (/ (1 + x) * 1 + / (1 + x) * x) with 1; auto.
auto with *.
pattern 1 at 1 in |- *.
replace 1 with (/ (1 + x) * (1 + x)); auto.
ring.
auto with *.
replace (/ (1 + x) * 1 + / (1 + x) * x) with (/ (1 + x) * (1 + x)); auto.
auto with *.
auto with *.
rewrite H3.
pattern 1 at 1 in |- *.
replace 1 with (/ (1 + x0) * 1 + / (1 + x0) * x0).
rewrite <- add_PP_barycentre; auto.
replace (1 + - (/ (1 + x0) * 1)) with (/ (1 + x0) * x0); auto.
pattern 1 at 2 in |- *.
replace 1 with (/ (1 + x0) * (1 + x0)); auto.
ring.
auto with *.
replace (/ (1 + x0) * 1 + / (1 + x0) * x0) with 1; auto.
auto with *.
pattern 1 at 1 in |- *.
replace 1 with (/ (1 + x0) * (1 + x0)); auto.
ring.
auto with *.
replace (/ (1 + x0) * 1 + / (1 + x0) * x0) with (/ (1 + x0) * (1 + x0)); auto.
auto with *.
auto with *.
auto with *.
ring.
rewrite homogene_barycentre.
rewrite homogene_barycentre; auto.
auto with *.
try exact H0.
auto with *.
Qed.

Lemma unicite_coor_bar_aux :
 forall (A B C I : PO) (x y x' y' : R),
 x <> x' :>R \/ y <> y' :>R ->
 cons 1 I = add_PP (add_PP (cons x A) (cons y B)) (cons (1 + - (x + y)) C)
 :>PP ->
 cons 1 I =
 add_PP (add_PP (cons x' A) (cons y' B)) (cons (1 + - (x' + y')) C) :>PP ->
 alignes A B C.
intros.
assert (vec C I = add_PP (mult_PP x (vec C A)) (mult_PP y (vec C B))).
unfold vec in |- *.
rewrite H0; Ringvec.
assert (vec C I = add_PP (mult_PP x' (vec C A)) (mult_PP y' (vec C B))).
unfold vec in |- *.
rewrite H1; Ringvec.
assert
 (add_PP (mult_PP (x + - x') (vec C A)) (mult_PP (y + - y') (vec C B)) = zero).
VReplace zero (add_PP (vec C I) (mult_PP (-1) (vec C I))).
pattern (vec C I) at 1 in |- *; rewrite H2; rewrite H3; Ringvec.
assert (mult_PP (x + - x') (vec C A) = mult_PP (y' + - y) (vec C B)).
VReplace (mult_PP (y' + - y) (vec C B))
 (add_PP (mult_PP (y' + - y) (vec C B)) zero).
rewrite <- H4; Ringvec.
elim H; [ intros H6; try clear H; try exact H6 | intros H6; try clear H ].
assert (x + - x' <> 0).
contrapose H6.
RReplace x' (x' + 0).
rewrite <- H; ring.
assert (alignes C B A); auto with geo.
apply colineaire_alignes with (/ (x + - x') * (y' + - y)).
VReplace (mult_PP (/ (x + - x') * (y' + - y)) (vec C B))
 (mult_PP (/ (x + - x')) (mult_PP (y' + - y) (vec C B))).
rewrite <- H5; Fieldvec (x + - x').
assert (y' + - y <> 0).
contrapose H6.
RReplace y (y + 0).
rewrite <- H; ring.
assert (alignes C A B); auto with geo.
apply colineaire_alignes with (/ (y' + - y) * (x + - x')).
VReplace (mult_PP (/ (y' + - y) * (x + - x')) (vec C A))
 (mult_PP (/ (y' + - y)) (mult_PP (x + - x') (vec C A))).
rewrite H5; Fieldvec (y' + - y).
Qed.

Lemma unicite_coor_bar2 :
 forall (A B C I : PO) (x y x' y' : R),
 ~ alignes A B C ->
 cons 1 I = add_PP (add_PP (cons x A) (cons y B)) (cons (1 + - (x + y)) C)
 :>PP ->
 cons 1 I =
 add_PP (add_PP (cons x' A) (cons y' B)) (cons (1 + - (x' + y')) C) :>PP ->
 x = x' :>R /\ y = y' :>R.
intros.
assert (~ x <> x' /\ ~ y <> y').
apply not_or_and; auto.
contrapose H.
apply
 (unicite_coor_bar_aux (A:=A) (B:=B) (C:=C) (I:=I) (x:=x) (y:=y) (x':=x')
    (y':=y')); auto.
elim H2; [ intros H3 H4; try clear H2; try exact H3 ].
split; (apply NNPP; auto).
Qed.

Lemma parallelogramme_non_concours :
 forall A B A1 B1 S : PO,
 ~ alignes A A1 B ->
 alignes A A1 S ->
 alignes B B1 S ->
 add_PP (cons 1 A) (cons (-1) A1) <> add_PP (cons 1 B) (cons (-1) B1).
intros.
contrapose H.
assert (vec A1 A = vec B1 B).
unfold vec in |- *.
RingPP1 H2.
RingPP.
halignes H1 k.
assert (A1 = A); auto with geo.
apply vecteur_nul_conf.
rewrite H3; rewrite H1; Ringvec.
halignes H0 k0.
apply colineaire_alignes with (k0 + - k).
VReplace (vec A B) (add_PP (vec A S) (mult_PP (-1) (vec B S))).
rewrite H5; rewrite H4.
VReplace (vec B B1) (mult_PP (-1) (vec B1 B)).
rewrite <- H3.
Ringvec.
Qed.

Lemma concours_unique :
 forall A B A1 B1 I J : PO,
 ~ alignes A A1 B ->
 B1 <> B ->
 alignes A A1 I ->
 alignes B1 B I -> alignes A A1 J -> alignes B1 B J -> I = J.
intros A B A1 B1 I J H.
unfold alignes in |- *; intros H50 H0 H1 H2 H3.
elim H3; clear H3; [ intros; tauto | unfold alignes1 in |- *; intros ].
elim H1; clear H1; [ intros; tauto | unfold alignes1 in |- *; intros ].
deroule_triangle A A1 B.
elim H2; clear H2; [ intros; tauto | unfold alignes1 in |- *; intros ].
elim H0; clear H0 H5 H4;
 [ intros; tauto; clear H6 | unfold alignes1 in |- *; intros ].
elim H3; intros k0 H4; try clear H3; try exact H4.
elim H2; intros k1 H3; try clear H2; try exact H3.
elim H1; intros k2 H2; try clear H1; try exact H2.
elim H0; intros k3 H1; try clear H0; try exact H1.
elim (classic (k0 + - k2 = 0)); intros.
cut (k0 = k2); intros.
rewrite H5 in H4.
apply conversion_PP with (a := 1) (b := 1); auto.
rewrite H4; auto.
auto with *.
cut
 (cons (k0 + - k2) B =
  add_PP (cons (k0 * k3 + - (k2 * k1)) A)
    (cons (k0 + - k2 + - (k0 * k3 + - (k2 * k1))) A1));
 intros.
assert (~ alignes1 A A1 B); auto with geo.
absurd
 (ex (fun k0 : R => cons 1 B = add_PP (cons k0 A) (cons (1 + - k0) A1)));
 auto.
exists (/ (k0 + - k2) * (k0 * k3 + - (k2 * k1))).
apply mult_PP_regulier with (k0 + - k2); auto.
pattern 1 at 2 in |- *.
replace 1 with ((k0 + - k2) * / (k0 + - k2)); auto.
rewrite <- distrib_mult_cons.
rewrite def_mult_PP.
replace ((k0 + - k2) * (/ (k0 + - k2) * (k0 * k3 + - (k2 * k1)))) with
 (k0 * k3 + - (k2 * k1)); auto.
replace ((k0 + - k2) * 1) with (k0 + - k2); auto.
replace
 ((k0 + - k2) * / (k0 + - k2) + - (/ (k0 + - k2) * (k0 * k3 + - (k2 * k1))))
 with (/ (k0 + - k2) * (k0 + - k2 + - (k0 * k3 + - (k2 * k1))));
 auto.
replace
 ((k0 + - k2) * (/ (k0 + - k2) * (k0 + - k2 + - (k0 * k3 + - (k2 * k1)))))
 with (1 * (k0 + - k2 + - (k0 * k3 + - (k2 * k1))));
 auto.
rewrite H5.
RingPP.
replace 1 with ((k0 + - k2) * / (k0 + - k2)); auto.
ring.
auto with *.
ring.
ring.
replace ((k0 + - k2) * (/ (k0 + - k2) * (k0 * k3 + - (k2 * k1)))) with
 ((k0 + - k2) * / (k0 + - k2) * (k0 * k3 + - (k2 * k1))).
replace ((k0 + - k2) * / (k0 + - k2)) with 1.
ring.
auto with *.
ring.
auto with *.
cut
 (add_PP (cons (k0 * k2) B1) (cons (k0 * (1 + - k2)) B) =
  add_PP (cons (k0 * k3) A) (cons (k0 * (1 + - k3)) A1));
 intros.
cut
 (add_PP (cons (k2 * k0) B1) (cons (k2 * (1 + - k0)) B) =
  add_PP (cons (k2 * k1) A) (cons (k2 * (1 + - k1)) A1));
 intros.
replace (cons (k0 + - k2) B) with
 (add_PP (cons (k0 * (1 + - k2)) B) (cons (- (k2 * (1 + - k0))) B)).
replace (cons (k0 * k3 + - (k2 * k1)) A) with
 (add_PP (cons (k0 * k3) A) (cons (- (k2 * k1)) A)).
replace (cons (k0 + - k2 + - (k0 * k3 + - (k2 * k1))) A1) with
 (add_PP (cons (k0 * (1 + - k3)) A1) (cons (- (k2 * (1 + - k1))) A1)).
RingPP2 H5.
cut
 (add_PP (cons (- (k2 * k0)) B1) (cons (- (k2 * (1 + - k0))) B) =
  add_PP (cons (- (k2 * k1)) A) (cons (- (k2 * (1 + - k1))) A1));
 intros.
RingPP2 H8.
RingPP.
replace (add_PP (cons (- (k2 * k0)) B1) (cons (- (k2 * (1 + - k0))) B)) with
 (mult_PP (-1) (add_PP (cons (k2 * k0) B1) (cons (k2 * (1 + - k0)) B))).
rewrite H7.
RingPP.
RingPP.
RingPP.
RingPP.
RingPP.
rewrite distrib_mult_cons.
rewrite distrib_mult_cons.
rewrite <- H4.
rewrite H3; auto.
rewrite distrib_mult_cons.
rewrite distrib_mult_cons.
rewrite <- H2.
rewrite H1; auto.
Qed.

Lemma couple_colineaires_parallelogramme :
 forall (A B C D : PO) (k k' : R),
 A <> B ->
 ~ alignes A B C ->
 vec C D = mult_PP k (vec A B) ->
 vec B D = mult_PP k' (vec A C) -> vec B D = vec A C.
unfold vec in |- *; intros.
cut
 (cons 1 D =
  add_PP (add_PP (cons (- k') A) (cons 1 B)) (cons (1 + - (- k' + 1)) C));
 intros.
cut
 (cons 1 D =
  add_PP (add_PP (cons (- k) A) (cons k B)) (cons (1 + - (- k + k)) C));
 intros.
cut (k = k' /\ k = 1); intros.
elim H5; intros H6 H7; try clear H5; try exact H7.
rewrite <- H6 in H2; rewrite H7 in H2.
rewrite H2; Ringvec.
cut (- k = - k' /\ k = 1); intros.
elim H5; intros H6 H7; try clear H5; try exact H7.
split; [ idtac | try assumption ].
replace k with (- - k).
rewrite H6; ring.
ring.
apply (unicite_coor_bar2 (A:=A) (B:=B) (C:=C) (I:=D)); auto.
RingPP2 H1.
RingPP.
RingPP2 H2.
RingPP.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.

Local Open Scope logic_base.
Local Open Scope syntax.

Section RewriteClass.

Context {L: Language}
        {minL: MinimumLanguage L}
        {GammaP: Provable L}.

Instance provable_impp_rewrite: RewriteRelation (fun x y => |-- x --> y).
Qed.

Section Provable.

Context {minAX: MinimumAxiomatization L GammaP}.

Instance provable_impp_refl_instance: Reflexive (fun x y => |-- x --> y).
Proof.
  intros.
  hnf; intros.
  apply provable_impp_refl.
Qed.

Instance provable_proper_impp:
  Proper ((fun x y => |-- impp x y) ==> Basics.impl) provable.
Proof.
  intros.
  hnf; intros.
  intro.
  eapply modus_ponens; eauto.
Qed.

Instance impp_proper_impp:
  Proper ((fun x y => |-- impp x y) --> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) impp.
Proof.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  unfold Basics.flip in H.
  eapply modus_ponens; [apply provable_impp_arg_switch |].
  eapply aux_minimun_rule02; [apply H |].
  eapply modus_ponens; [apply provable_impp_arg_switch |].
  apply aux_minimun_rule01, H0.
Qed.

Section Derivable1_provable.

Context {GammaD: Derivable1 L}
        {GammaD1P: Derivable1Provable L GammaP GammaD}.

Instance provable_proper_derivable1:
  Proper (derivable1 ==> Basics.impl) provable.
Proof.
  hnf;intros.
  intro.
  pose proof derivable1_provable x y.
  rewrite H1 in H.
  pose proof modus_ponens _ _ H H0.
  tauto.
Qed.

End Derivable1_provable.

End Provable.

Section Derivable.

Context {GammaD: Derivable L}
        {GammaPD: ProvableDerivable L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}.

Instance derivable_proper_impp:
  Proper (eq ==> (fun x y => |-- impp x y) ==> Basics.impl) derivable.
Proof.
  hnf; intros Phi Phi' ?; subst Phi'.
  hnf; intros x1 x2 ?.
  intro.
  apply (deduction_weaken0 Phi) in H.
  exact (deduction_modus_ponens _ _ _ H0 H).
Qed.

Section Derivable1.

Context {GammaD1: Derivable1 L}
        {GammaD1P: Derivable1Provable L GammaP GammaD1}.

Instance derivable_proper_derivable1:
  Proper (eq ==> derivable1 ==> Basics.impl) derivable.
Proof.
  hnf;intros;subst y.
  hnf;intros.
  intro.
  pose proof derivable1_provable x0 y.
  rewrite H1 in H.
  rewrite H in H0.
  tauto.
Qed.

End Derivable1.

End Derivable.

Section Logic_equiv.

Existing Instance derivable_proper_impp.

Context {GammaE: LogicEquiv L}.

Context {GammaEP: EquivProvable L GammaP GammaE}
        {minAX: MinimumAxiomatization L GammaP}.

Instance provable_proper_equiv : Proper (logic_equiv ==> iff) provable.
Proof.
  hnf;intros.
  pose proof logic_equiv_provable x y.
  rewrite H0 in H.
  destruct H.
  split.
  -intros. pose proof modus_ponens _ _ H H2;auto.
  -intros. pose proof modus_ponens _ _ H1 H2;auto.
  Qed.

Context {GammaD:Derivable L}
        {GammaPD: ProvableDerivable L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}.

Instance derivable_proper_equiv:
  Proper (eq ==> logic_equiv ==> iff) derivable.
Proof.
  hnf;intros;subst y.
  hnf;intros.
  pose proof logic_equiv_provable x0 y. rewrite H0 in H.
  destruct H.
  split.
  -intros. rewrite H in H2. auto.
  -intros. rewrite H1 in H2. auto.
Qed.

End Logic_equiv.

End RewriteClass.

Existing Instances provable_impp_rewrite
                   provable_impp_refl_instance
                   provable_proper_impp
                   derivable_proper_impp
                   impp_proper_impp.

Module TestInAxiomatization.

Section TestInAxiomatization.

(* Here, "Section" is used to avoid leaking "Existing Instances". *)

Existing Instances Axiomatization2SequentCalculus_GammaPD
                   Axiomatization2SequentCalculus_bSC
                   Axiomatization2SequentCalculus_minSC.

Goal forall {L: Language} {minL: MinimumLanguage L} {GammaP: Provable L} {GammaD: Derivable L} {GammaDP: DerivableProvable L GammaP GammaD} {minAX: MinimumAxiomatization L GammaP} (Phi: context) y1 y2,
  |-- y1 --> y2 ->
  Phi |--- y1 ->
  Phi |--- y2.
Proof.
  intros.
  rewrite <- H.
  auto.
Qed.

Goal forall {L: Language} {minL: MinimumLanguage L} {GammaP: Provable L} {GammaD: Derivable L} {GammaDP: DerivableProvable L GammaP GammaD} {minAX: MinimumAxiomatization L GammaP} (Phi: context) x1 y1 x2 y2,
  |-- x2 --> x1 ->
  |-- y1 --> y2 ->
  Phi |--- x1 --> y1 ->
  Phi |--- x2 --> y2.
Proof.
  intros.
  rewrite H0 in H1.
  rewrite H.
  auto.
Qed.

Goal forall {L: Language} {minL: MinimumLanguage L} {GammaP: Provable L} {GammaD: Derivable L} {GammaDP: DerivableProvable L GammaP GammaD} {minAX: MinimumAxiomatization L GammaP} (Phi: context) x1 y1 x2 y2,
  |-- x2 --> x1 ->
  |-- y1 --> y2 ->
  |-- (x1 --> y1) --> (x2 --> y2).
Proof.
  intros.
  rewrite <- H0, H.
  apply provable_impp_refl.
Qed.

End TestInAxiomatization.

End TestInAxiomatization.

Module TestInSequentCalculus.

Section TestInSequentCalculus.

(* Here, "Section" is used to avoid leaking "Existing Instances". *)

Existing Instances SequentCalculus2Axiomatization_minAX.

Goal forall {L: Language} {minL: MinimumLanguage L} {GammaP: Provable L} {GammaD: Derivable L} {GammaPD: ProvableDerivable L GammaP GammaD} {bSC: BasicSequentCalculus L GammaD} {minSC: MinimumSequentCalculus L GammaD} (Phi: context) y1 y2,
  |-- y1 --> y2 ->
  Phi |--- y1 ->
  Phi |--- y2.
Proof.
  intros.
  rewrite <- H.
  auto.
Qed.

Goal forall {L: Language} {minL: MinimumLanguage L} {GammaP: Provable L} {GammaD: Derivable L} {GammaPD: ProvableDerivable L GammaP GammaD} {bSC: BasicSequentCalculus L GammaD} {minSC: MinimumSequentCalculus L GammaD} (Phi: context) x1 y1 x2 y2,
  |-- x2 --> x1 ->
  |-- y1 --> y2 ->
  Phi |--- x1 --> y1 ->
  Phi |--- x2 --> y2.
Proof.
  intros.
  rewrite H0 in H1.
  rewrite H.
  auto.
Qed.

Goal forall {L: Language} {minL: MinimumLanguage L} {GammaP: Provable L} {GammaD: Derivable L} {GammaPD: ProvableDerivable L GammaP GammaD} {bSC: BasicSequentCalculus L GammaD} {minSC: MinimumSequentCalculus L GammaD} (Phi: context) x1 y1 x2 y2,
  |-- x2 --> x1 ->
  |-- y1 --> y2 ->
  |-- (x1 --> y1) --> (x2 --> y2).
Proof.
  intros.
  rewrite <- H0, H.
  apply provable_impp_refl.
Qed.

End TestInSequentCalculus.

End TestInSequentCalculus.