(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i Due to L.Thery i*)

(************************************************************)
(* Definitions of log and Rpower : R->R->R; main properties *)
(************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo.
Require Import Ranalysis1.
Require Import Exp_prop.
Require Import Rsqrt_def.
Require Import R_sqrt.
Require Import MVT.
Require Import Ranalysis4.
Open Local Scope R_scope.

Lemma P_Rmin : forall (P:R -> Prop) (x y:R), P x -> P y -> P (Rmin x y).
Proof.
  intros P x y H1 H2; unfold Rmin in |- *; case (Rle_dec x y); intro;
    assumption.
Qed.

Lemma exp_le_3 : exp 1 <= 3.
Proof.
  assert (exp_1 : exp 1 <> 0).
  assert (H0 := exp_pos 1); red in |- *; intro; rewrite H in H0;
    elim (Rlt_irrefl _ H0).
  apply Rmult_le_reg_l with (/ exp 1).
  apply Rinv_0_lt_compat; apply exp_pos.
  rewrite <- Rinv_l_sym.
  apply Rmult_le_reg_l with (/ 3).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite Rmult_1_r; rewrite <- (Rmult_comm 3); rewrite <- Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; replace (/ exp 1) with (exp (-1)).
  unfold exp in |- *; case (exist_exp (-1)); intros; simpl in |- *;
    unfold exp_in in e;
      assert (H := alternated_series_ineq (fun i:nat => / INR (fact i)) x 1).
  cut
    (sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (S (2 * 1)) <= x <=
      sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (2 * 1)).
  intro; elim H0; clear H0; intros H0 _; simpl in H0; unfold tg_alt in H0;
    simpl in H0.
  replace (/ 3) with
  (1 * / 1 + -1 * 1 * / 1 + -1 * (-1 * 1) * / 2 +
    -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)).
  apply H0.
  repeat rewrite Rinv_1; repeat rewrite Rmult_1_r;
    rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
      rewrite Ropp_involutive; rewrite Rplus_opp_r; rewrite Rmult_1_r;
        rewrite Rplus_0_l; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 6.
  rewrite Rmult_plus_distr_l; replace (2 + 1 + 1 + 1 + 1) with 6.
  rewrite <- (Rmult_comm (/ 6)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; replace 6 with 6.
  do 2 rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; rewrite (Rmult_comm 3); rewrite <- Rmult_assoc;
    rewrite <- Rinv_r_sym.
  ring.
  discrR.
  discrR.
  ring.
  discrR.
  ring.
  discrR.
  apply H.
  unfold Un_decreasing in |- *; intros;
    apply Rmult_le_reg_l with (INR (fact n)).
  apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (fact (S n))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; apply le_INR; apply fact_le; apply le_n_Sn.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  assert (H0 := cv_speed_pow_fact 1); unfold Un_cv in |- *; unfold Un_cv in H0;
    intros; elim (H0 _ H1); intros; exists x0; intros;
      unfold R_dist in H2; unfold R_dist in |- *;
        replace (/ INR (fact n)) with (1 ^ n / INR (fact n)).
  apply (H2 _ H3).
  unfold Rdiv in |- *; rewrite pow1; rewrite Rmult_1_l; reflexivity.
  unfold infinite_sum in e; unfold Un_cv, tg_alt in |- *; intros; elim (e _ H0);
    intros; exists x0; intros;
      replace (sum_f_R0 (fun i:nat => (-1) ^ i * / INR (fact i)) n) with
      (sum_f_R0 (fun i:nat => / INR (fact i) * (-1) ^ i) n).
  apply (H1 _ H2).
  apply sum_eq; intros; apply Rmult_comm.
  apply Rmult_eq_reg_l with (exp 1).
  rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
    rewrite <- Rinv_r_sym.
  reflexivity.
  assumption.
  assumption.
  discrR.
  assumption.
Qed.

(******************************************************************)
(** *                     Properties of  Exp                      *)
(******************************************************************)

Theorem exp_increasing : forall x y:R, x < y -> exp x < exp y.
Proof.
  intros x y H.
  assert (H0 : derivable exp).
  apply derivable_exp.
  assert (H1 := positive_derivative _ H0).
  unfold strict_increasing in H1.
  apply H1.
  intro.
  replace (derive_pt exp x0 (H0 x0)) with (exp x0).
  apply exp_pos.
  symmetry  in |- *; apply derive_pt_eq_0.
  apply (derivable_pt_lim_exp x0).
  apply H.
Qed.

Theorem exp_lt_inv : forall x y:R, exp x < exp y -> x < y.
Proof.
  intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ].
  assumption.
  rewrite H1 in H; elim (Rlt_irrefl _ H).
  assert (H2 := exp_increasing _ _ H1).
  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H2)).
Qed.

Lemma exp_ineq1 : forall x:R, 0 < x -> 1 + x < exp x.
Proof.
  intros; apply Rplus_lt_reg_r with (- exp 0); rewrite <- (Rplus_comm (exp x));
    assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0;
      intros; elim H1; intros; unfold Rminus in H2; rewrite H2;
        rewrite Ropp_0; rewrite Rplus_0_r;
          replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0).
  rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
    pattern x at 1 in |- *; rewrite <- Rmult_1_r; rewrite (Rmult_comm (exp x0));
      apply Rmult_lt_compat_l.
  apply H.
  rewrite <- exp_0; apply exp_increasing; elim H3; intros; assumption.
  symmetry  in |- *; apply derive_pt_eq_0; apply derivable_pt_lim_exp.
Qed.

Lemma ln_exists1 : forall y:R, 1 <= y -> { z:R | y = exp z }.
Proof.
  intros; set (f := fun x:R => exp x - y).
  assert (H0 : 0 < y) by (apply Rlt_le_trans with 1; auto with real).
  cut (f 0 <= 0); [intro H1|].
  cut (continuity f); [intro H2|].
  cut (0 <= f y); [intro H3|].
  cut (f 0 * f y <= 0); [intro H4|].
  pose proof (IVT_cor f 0 y H2 (Rlt_le _ _ H0) H4) as (t,(_,H7));
    exists t; unfold f in H7; apply Rminus_diag_uniq_sym; exact H7.
  pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y));
    rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l;
      assumption.
  unfold f in |- *; apply Rplus_le_reg_l with y; left;
    apply Rlt_trans with (1 + y).
  rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1.
  replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H0) | ring ].
  unfold f in |- *; change (continuity (exp - fct_cte y)) in |- *;
    apply continuity_minus;
      [ apply derivable_continuous; apply derivable_exp
        | apply derivable_continuous; apply derivable_const ].
  unfold f in |- *; rewrite exp_0; apply Rplus_le_reg_l with y;
    rewrite Rplus_0_r; replace (y + (1 - y)) with 1; [ apply H | ring ].
Qed.

(**********)
Lemma ln_exists : forall y:R, 0 < y -> { z:R | y = exp z }.
Proof.
  intros; case (Rle_dec 1 y); intro.
  apply (ln_exists1 _ r).
  assert (H0 : 1 <= / y).
  apply Rmult_le_reg_l with y.
  apply H.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ n).
  red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
  destruct (ln_exists1 _ H0) as (x,p); exists (- x);
    apply Rmult_eq_reg_l with (exp x / y).
  unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc;
    rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
      rewrite Rmult_1_r; symmetry  in |- *; apply p.
  red in |- *; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H).
  unfold Rdiv in |- *; apply prod_neq_R0.
  assert (H3 := exp_pos x); red in |- *; intro H4; rewrite H4 in H3;
    elim (Rlt_irrefl _ H3).
  apply Rinv_neq_0_compat; red in |- *; intro H3; rewrite H3 in H;
    elim (Rlt_irrefl _ H).
Qed.

(* Definition of log R+* -> R *)
Definition Rln (y:posreal) : R :=
  let (a,_) := ln_exists (pos y) (cond_pos y) in a.

(* Extension on R *)
Definition ln (x:R) : R :=
  match Rlt_dec 0 x with
    | left a => Rln (mkposreal x a)
    | right a => 0
  end.

Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x.
Proof.
  intros; unfold ln in |- *; case (Rlt_dec 0 x); intro.
  unfold Rln in |- *;
    case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r)));
    intros.
  simpl in e; symmetry  in |- *; apply e.
  elim n; apply H.
Qed.

Theorem exp_inv : forall x y:R, exp x = exp y -> x = y.
Proof.
  intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ]; auto;
    assert (H2 := exp_increasing _ _ H1); rewrite H in H2;
      elim (Rlt_irrefl _ H2).
Qed.

Theorem exp_Ropp : forall x:R, exp (- x) = / exp x.
Proof.
  intros x; assert (H : exp x <> 0).
  assert (H := exp_pos x); red in |- *; intro; rewrite H0 in H;
    elim (Rlt_irrefl _ H).
  apply Rmult_eq_reg_l with (r := exp x).
  rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0.
  apply Rinv_r_sym.
  apply H.
  apply H.
Qed.

(******************************************************************)
(** *                     Properties of  Ln                       *)
(******************************************************************)

Theorem ln_increasing : forall x y:R, 0 < x -> x < y -> ln x < ln y.
Proof.
  intros x y H H0; apply exp_lt_inv.
  repeat rewrite exp_ln.
  apply H0.
  apply Rlt_trans with x; assumption.
  apply H.
Qed.

Theorem ln_exp : forall x:R, ln (exp x) = x.
Proof.
  intros x; apply exp_inv.
  apply exp_ln.
  apply exp_pos.
Qed.

Theorem ln_1 : ln 1 = 0.
Proof.
  rewrite <- exp_0; rewrite ln_exp; reflexivity.
Qed.

Theorem ln_lt_inv : forall x y:R, 0 < x -> 0 < y -> ln x < ln y -> x < y.
Proof.
  intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y).
  apply exp_increasing; apply H1.
  assumption.
  assumption.
Qed.

Theorem ln_inv : forall x y:R, 0 < x -> 0 < y -> ln x = ln y -> x = y.
Proof.
  intros x y H H0 H'0; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ];
    auto.
  assert (H2 := ln_increasing _ _ H H1); rewrite H'0 in H2;
    elim (Rlt_irrefl _ H2).
  assert (H2 := ln_increasing _ _ H0 H1); rewrite H'0 in H2;
    elim (Rlt_irrefl _ H2).
Qed.

Theorem ln_mult : forall x y:R, 0 < x -> 0 < y -> ln (x * y) = ln x + ln y.
Proof.
  intros x y H H0; apply exp_inv.
  rewrite exp_plus.
  repeat rewrite exp_ln.
  reflexivity.
  assumption.
  assumption.
  apply Rmult_lt_0_compat; assumption.
Qed.

Theorem ln_Rinv : forall x:R, 0 < x -> ln (/ x) = - ln x.
Proof.
  intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp.
  reflexivity.
  assumption.
  apply Rinv_0_lt_compat; assumption.
Qed.

Theorem ln_continue :
  forall y:R, 0 < y -> continue_in ln (fun x:R => 0 < x) y.
Proof.
  intros y H.
  unfold continue_in, limit1_in, limit_in in |- *; intros eps Heps.
  cut (1 < exp eps); [ intros H1 | idtac ].
  cut (exp (- eps) < 1); [ intros H2 | idtac ].
  exists (Rmin (y * (exp eps - 1)) (y * (1 - exp (- eps)))); split.
  red in |- *; apply P_Rmin.
  apply Rmult_lt_0_compat.
  assumption.
  apply Rplus_lt_reg_r with 1.
  rewrite Rplus_0_r; replace (1 + (exp eps - 1)) with (exp eps);
    [ apply H1 | ring ].
  apply Rmult_lt_0_compat.
  assumption.
  apply Rplus_lt_reg_r with (exp (- eps)).
  rewrite Rplus_0_r; replace (exp (- eps) + (1 - exp (- eps))) with 1;
    [ apply H2 | ring ].
  unfold dist, R_met, R_dist in |- *; simpl in |- *.
  intros x [[H3 H4] H5].
  cut (y * (x * / y) = x).
  intro Hxyy.
  replace (ln x - ln y) with (ln (x * / y)).
  case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ].
  rewrite Rabs_left.
  apply Ropp_lt_cancel; rewrite Ropp_involutive.
  apply exp_lt_inv.
  rewrite exp_ln.
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy.
  apply Ropp_lt_cancel.
  apply Rplus_lt_reg_r with (r := y).
  replace (y + - (y * exp (- eps))) with (y * (1 - exp (- eps)));
  [ idtac | ring ].
  replace (y + - x) with (Rabs (x - y)).
  apply Rlt_le_trans with (1 := H5); apply Rmin_r.
  rewrite Rabs_left; [ ring | idtac ].
  apply (Rlt_minus _ _ Hxy).
  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
  rewrite <- ln_1.
  apply ln_increasing.
  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
  rewrite Hxy; rewrite Rinv_r.
  rewrite ln_1; rewrite Rabs_R0; apply Heps.
  red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
  rewrite Rabs_right.
  apply exp_lt_inv.
  rewrite exp_ln.
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy.
  apply Rplus_lt_reg_r with (r := - y).
  replace (- y + y * exp eps) with (y * (exp eps - 1)); [ idtac | ring ].
  replace (- y + x) with (Rabs (x - y)).
  apply Rlt_le_trans with (1 := H5); apply Rmin_l.
  rewrite Rabs_right; [ ring | idtac ].
  left; apply (Rgt_minus _ _ Hxy).
  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
  rewrite <- ln_1.
  apply Rgt_ge; red in |- *; apply ln_increasing.
  apply Rlt_0_1.
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
  rewrite ln_mult.
  rewrite ln_Rinv.
  ring.
  assumption.
  assumption.
  apply Rinv_0_lt_compat; assumption.
  rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  ring.
  red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
  apply Rmult_lt_reg_l with (exp eps).
  apply exp_pos.
  rewrite <- exp_plus; rewrite Rmult_1_r; rewrite Rplus_opp_r; rewrite exp_0;
    apply H1.
  rewrite <- exp_0.
  apply exp_increasing; apply Heps.
Qed.

(******************************************************************)
(** *                     Definition of  Rpower                   *)
(******************************************************************)

Definition Rpower (x y:R) := exp (y * ln x).

Infix Local "^R" := Rpower (at level 30, right associativity) : R_scope.

(******************************************************************)
(** *                     Properties of  Rpower                   *)
(******************************************************************)

(** Note: [Rpower] is prolongated to [1] on negative real numbers and
    it thus does not extend integer power. The next two lemmas, which
    hold for integer power, accidentally hold on negative real numbers
    as a side effect of the default value taken on negative real
    numbers. Contrastingly, the lemmas that do not hold for the
    integer power of a negative number are stated for [Rpower] on the
    positive numbers only (even if they accidentally hold due to the
    default value of [Rpower] on the negative side, as it is the case
    for [Rpower_O]). *)

Theorem Rpower_plus : forall x y z:R, z ^R (x + y) = z ^R x * z ^R y.
Proof.
  intros x y z; unfold Rpower in |- *.
  rewrite Rmult_plus_distr_r; rewrite exp_plus; auto.
Qed.

Theorem Rpower_mult : forall x y z:R, (x ^R y) ^R z = x ^R (y * z).
Proof.
  intros x y z; unfold Rpower in |- *.
  rewrite ln_exp.
  replace (z * (y * ln x)) with (y * z * ln x).
  reflexivity.
  ring.
Qed.

Theorem Rpower_O : forall x:R, 0 < x -> x ^R 0 = 1.
Proof.
  intros x _; unfold Rpower in |- *.
  rewrite Rmult_0_l; apply exp_0.
Qed.

Theorem Rpower_1 : forall x:R, 0 < x -> x ^R 1 = x.
Proof.
  intros x H; unfold Rpower in |- *.
  rewrite Rmult_1_l; apply exp_ln; apply H.
Qed.

Theorem Rpower_pow : forall (n:nat) (x:R), 0 < x -> x ^R INR n = x ^ n.
Proof.
  intros n; elim n; simpl in |- *; auto; fold INR in |- *.
  intros x H; apply Rpower_O; auto.
  intros n1; case n1.
  intros H x H0; simpl in |- *; rewrite Rmult_1_r; apply Rpower_1; auto.
  intros n0 H x H0; rewrite Rpower_plus; rewrite H; try rewrite Rpower_1;
    try apply Rmult_comm || assumption.
Qed.

Theorem Rpower_lt :
  forall x y z:R, 1 < x -> 0 <= y -> y < z -> x ^R y < x ^R z.
Proof.
  intros x y z H H0 H1.
  unfold Rpower in |- *.
  apply exp_increasing.
  apply Rmult_lt_compat_r.
  rewrite <- ln_1; apply ln_increasing.
  apply Rlt_0_1.
  apply H.
  apply H1.
Qed.

Theorem Rpower_sqrt : forall x:R, 0 < x -> x ^R (/ 2) = sqrt x.
Proof.
  intros x H.
  apply ln_inv.
  unfold Rpower in |- *; apply exp_pos.
  apply sqrt_lt_R0; apply H.
  apply Rmult_eq_reg_l with (INR 2).
  apply exp_inv.
  fold Rpower in |- *.
  cut ((x ^R (/ INR 2)) ^R INR 2 = sqrt x ^R INR 2).
  unfold Rpower in |- *; auto.
  rewrite Rpower_mult.
  rewrite Rinv_l.
  replace 1 with (INR 1); auto.
  repeat rewrite Rpower_pow; simpl in |- *.
  pattern x at 1 in |- *; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)).
  ring.
  apply sqrt_lt_R0; apply H.
  apply H.
  apply not_O_INR; discriminate.
  apply not_O_INR; discriminate.
Qed.

Theorem Rpower_Ropp : forall x y:R, x ^R (- y) = / x ^R y.
Proof.
  unfold Rpower in |- *.
  intros x y; rewrite Ropp_mult_distr_l_reverse.
  apply exp_Ropp.
Qed.

Theorem Rle_Rpower :
  forall e n m:R, 1 < e -> 0 <= n -> n <= m -> e ^R n <= e ^R m.
Proof.
  intros e n m H H0 H1; case H1.
  intros H2; left; apply Rpower_lt; assumption.
  intros H2; rewrite H2; right; reflexivity.
Qed.

Theorem ln_lt_2 : / 2 < ln 2.
Proof.
  apply Rmult_lt_reg_l with (r := 2).
  prove_sup0.
  rewrite Rinv_r.
  apply exp_lt_inv.
  apply Rle_lt_trans with (1 := exp_le_3).
  change (3 < 2 ^R 2) in |- *.
  repeat rewrite Rpower_plus; repeat rewrite Rpower_1.
  repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
    repeat rewrite Rmult_1_l.
  pattern 3 at 1 in |- *; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1);
    [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ].
  prove_sup0.
  discrR.
Qed.

(*****************************************)
(** * Differentiability of Ln and Rpower *)
(*****************************************)

Theorem limit1_ext :
  forall (f g:R -> R) (D:R -> Prop) (l x:R),
    (forall x:R, D x -> f x = g x) -> limit1_in f D l x -> limit1_in g D l x.
Proof.
  intros f g D l x H; unfold limit1_in, limit_in in |- *.
  intros H0 eps H1; case (H0 eps); auto.
  intros x0 [H2 H3]; exists x0; split; auto.
  intros x1 [H4 H5]; rewrite <- H; auto.
Qed.

Theorem limit1_imp :
  forall (f:R -> R) (D D1:R -> Prop) (l x:R),
    (forall x:R, D1 x -> D x) -> limit1_in f D l x -> limit1_in f D1 l x.
Proof.
  intros f D D1 l x H; unfold limit1_in, limit_in in |- *.
  intros H0 eps H1; case (H0 eps H1); auto.
  intros alpha [H2 H3]; exists alpha; split; auto.
  intros d [H4 H5]; apply H3; split; auto.
Qed.

Theorem Rinv_Rdiv : forall x y:R, x <> 0 -> y <> 0 -> / (x / y) = y / x.
Proof.
  intros x y H1 H2; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
  rewrite Rinv_involutive.
  apply Rmult_comm.
  assumption.
  assumption.
  apply Rinv_neq_0_compat; assumption.
Qed.

Theorem Dln : forall y:R, 0 < y -> D_in ln Rinv (fun x:R => 0 < x) y.
Proof.
  intros y Hy; unfold D_in in |- *.
  apply limit1_ext with
    (f := fun x:R => / ((exp (ln x) - exp (ln y)) / (ln x - ln y))).
  intros x [HD1 HD2]; repeat rewrite exp_ln.
  unfold Rdiv in |- *; rewrite Rinv_mult_distr.
  rewrite Rinv_involutive.
  apply Rmult_comm.
  apply Rminus_eq_contra.
  red in |- *; intros H2; case HD2.
  symmetry  in |- *; apply (ln_inv _ _ HD1 Hy H2).
  apply Rminus_eq_contra; apply (sym_not_eq HD2).
  apply Rinv_neq_0_compat; apply Rminus_eq_contra; red in |- *; intros H2;
    case HD2; apply ln_inv; auto.
  assumption.
  assumption.
  apply limit_inv with
    (f := fun x:R => (exp (ln x) - exp (ln y)) / (ln x - ln y)).
  apply limit1_imp with
    (f := fun x:R => (fun x:R => (exp x - exp (ln y)) / (x - ln y)) (ln x))
    (D := Dgf (D_x (fun x:R => 0 < x) y) (D_x (fun x:R => True) (ln y)) ln).
  intros x [H1 H2]; split.
  split; auto.
  split; auto.
  red in |- *; intros H3; case H2; apply ln_inv; auto.
  apply limit_comp with
    (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln).
  apply ln_continue; auto.
  assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0;
    unfold limit1_in in |- *; unfold limit_in in |- *;
      simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H);
        intros; exists (pos x); split.
  apply (cond_pos x).
  intros; pattern y at 3 in |- *; rewrite <- exp_ln.
  pattern x0 at 1 in |- *; replace x0 with (ln y + (x0 - ln y));
    [ idtac | ring ].
  apply H1.
  elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3;
    apply Rminus_eq_contra; apply (sym_not_eq (A:=R));
      apply H3.
  elim H2; clear H2; intros _ H2; apply H2.
  assumption.
  red in |- *; intro; rewrite H in Hy; elim (Rlt_irrefl _ Hy).
Qed.

Lemma derivable_pt_lim_ln : forall x:R, 0 < x -> derivable_pt_lim ln x (/ x).
Proof.
  intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0;
    unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
      unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1);
        intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2));
          assert (H4 : 0 < alp).
  unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec x0 (x / 2)); intro.
  apply H2.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
  exists (mkposreal _ H4); intros; pattern h at 2 in |- *;
    replace h with (x + h - x); [ idtac | ring ].
  apply H3; split.
  unfold D_x in |- *; split.
  case (Rcase_abs h); intro.
  assert (H7 : Rabs h < x / 2).
  apply Rlt_le_trans with alp.
  apply H6.
  unfold alp in |- *; apply Rmin_r.
  apply Rlt_trans with (x / 2).
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
  rewrite Rabs_left in H7.
  apply Rplus_lt_reg_r with (- h - x / 2).
  replace (- h - x / 2 + x / 2) with (- h); [ idtac | ring ].
  pattern x at 2 in |- *; rewrite double_var.
  replace (- h - x / 2 + (x / 2 + x / 2 + h)) with (x / 2); [ apply H7 | ring ].
  apply r.
  apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply r ].
  apply (sym_not_eq (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
    [ apply H5 | ring ].
  replace (x + h - x) with h;
  [ apply Rlt_le_trans with alp;
    [ apply H6 | unfold alp in |- *; apply Rmin_l ]
    | ring ].
Qed.

Theorem D_in_imp :
  forall (f g:R -> R) (D D1:R -> Prop) (x:R),
    (forall x:R, D1 x -> D x) -> D_in f g D x -> D_in f g D1 x.
Proof.
  intros f g D D1 x H; unfold D_in in |- *.
  intros H0; apply limit1_imp with (D := D_x D x); auto.
  intros x1 [H1 H2]; split; auto.
Qed.

Theorem D_in_ext :
  forall (f g h:R -> R) (D:R -> Prop) (x:R),
    f x = g x -> D_in h f D x -> D_in h g D x.
Proof.
  intros f g h D x H; unfold D_in in |- *.
  rewrite H; auto.
Qed.

Theorem Dpower :
  forall y z:R,
    0 < y ->
    D_in (fun x:R => x ^R z) (fun x:R => z * x ^R (z - 1)) (
      fun x:R => 0 < x) y.
Proof.
  intros y z H;
    apply D_in_imp with (D := Dgf (fun x:R => 0 < x) (fun x:R => True) ln).
  intros x H0; repeat split.
  assumption.
  apply D_in_ext with (f := fun x:R => / x * (z * exp (z * ln x))).
  unfold Rminus in |- *; rewrite Rpower_plus; rewrite Rpower_Ropp;
    rewrite (Rpower_1 _ H); unfold Rpower; ring.
  apply Dcomp with
    (f := ln)
    (g := fun x:R => exp (z * x))
    (df := Rinv)
    (dg := fun x:R => z * exp (z * x)).
  apply (Dln _ H).
  apply D_in_imp with
    (D := Dgf (fun x:R => True) (fun x:R => True) (fun x:R => z * x)).
  intros x H1; repeat split; auto.
  apply
    (Dcomp (fun _:R => True) (fun _:R => True) (fun x => z) exp
      (fun x:R => z * x) exp); simpl in |- *.
  apply D_in_ext with (f := fun x:R => z * 1).
  apply Rmult_1_r.
  apply (Dmult_const (fun x => True) (fun x => x) (fun x => 1)); apply Dx.
  assert (H0 := derivable_pt_lim_D_in exp exp (z * ln y)); elim H0; clear H0;
    intros _ H0; apply H0; apply derivable_pt_lim_exp.
Qed.

Theorem derivable_pt_lim_power :
  forall x y:R,
    0 < x -> derivable_pt_lim (fun x => x ^R y) x (y * x ^R (y - 1)).
Proof.
  intros x y H.
  unfold Rminus in |- *; rewrite Rpower_plus.
  rewrite Rpower_Ropp.
  rewrite Rpower_1; auto.
  rewrite <- Rmult_assoc.
  unfold Rpower in |- *.
  apply derivable_pt_lim_comp with (f1 := ln) (f2 := fun x => exp (y * x)).
  apply derivable_pt_lim_ln; assumption.
  rewrite (Rmult_comm y).
  apply derivable_pt_lim_comp with (f1 := fun x => y * x) (f2 := exp).
  pattern y at 2 in |- *; replace y with (0 * ln x + y * 1).
  apply derivable_pt_lim_mult with (f1 := fun x:R => y) (f2 := fun x:R => x).
  apply derivable_pt_lim_const with (a := y).
  apply derivable_pt_lim_id.
  ring.
  apply derivable_pt_lim_exp.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export csubst2.
Require Export continuity_defs.
Require Export list.  (* Why?? *)

Lemma alpha_eq_bterm_refl {o} :
  forall (b : @BTerm o),
    alpha_eq_bterm b b.
Proof.
  destruct b as [l t].
  apply alpha_eq_bterm_congr; eauto 3 with slow.
Qed.
Hint Resolve alpha_eq_bterm_refl : slow.

Lemma alphaeqbt_vs_nil_refl {o} :
  forall (b : @BTerm o),
    alphaeqbt_vs [] b b.
Proof.
  introv.
  apply alphaeqbt_eq; eauto 3 with slow.
Qed.
Hint Resolve alphaeqbt_vs_nil_refl : slow.

Ltac gen_newvar :=
  match goal with
    | [ |- context[newvarlst ?l] ] => remember (newvarlst l)
    | [ |- context[newvar ?x] ] => remember (newvar x)
  end.

Lemma oneswapvar_eq1 :
  forall a b, oneswapvar a b a = b.
Proof.
  introv.
  unfold oneswapvar; boolvar; sp.
Qed.

Lemma oneswapvar_neq :
  forall a b v, v <> a -> v <> b -> oneswapvar a b v = v.
Proof.
  introv ni1 ni2.
  unfold oneswapvar; boolvar; sp.
Qed.

Lemma newvar_prop2 {p} :
  forall v (t : @NTerm p), LIn v (free_vars t) -> newvar t <> v.
Proof.
  introv i e; subst.
  apply newvar_prop in i; sp.
Qed.
Hint Resolve newvar_prop2 : slow.

Definition agree_upto_b_type {o} vi (b f g : @NTerm o) : NTerm :=
  mk_isect
    (mk_set
       mk_int
       vi
       (mk_member (absolute_value (mk_var vi)) (mk_natk_aux vi b)))
    vi
    (mk_equality
       (mk_apply f (mk_var vi))
       (mk_apply g (mk_var vi))
       mk_int).

Definition continuous_type_aux_aux {o} vb vg vi vf (F f : @NTerm o) :=
  mk_product
    mk_tnat
    vb
    (mk_isect
       int2int
       vg
       (mk_isect
          (agree_upto_b_type
             vi
             (mk_var vb)
             f
             (mk_var vg))
          vf
          (mk_equality
             (mk_apply F f)
             (mk_apply F (mk_var vg))
             mk_int))).

Lemma alphaeq_continuous_type_aux_aux {o} :
  forall vb1 vb2 vg1 vg2 vi1 vi2 vf1 vf2 (F f : @NTerm o),
    closed F
    -> closed f

    -> vi1 <> vb1
    -> vi1 <> vg1
    -> vg1 <> vb1
    -> vf1 <> vg1

    -> vi2 <> vb2
    -> vi2 <> vg2
    -> vg2 <> vb2
    -> vf2 <> vg2

    -> alphaeq
         (continuous_type_aux_aux vb1 vg1 vi1 vf1 F f)
         (continuous_type_aux_aux vb2 vg2 vi2 vf2 F f).
Proof.
  introv clF clf;
  introv ni1 ni2 ni3 ni4 ni5 ni6 ni7 ni8.
  constructor; simpl; auto.
  introv j.
  destruct n;[|destruct n]; try (complete cpx); unfold selectbt; simpl.
  { apply alphaeqbt_eq; auto. }
  pose proof (ex_fresh_var ([vb1,vb2,vg1,vg2,vi1,vi2,vf1,vf2,
                             @newvar o mk_int,
                             @newvar o (mk_less_than (mk_var vi1) (mk_var vb1)),
                             @newvar o (mk_less_than (mk_var vi2) (mk_var vb2))]
                              ++ allvars f
                              ++ allvars F)) as fv; exrepnd.
  allsimpl; allrw not_over_or; repnd; GC.
  apply (aeqbt _ [v]); try (complete (simpl; auto)).
  { apply disjoint_singleton_l; intro k; allsimpl; repndors; subst; tcsp.
    allrw app_nil_r; allrw in_app_iff; allsimpl; repndors; subst; tcsp.
    { allrw in_app_iff; allsimpl; repndors; tcsp. }
    { allrw in_app_iff; allsimpl; repndors; tcsp.
      allrw in_app_iff; allsimpl; repndors; tcsp. }
  }

  simpl.
  allrw oneswapvar_eq1.
  allrw (oneswapvar_neq vb1 v vi1); auto;[].
  allrw (oneswapvar_neq vb1 v vg1); auto;[].
  allrw (oneswapvar_neq vb2 v vi2); auto;[].
  allrw (oneswapvar_neq vb2 v vg2); auto;[].
  repeat (rw (oneswapvar_neq vb1 v (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1))));
          auto; try (apply newvar_prop2; simpl; tcsp);[]);[].
  repeat (rw (oneswapvar_neq vb2 v (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2))));
          auto; try (apply newvar_prop2; simpl; tcsp);[]);[].

  constructor; simpl; tcsp; fold_terms.
  introv i.
  destruct n;[|destruct n]; try (complete cpx); unfold selectbt; simpl;
  eauto 3 with slow;[|].

  { apply alphaeqbt_eq.
    apply alphaeqbt_nilv2.
    apply alphaeq_eq.
    constructor; simpl; auto.
    introv k.
    destruct n;[|destruct n]; cpx; unfold selectbt; simpl.
    { apply alphaeqbt_eq; auto. }
    pose proof (ex_fresh_var ([oneswapvar vb1 v (newvar (@mk_int o)),
                               oneswapvar vb2 v (newvar (@mk_int o))])) as fv; exrepnd.
    apply (aeqbt _ [v0]); simpl; auto.
    { apply disjoint_singleton_l; intro k; allsimpl.
      allrw not_over_or; repndors; tcsp. }
    { apply alphaeq_refl. }
  }

  { pose proof (ex_fresh_var ([v, vg1, vi1, vg2, vi2, vb1, vf1, vb2, vf2,
                               oneswapvar vb1 v vf1,
                               oneswapvar vb2 v vf2,
                               oneswapvar vb1 v nvarx,
                               oneswapvar vb2 v nvarx,
                               newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)),
                               newvar (mk_less_than (mk_var vi2) (@mk_var o vb2))
                              ]
                                ++ allvars (cswap [(vb1, v)] f)
                                ++ allvars (cswap [(vb1, v)] F)
                                ++ allvars (cswap [(vb2, v)] f)
                                ++ allvars (cswap [(vb2, v)] F)
                                ++ allvars f
                                ++ allvars F
                             )
               ) as fv; exrepnd.
    allsimpl; allrw not_over_or; repnd; GC.
    apply (aeqbt _ [v0]); allsimpl; tcsp.

    { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp.
      allrw app_nil_r; allrw in_app_iff; allsimpl; allrw not_over_or;
      allrw in_app_iff; allsimpl; repndors; tcsp.
      allrw in_app_iff; allsimpl; repndors; tcsp. }

    allrw oneswapvar_eq1.
    allrw (oneswapvar_neq vg1 v0 vi1); auto;[].
    allrw (oneswapvar_neq vg1 v0 v); auto;[].
    allrw (oneswapvar_neq vg1 v0 vf1); auto;[].
    allrw (oneswapvar_neq vg2 v0 vi2); auto;[].
    allrw (oneswapvar_neq vg2 v0 v); auto;[].
    allrw (oneswapvar_neq vg2 v0 vf2); auto;[].

    constructor; allsimpl; tcsp.
    introv i.
    destruct n;[|destruct n]; try (complete cpx); unfold selectbt; simpl;
    fold_terms;[|].

    { apply alphaeqbt_eq.
      apply alphaeqbt_nilv2.
      apply alphaeq_eq.
      constructor; simpl; auto.
      introv k.
      destruct n;[|destruct n]; cpx; unfold selectbt; simpl;[|].

      { apply alphaeqbt_eq.
        apply alphaeqbt_nilv2.
        apply alphaeq_eq.
        constructor; simpl; auto.
        introv k.
        destruct n;[|destruct n]; cpx; unfold selectbt; simpl.
        { apply alphaeqbt_eq; auto. }

        pose proof (ex_fresh_var ([vi1, vi2, v,
                                   oneswapvar vg1 v0 (oneswapvar vb1 v nvarx),
                                   oneswapvar vg1 v0 (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1))),
                                   oneswapvar vg2 v0 (oneswapvar vb2 v nvarx),
                                   oneswapvar vg2 v0 (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))
                                  ]
                                 )
                   ) as fv; exrepnd.
        allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
        apply (aeqbt _ [v1]); simpl; auto.
        { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }

        allrw oneswapvar_eq1.
        allrw (oneswapvar_neq vi1 v1 v); auto;[].
        allrw (oneswapvar_neq vi2 v1 v); auto;[].

        rw (oneswapvar_neq vi1 v1
                           (oneswapvar vg1 v0
                                       (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)))));
          tcsp;
          [|complete (unfold oneswapvar; boolvar; tcsp; apply newvar_prop2; simpl; sp)].

        rw (oneswapvar_neq vi2 v1
                           (oneswapvar vg2 v0
                                       (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))));
          tcsp;
          [|complete (unfold oneswapvar; boolvar; tcsp; apply newvar_prop2; simpl; sp)].

        fold_terms.
        constructor; simpl; auto.
        introv k.
        destruct n;[|destruct n;[|destruct n] ]; cpx; unfold selectbt; simpl;
        eauto 3 with slow;[].

        (*
        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.
          constructor; simpl; auto.
          introv p.
          destruct n;[|destruct n;[|destruct n;[|destruct n] ] ]; cpx; unfold selectbt; simpl;
          eauto 3 with slow;[].

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alpha_eq_refl.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }

          { apply alphaeqbt_eq; auto. }

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            constructor; simpl; auto.
            introv p.
            destruct n; cpx; unfold selectbt; simpl; tcsp.
            apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }
        }

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.
          constructor; simpl; auto.
          introv p.
          destruct n;[|destruct n;[|destruct n;[|destruct n] ] ]; cpx; unfold selectbt; simpl.

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }

          { apply alphaeqbt_eq; auto. }

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            constructor; simpl; auto.
            introv p.
            destruct n; cpx; unfold selectbt; simpl; tcsp.
            apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw oneswapvar_eq1; tcsp. }
        }
*)

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.
          constructor; simpl; auto.
          fold_terms.
          introv p.
          destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp; eauto 3 with slow;[].

          (*
          { apply alphaeqbt_eq; auto. }
*)

          { pose proof (ex_fresh_var ([ v1, v,
                                        oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx)),
                                        oneswapvar vg1 v0 (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1))),
                                        oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx)),
                                        oneswapvar vg2 v0 (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))
                                      ]
                                     )
                       ) as fv; exrepnd.
            allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
            apply (aeqbt _ [v2]); simpl; auto.
            { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }

            fold_terms;[].
            constructor; simpl; auto.

            allrw oneswapvar_eq1.
            allrw (oneswapvar_neq v1 v2 v); auto;[].

            introv p.
            destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp; eauto 3 with slow;[|].

            { apply alphaeqbt_eq.
              apply alphaeqbt_nilv2.
              apply alphaeq_eq.
              constructor; simpl; auto.
              introv q.
              destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp.

              { apply alphaeqbt_eq.
                apply alphaeqbt_nilv2.
                apply alphaeq_eq.
                constructor; simpl; auto.
                introv r.
                destruct n;[|destruct n;[|destruct n;[|destruct n] ] ]; cpx; unfold selectbt; simpl; tcsp;
                eauto 3 with slow;[].

                (*
                { apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  allrw oneswapvar_eq1; tcsp. }

                { apply alphaeqbt_eq; auto. }

                { apply alphaeqbt_eq; auto. }
*)

                { apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv r.
                  destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp;
                  eauto 3 with slow;[].

                  (*
                  { apply alphaeqbt_eq; auto. }
*)

                  { apply alphaeqbt_eq.
                    apply alphaeqbt_nilv2.
                    apply alphaeq_eq.
                    constructor; simpl; auto.
                    introv r.
                    destruct n; cpx; unfold selectbt; simpl; tcsp.

                    { apply alphaeqbt_eq.
                      apply alphaeqbt_nilv2.
                      apply alphaeq_eq.
                      constructor; simpl; auto.
                      introv s.
                      destruct n; cpx; unfold selectbt; simpl; tcsp.

                      { pose proof (ex_fresh_var ([ oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx))),
                                                    oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx)))
                                                  ]
                                                 )
                                   ) as fv; exrepnd.
                        allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
                        apply (aeqbt _ [v3]); simpl; auto.
                        { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
                        fold_terms;[].

                        allrw oneswapvar_eq1; tcsp.
                      }
                    }
                  }
                }
              }

              { pose proof (ex_fresh_var ([ oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v (newvar (@mk_void o))))),
                                            oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v (newvar (@mk_void o)))))
                                          ]
                                         )
                           ) as fv; exrepnd.
                allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
                apply (aeqbt _ [v3]); simpl; auto.
                { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
                fold_terms;[].

                constructor; simpl; auto.
                introv r.
                destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp;
                eauto 3 with slow;[].

                (*
                { apply alphaeqbt_eq; auto. }
*)

                { apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv r.
                  destruct n; cpx; unfold selectbt; simpl; tcsp;[].

                  apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv q.
                  destruct n; cpx; unfold selectbt; simpl; tcsp;[].

                  pose proof (ex_fresh_var ([ oneswapvar
                                                (oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v (newvar (@mk_void o)))))) v3
                                                (oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx)))),
                                              oneswapvar
                                                (oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v (newvar (@mk_void o)))))) v3
                                                (oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx))))
                                            ]
                                           )
                             ) as fv; exrepnd.
                  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
                  apply (aeqbt _ [v4]); simpl; auto.
                  { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
                  fold_terms;[].
                  allrw oneswapvar_eq1; tcsp.
                }
              }
            }

            { pose proof (ex_fresh_var ([ v, v2,
                                          oneswapvar v1 v2 (oneswapvar vg1 v0 (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)))),
                                          oneswapvar v1 v2 (oneswapvar vg2 v0 (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))),
                                          oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx))),
                                          oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx)))
                                        ]
                                       )
                         ) as fv; exrepnd.
              allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
              apply (aeqbt _ [v3]); simpl; auto.
              { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
              fold_terms;[].

              rw (oneswapvar_neq v1 v2
                                 (oneswapvar vg1 v0
                                             (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)))));
                tcsp;[].

              rw (oneswapvar_neq v1 v2
                                 (oneswapvar vg2 v0
                                             (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))));
                tcsp;[].

              constructor; simpl; auto.
              introv r.
              destruct n;[|destruct n;[|destruct n;[|destruct n] ] ]; cpx; unfold selectbt; simpl; tcsp;
              eauto 3 with slow;[| |].

              { apply alphaeqbt_eq.
                apply alphaeqbt_nilv2.
                apply alphaeq_eq.
                allrw oneswapvar_eq1; tcsp.

                rw (oneswapvar_neq
                      (oneswapvar vg1 v0
                                  (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1))))
                      v3 v2);
                    tcsp;[].

                rw (oneswapvar_neq
                      (oneswapvar vg2 v0
                                  (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2))))
                      v3 v2);
                    tcsp; eauto 3 with slow.
              }

              { apply alphaeqbt_eq.
                apply alphaeqbt_nilv2.
                apply alphaeq_eq.
                unfold oneswapvar; boolvar; eauto 3 with slow; sp.
              }

              (*
              { apply alphaeqbt_eq; auto. }
*)

              { apply alphaeqbt_eq.
                apply alphaeqbt_nilv2.
                apply alphaeq_eq.
                constructor; simpl; auto.
                introv r.
                destruct n;[|destruct n]; cpx; unfold selectbt; simpl; tcsp;
                eauto 3 with slow;[].

                (*
                { apply alphaeqbt_eq; auto. }
*)

                { apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv r.
                  destruct n; cpx; unfold selectbt; simpl; tcsp.

                  apply alphaeqbt_eq.
                  apply alphaeqbt_nilv2.
                  apply alphaeq_eq.
                  constructor; simpl; auto.
                  introv q.
                  destruct n; cpx; unfold selectbt; simpl; tcsp.

                  pose proof (ex_fresh_var ([ oneswapvar
                                                (oneswapvar vg1 v0 (newvar (mk_less_than (mk_var vi1) (@mk_var o vb1)))) v3
                                                (oneswapvar v1 v2 (oneswapvar vi1 v1 (oneswapvar vg1 v0 (oneswapvar vb1 v nvarx)))),
                                              oneswapvar
                                                (oneswapvar vg2 v0 (newvar (mk_less_than (mk_var vi2) (@mk_var o vb2)))) v3
                                                (oneswapvar v1 v2 (oneswapvar vi2 v1 (oneswapvar vg2 v0 (oneswapvar vb2 v nvarx))))
                                            ]
                                           )
                             ) as fv; exrepnd.
                  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
                  apply (aeqbt _ [v4]); simpl; auto.
                  { apply disjoint_singleton_l; intro k; allsimpl; repndors; tcsp. }
                  fold_terms;[].
                  allrw oneswapvar_eq1; tcsp.
                }
              }
            }
          }
        }
      }

      { pose proof (ex_fresh_var ([ vi1, vi2, v0, vg1, vb1, v, vg2, vb2
                                  ]
                                    ++ allvars (cswap [(vg1, v0)] (cswap [(vb1, v)] f))
                                    ++ allvars (cswap [(vg2, v0)] (cswap [(vb2, v)] f))
                                    ++ allvars f
                                 )
                   ) as fv; exrepnd.
        allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
        apply (aeqbt _ [v1]); simpl; auto.
        { apply disjoint_singleton_l; intro k; allsimpl;
          allrw in_app_iff; allsimpl;
          repndors; tcsp. }
        fold_terms;[].
        allrw oneswapvar_eq1; tcsp.
        constructor; simpl; auto.

        introv k.
        destruct n;[|destruct n;[|destruct n ] ]; cpx; unfold selectbt; simpl; tcsp;
        eauto 3 with slow;[|].

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          constructor; simpl; auto.
          introv p.
          destruct n;[|destruct n ]; cpx; unfold selectbt; simpl; tcsp;
          eauto 3 with slow;[].

          { apply alphaeqbt_eq.
            apply alphaeqbt_nilv2.
            apply alphaeq_eq.
            allrw @cswap_cswap; allsimpl.
            apply (alphaeq_trans _ f).
            { apply alphaeq_cswap_cl2; simpl; repeat (rw disjoint_cons_l);
              simpl; allrw not_over_or; dands; try (rw clf); tcsp.
              repeat (rw no_repeats_cons); dands; simpl; tcsp. }
            { apply alphaeq_sym.
              apply alphaeq_cswap_cl2; simpl; repeat (rw disjoint_cons_l);
              simpl; allrw not_over_or; dands; try (rw clf); tcsp.
              repeat (rw no_repeats_cons); dands; simpl; tcsp. }
          }

          (*
          { apply alphaeqbt_eq; apply alphaeqbt_nilv2; auto. }
*)
        }

        { rw (oneswapvar_neq vi1 v1 v0); auto.
          rw (oneswapvar_neq vi2 v1 v0); auto.
          apply alphaeqbt_eq; apply alphaeqbt_nilv2; auto. }

        (*
        { apply alphaeqbt_eq; apply alphaeqbt_nilv2; auto. }
*)
      }
    }

    { rw (oneswapvar_neq vg1 v0 (oneswapvar vb1 v vf1));
      auto; [|unfold oneswapvar; boolvar; complete sp].

      rw (oneswapvar_neq vg2 v0 (oneswapvar vb2 v vf2));
      auto; [|unfold oneswapvar; boolvar; complete sp].

      pose proof (ex_fresh_var ([ v0, vg1, vb1, vg2, vb2,
                                  oneswapvar vb1 v vf1,
                                  oneswapvar vb2 v vf2
                                ]
                                  ++ allvars (cswap [(vg1, v0)] (cswap [(vb1, v)] F))
                                  ++ allvars (cswap [(vg1, v0)] (cswap [(vb1, v)] f))
                                  ++ allvars (cswap [(vg2, v0)] (cswap [(vb2, v)] F))
                                  ++ allvars (cswap [(vg2, v0)] (cswap [(vb2, v)] f))
                                  ++ allvars F
                               )
                 ) as fv; exrepnd.
      allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.
      apply (aeqbt _ [v1]); simpl; auto.
      { apply disjoint_singleton_l; intro k; allsimpl;
        allrw in_app_iff; allsimpl; repndors; tcsp. }
      fold_terms;[].
      allrw oneswapvar_eq1; tcsp.
      constructor; simpl; auto.

      introv p.
      destruct n;[|destruct n;[|destruct n] ]; cpx; unfold selectbt; simpl; tcsp;
      eauto 3 with slow;[|].

      { apply alphaeqbt_eq.
        apply alphaeqbt_nilv2.
        apply alphaeq_eq.

        constructor; simpl; auto.

        introv q.
        destruct n;[|destruct n ]; cpx; unfold selectbt; simpl; tcsp;
        eauto 3 with slow;[|].

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          apply (alphaeq_trans _ F).

          { pose proof (alphaeq_cswap_cl2 F [(vb1,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb1,v)] F) [(vg1,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clF; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg1,v0)] (cswap [(vb1,v)] F)) [(oneswapvar vb1 v vf1, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clF; simpl; tcsp. }
            eauto with slow. }

          { pose proof (alphaeq_cswap_cl2 F [(vb2,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb2,v)] F) [(vg2,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clF; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg2,v0)] (cswap [(vb2,v)] F)) [(oneswapvar vb2 v vf2, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clF; simpl; tcsp. }
            eauto with slow. }
        }

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          apply (alphaeq_trans _ f).

          { pose proof (alphaeq_cswap_cl2 f [(vb1,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb1,v)] f) [(vg1,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clf; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg1,v0)] (cswap [(vb1,v)] f)) [(oneswapvar vb1 v vf1, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clf; simpl; tcsp. }
            eauto with slow. }

          { pose proof (alphaeq_cswap_cl2 f [(vb2,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb2,v)] f) [(vg2,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clf; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg2,v0)] (cswap [(vb2,v)] f)) [(oneswapvar vb2 v vf2, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clf); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clf; simpl; tcsp. }
            eauto with slow. }
        }
      }

      { apply alphaeqbt_eq.
        apply alphaeqbt_nilv2.
        apply alphaeq_eq.

        constructor; simpl; auto.
        introv q.
        destruct n;[|destruct n ]; cpx; unfold selectbt; simpl; tcsp;
        eauto 3 with slow;[|].

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          apply (alphaeq_trans _ F).

          { pose proof (alphaeq_cswap_cl2 F [(vb1,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb1,v)] F) [(vg1,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clF; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg1,v0)] (cswap [(vb1,v)] F)) [(oneswapvar vb1 v vf1, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clF; simpl; tcsp. }
            eauto with slow. }

          { pose proof (alphaeq_cswap_cl2 F [(vb2,v)]) as h1.
            repeat (autodimp h1 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp;[].

            pose proof (alphaeq_cswap_cl2 (cswap [(vb2,v)] F) [(vg2,v0)]) as h2.
            repeat (autodimp h2 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1; rw clF; simpl; tcsp. }

            pose proof (alphaeq_cswap_cl2 (cswap [(vg2,v0)] (cswap [(vb2,v)] F)) [(oneswapvar vb2 v vf2, v1)]) as h3.
            repeat (autodimp h3 hyp); simpl; repeat (rw disjoint_singleton_l);
            simpl; try (allrw clF); tcsp.
            { apply alphaeq_eq in h2; apply alphaeq_preserves_free_vars in h2; rw h2.
              apply alphaeq_eq in h1; apply alphaeq_preserves_free_vars in h1; rw h1.
              rw clF; simpl; tcsp. }
            eauto with slow. }
        }

        { apply alphaeqbt_eq.
          apply alphaeqbt_nilv2.
          apply alphaeq_eq.

          unfold oneswapvar; boolvar; tcsp; eauto 3 with slow.
        }
      }

      (*
      { apply alphaeqbt_eq; auto. }
*)
    }
  }
Qed.


Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils Monad.
From Pyrosome.Theory Require Import Core.
Import Core.Notations.

Section WithVar.
  Context (V : Type)
    {V_Eqb : Eqb V}
    {V_Eqb_ok : Eqb_ok V_Eqb}
    {V_default : WithDefault V}.

  Notation named_list := (@named_list V).
  Notation named_map := (@named_map V).
  Notation term := (@term V).
  Notation ctx := (@ctx V).
  Notation sort := (@sort V).
  Notation subst := (@subst V).
  Notation rule := (@rule V).
  Notation lang := (@lang V).

  Notation eq_subst l :=
    (eq_subst (Model:= core_model l)).
  Notation eq_args l :=
    (eq_args (Model:= core_model l)).
  Notation wf_subst l :=
    (wf_subst (Model:= core_model l)).
  Notation wf_args l :=
    (wf_args (Model:= core_model l)).
  Notation wf_ctx l :=
    (wf_ctx (Model:= core_model l)).

  Section Terms.
    Context (l : lang).

    Fixpoint compute_noconv_wf_term c e fuel : option sort :=
      match e with
      | var x => named_list_lookup_err c x
      | con name s =>
          @! let (S fuel') <?- @! ret fuel in
             let (term_rule c' args t) <?- named_list_lookup_err l name in
             let tt <- compute_noconv_wf_args c s c' fuel' in
             ret t[/with_names_from c' s/]
      end
    with compute_noconv_wf_args c s c' fuel : option unit :=
           match c', s with
           | [], [] => @! ret tt
           | [], _ => None
           | (name,t)::c'', [] => None
           | (name,t')::c'', e::s' =>
               @! let (S fuel') <?- @! ret fuel in
                  let t <- compute_noconv_wf_term c e fuel' in
                  let !(eqb t t'[/with_names_from c'' s'/]) in
                  let tt <- compute_noconv_wf_args c s' c'' fuel' in
                  ret tt
           end.

    Arguments compute_noconv_wf_term c !e !fuel /.
    Arguments compute_noconv_wf_args c !s !c' !fuel/.

    (*TODO: deprecate when feasible? *)
    Lemma compute_noconv_wf_term_sound c e t fuel
      : wf_lang l ->
        wf_ctx l c ->
        Some t = compute_noconv_wf_term c e fuel ->
        wf_term l c e t
    with compute_noconv_wf_args_sound c s c' fuel
      : wf_lang l ->
        wf_ctx l c ->
        wf_ctx l c' ->
        Some tt = compute_noconv_wf_args c s c' fuel ->
        wf_args l c s c'.
    Proof.
      all: intros wfl wfc.
      {
        destruct e; destruct fuel; basic_goal_prep; basic_core_firstorder_crush.
        revert H; case_match; basic_goal_prep; [|basic_core_crush].
        (*TODO: Some = default rewrite?*)
        unfold default, option_default in H.
        revert H; case_match; basic_goal_prep; try congruence.
        revert H; case_match; basic_goal_prep; try congruence.
        (*TODO: why is this slow? basic_core_firstorder_crush.*)
        autorewrite with utils in *.
        subst.
        eapply wf_term_by;
          eauto with lang_core model utils.
      }
      {
        destruct s; destruct c'; destruct fuel;
          basic_goal_prep;
          intuition break;
          autorewrite with utils model term lang_core in *;
          try tauto.
        (*TODO: automation for pushing props under matches?
          What about rewriting matches to existential or?
          The latter is probably bad.
         *)
        revert H0.
        case_match; basic_goal_prep; [|basic_core_crush].
        revert H0.
        case_match; basic_goal_prep; [|basic_core_crush].
        revert H0.
        case_match; basic_goal_prep; [|basic_core_crush].
        (* TODO: why does this take a long time?
          basic_core_crush. *)
        autorewrite with utils model term lang_core in *.
        subst.
        split; eauto.
      }
    Qed.

    Fixpoint compute_noconv_wf_subst c s c' fuel : option unit :=
      match c', s with
      | [], [] => @! ret tt
      | [], _ => None
      | (name,t)::c'', [] => None
      | (name,t')::c'', (name',e)::s' =>
          @! let ! eqb name name' in
             let t <- compute_noconv_wf_term c e fuel in
             let !(eqb t t'[/ s'/]) in
             let tt <- compute_noconv_wf_subst c s' c'' fuel in
             ret tt
      end.

    Lemma compute_noconv_wf_subst_sound c s c' fuel
      : wf_lang l ->
        wf_ctx l c ->
        wf_ctx l c' ->
        Some tt = compute_noconv_wf_subst c s c' fuel ->
        wf_subst l c s c'.
    Proof using V_Eqb_ok.
      intros wfl wfc.
      revert c'.
      induction s; destruct c'; basic_goal_prep; [basic_core_crush..|].
      repeat (revert H0; case_match; basic_goal_prep; [|basic_core_crush]).
      autorewrite with utils model term lang_core in *.
      subst.
      intuition eauto.
      eapply compute_noconv_wf_term_sound; eauto.
    Qed.

    Definition compute_noconv_wf_sort c t fuel : option unit :=
      match t with
      | scon name s =>
          @! let (S fuel') <?- @! ret fuel in
             let (sort_rule c' args) <?- named_list_lookup_err l name in
             let tt <- compute_noconv_wf_args c s c' fuel' in
             ret tt
      end.

    Lemma compute_noconv_wf_sort_sound c t fuel
      : wf_lang l ->
        wf_ctx l c ->
        Some tt = compute_noconv_wf_sort c t fuel ->
        wf_sort l c t.
    Proof.
      intros wfl wfc.

      destruct t; destruct fuel; basic_goal_prep; basic_core_firstorder_crush.

      revert H; case_match; basic_goal_prep; [|basic_core_crush].
      destruct r; basic_goal_prep; basic_core_firstorder_crush.

      revert H; case_match; basic_goal_prep; [|basic_core_crush].

      safe_invert H.
      eapply wf_sort_by; eauto with utils.
      eapply compute_noconv_wf_args_sound; eauto.
      basic_core_crush.
    Qed.

    Fixpoint compute_noconv_wf_ctx c fuel : option unit :=
      match c with
      | [] => @! ret tt
      | (name,t)::c' =>
          @! let ! freshb name c' in
             let tt <- compute_noconv_wf_sort c' t fuel in
             let tt <- compute_noconv_wf_ctx c' fuel in
             ret tt
      end.

    Lemma compute_noconv_wf_ctx_sound c fuel
      : wf_lang l ->
        Some tt = compute_noconv_wf_ctx c fuel ->
        wf_ctx l c.
    Proof.
      intro wfl.
      induction c; basic_goal_prep.
      { basic_core_crush. }
      revert H; case_match; basic_goal_prep; [|basic_core_crush].
      revert H; case_match; basic_goal_prep; [|basic_core_crush].
      revert H; case_match; basic_goal_prep; [|basic_core_crush].
      basic_core_firstorder_crush.
      - apply (use_compute_fresh _).
        congruence.
      - eapply compute_noconv_wf_sort_sound; eauto.
    Qed.

    Definition compute_noconv_wf_rule r fuel : option unit :=
      match r with
      | sort_rule c args =>
          @! let ! sublistb args (map fst c) in
             let tt <- compute_noconv_wf_ctx c fuel in
             ret tt
      | term_rule c args t =>
          @! let ! sublistb args (map fst c) in
             let tt <- compute_noconv_wf_ctx c fuel in
             let tt <- compute_noconv_wf_sort c t fuel in
             ret tt
      | sort_eq_rule c t t'=>
          @! let tt <- compute_noconv_wf_ctx c fuel in
             let tt <- compute_noconv_wf_sort c t fuel in
             let tt <- compute_noconv_wf_sort c t' fuel in
             ret tt
      | term_eq_rule c e e' t =>
          @! let tt <- compute_noconv_wf_ctx c fuel in
             let tt <- compute_noconv_wf_sort c t fuel in
             let t1 <- compute_noconv_wf_term c e fuel in
             let t2 <- compute_noconv_wf_term c e' fuel in
             let ! eqb t1 t in
             let ! eqb t2 t in
             ret tt
      end.

    Lemma compute_noconv_wf_rule_sound r fuel
      : wf_lang l ->
        Some tt = compute_noconv_wf_rule r fuel ->
        wf_rule l r.
    Proof.
      intro wfl.
      destruct r; basic_goal_prep.
      all: repeat (revert H; case_match; basic_goal_prep; [|basic_core_crush]).

      all:autorewrite with lang_core utils in *.
      all:subst.

      all: intuition eauto using compute_noconv_wf_ctx_sound,
        compute_noconv_wf_sort_sound,
        compute_noconv_wf_term_sound,
        use_sublistb.
    Qed.

  End Terms.

  Fixpoint compute_noconv_wf_lang l fuel : option unit :=
    match l with
    | [] => @! ret tt
    | (name,t)::l' =>
        @! let ! (freshb name l') in
           let tt <- compute_noconv_wf_rule l' t fuel in
           let tt <- compute_noconv_wf_lang l' fuel in
           ret tt
    end.

  Lemma compute_noconv_wf_lang_sound l fuel
    : Some tt = compute_noconv_wf_lang l fuel ->
      wf_lang l.
  Proof.
    induction l; basic_goal_prep.
    { basic_core_crush. }
    revert H; case_match; basic_goal_prep; [|basic_core_crush].
    revert H; case_match; basic_goal_prep; [|basic_core_crush].
    revert H; case_match; basic_goal_prep; [|basic_core_crush].
    basic_core_crush.
    - apply (use_compute_fresh _); congruence.
    - eapply compute_noconv_wf_rule_sound; eauto.
  Qed.

End WithVar.

Ltac solve_wf_ctx :=
  (apply compute_noconv_wf_ctx_sound with (fuel := 100);
   [ typeclasses eauto | assumption | vm_compute; reflexivity ]).

Ltac compute_noconv_subst_wf :=
  apply compute_noconv_wf_subst_sound with (fuel := 100);
  [ assumption
  | solve_wf_ctx
  | solve_wf_ctx
  | vm_compute; reflexivity ].

Ltac compute_noconv_term_wf :=
    apply compute_noconv_wf_term_sound with (fuel := 100);
    [typeclasses eauto
    | assumption
    | solve_wf_ctx
    | vm_compute; reflexivity].


Require Import Program.
Require Import Lists.List.

Inductive sorts : Set :=
| INT_S
| ID_S
.

Parameter Ident : Set.

Definition sort : Set := sorts.

Inductive Constructors : Set := INTC (n: nat).

Definition constructors : Set := Constructors.

Fixpoint get_sig (x:constructors) : (list sort) * sort :=
  match x with
    | INTC n => ([], INT_S)
  end.

Record point := rec {x : nat ; y : nat}.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        syntaxb_ott
        rules_inf
        rulesb_inf
        Infrastructure
        Infrastructure_b
        Typing_b
        ttyping.

Require Import List. Import ListNotations.
Require Import Arith Omega.
Require Import Strings.String.

Require Import Omega.

Ltac size_ind_auto :=
  ( eapply_first_lt_hyp ;
    try reflexivity;
    try omega ;
    try eauto ).

Lemma eq_type: forall A,
 (A = t_dyn) \/ ~(A = t_dyn).
Proof.
  introv.
  inductions A;
  try solve[left;
  reflexivity];
  try solve[right;
  unfold not; intros H;
  inverts* H].
Qed.

Lemma BA_AB: forall B A,
  sim A B -> sim B A.
Proof.
  introv H.
  induction* H.
Qed.

Lemma principle_if: forall v A t,
 value v -> ttyping nil v Inf A t -> principal_type v = A.
Proof.
  introv H typ.
  inductions H; inverts* typ; eauto.
Qed.

Lemma fillb_cast: forall v A B,
  (trm_cast v A B) = (fillb (castCtxb A B)  v).
Proof.
  introv.
  eauto.
Qed.

Lemma value_valueb: forall e t A,
 ttyping nil e Inf A t -> value e ->
 valueb t.
Proof.
  introv typ H. gen t A.
  inductions H; intros;
  try solve [inverts* typ].
  - inverts typ.
    forwards*: lc_lcb H.
  - inverts typ.
    inverts* H3.
    forwards*: value_lc H.
    forwards*: lc_lcb H1.
    inverts H2.
    forwards*: IHvalue.
    inverts H; inverts H1. inverts H0.
  - inverts typ.
    inverts* H3.
    forwards*: IHvalue.
    forwards*: principle_if H1.
    rewrite H5 in H.
    apply valueb_dyn; eauto.
Qed.

Lemma sim_refl: forall A,
 sim A A.
Proof.
  intros.
  inductions A; eauto.
Qed.

Theorem Tred_blame_soundness: forall v t A,
  ttyping nil (e_anno v A) Inf A t->
  value v ->
  TypedReduce v A e_blame ->
  t ->* t_blame.
Proof.
  introv Typ val Red.
  inductions Red; intros.
  inverts Typ. inverts H2. inverts H0. inverts H6.
  --
  simpl in *.
  destruct A.
  eapply bstep_b.
  apply bStep_vanyp; eauto.
  unfold not; intros nt; inverts* nt.
  forwards*: value_valueb val. inverts* H2.
  exfalso; apply H; eauto.
  exfalso; apply H; eauto.
  --
  inverts val.
  forwards*: principle_if H0.
  inductions A.
  - inverts* H7.
    + rewrite <- H10 in H.
      exfalso. apply H.
      eauto.
    + eapply bstep_b.
      apply bStep_vanyp; eauto.
      rewrite <- H10 in H6. inverts* H6.
      rewrite <- H10 in H6. inverts H6.
      unfold not; intros nt; inverts nt.
      forwards*: value_valueb H8.
  - inverts* H7.
    +
      destruct (eq_type A1).
      destruct (eq_type A2).
      subst.
       eapply bstep_b.
      apply bStep_vanyp; eauto.
      rewrite <- H10; eauto.  rewrite <- H10.
      unfold not; intros n; inverts n.
      forwards*: value_valueb H8.
      eapply bstep_nb.
      apply bStep_dyna; eauto.
      apply valueb_dyn; eauto.
      forwards*: value_valueb H0.
      rewrite <- H10 in H6. inverts* H6.
      unfold not; intros n; inverts n.
      unfold not; intros n; inverts* n.
      rewrite fillb_cast.
      apply bstep_b.
      apply blame_stepb; eauto.
      apply bStep_vanyp; eauto.
      rewrite <- H10 in H6.  inverts* H6.
      rewrite <- H10 in H6.  inverts* H6.
      unfold not; intros n; inverts n.
      forwards*: value_valueb H0.
      eapply bstep_nb.
      apply bStep_dyna; eauto.
      apply valueb_dyn; eauto.
      forwards*: value_valueb H8.
      rewrite <- H10 in H6.  inverts* H6.
      unfold not; intros n; inverts n.
      unfold not; intros n; inverts* n.
      rewrite fillb_cast.
      apply bstep_b.
      apply blame_stepb; eauto.
      apply bStep_vanyp; eauto.
      rewrite <- H10 in H6.  inverts* H6.
      rewrite <- H10 in H6.  inverts* H6.
      unfold not; intros n; inverts n.
      forwards*: value_valueb H0.
    + rewrite <- H10 in H.
      exfalso. apply H.
      eauto.
  -
      exfalso; apply H;
      eauto.
Qed.

Lemma Soundness_blame_two: forall e t dir A,
  ttyping nil e dir A t->
  step e e_blame ->
  t ->* t_blame.
Proof.
  introv Typ J. gen A dir t.
  inductions J; intros.
  - destruct E; unfold fill in *.
    + inverts Typ.
      * forwards*: IHJ H3.
      apply multi_blame_app2; eauto.
      inverts H.
      forwards*: lc_lcb H2.
      * inverts H0.
       forwards*: IHJ H6.
       apply multi_blame_cast; eauto.
      apply multi_blame_app2; eauto.
      inverts H.
      forwards*: lc_lcb H4.
      forwards*: IHJ H6.
      apply multi_blame_cast; eauto.
      apply multi_blame_app2; eauto.
      inverts H.
      forwards*: lc_lcb H4.
      apply multi_blame_cast; eauto.
      *
      inverts H.
      forwards*: lc_lcb H1.
      forwards*: IHJ H3.
      apply multi_blame_app2; eauto.
      apply multi_blame_cast; eauto.
    + inverts Typ.
      *
      forwards*: IHJ H7.
      apply multi_blame_app; eauto.
      inverts H.
      forwards*: value_valueb H3.
      * inverts H0.
      forwards*: IHJ H7.
      apply multi_blame_cast; eauto.
      apply multi_blame_app; eauto.
      inverts H.
      forwards*: value_valueb H5.
      inverts H.
      forwards* h1: principle_if H6.
      rewrite h1 in H3.
      inverts H3.
      *
      inverts H.
      forwards* h1: principle_if H3.
      rewrite h1 in H1.
      inverts H1.
    + inverts Typ.
      forwards*: IHJ H6.
      inverts H0.
      forwards*: IHJ H5.
      apply multi_blame_cast; eauto.
  - inverts Typ.
    + inverts H5.
      assert (ttyping nil (e_anno v2 A1) Inf A1 t2); eauto.
      forwards*: Tred_blame_soundness H0.
      apply multi_blame_app; eauto.
      inverts H.
      inverts H10.
      forwards*: value_lc H6.
      forwards*: lc_lcb H.
      inverts H4.
      forwards*: value_valueb H.
      forwards*: principle_if H.
      rewrite H4 in H8.
      inverts H8.
    + inverts H2. inverts H8.
      assert (ttyping nil (e_anno v2 A2) Inf A2 t2); eauto.
      forwards*: Tred_blame_soundness H0.
      apply multi_blame_cast; eauto.
      apply multi_blame_app; eauto.
      inverts H.
      inverts H12.
      forwards*: value_lc H8.
      forwards*: lc_lcb H.
      inverts H6.
      forwards*: value_valueb H.
      forwards*: principle_if H.
      rewrite H6 in H11.
      inverts H11.
      inverts H8.
    +
      inverts H5.
  - inverts Typ.
    *
    assert (ttyping nil (e_anno v A0) Inf A0 t).
    eauto.
    forwards*: Tred_blame_soundness H0.
    * inverts H2.
    assert (ttyping nil (e_anno v A1) Inf A1 t0).
    eauto.
    forwards*: Tred_blame_soundness H0.
    apply multi_blame_cast; eauto.
  - inverts Typ. inverts H4. inverts H8.
    assert (ttyping nil (e_anno v1 t_int) Inf t_int (trm_cast t A t_int)).
    eauto.
    forwards*: Tred_blame_soundness H0.
    apply multi_blame_app; eauto.
    inverts H1. inverts H7.
    assert (ttyping nil (e_anno v1 t_int) Inf t_int t2).
    eauto.
    forwards*: Tred_blame_soundness H0.
    apply multi_blame_cast; eauto.
    apply multi_blame_app; eauto.
    inverts H7.
    +
      inverts H4.
  - inverts Typ.
    * inverts H4. inverts H8.
    assert (ttyping nil (e_anno v2 t_int) Inf t_int (trm_cast t A t_int)).
    eauto.
    forwards*: Tred_blame_soundness H0.
    apply multi_blame_app; eauto.
    * inverts H1.
    inverts H7.
    assert (ttyping nil (e_anno v2 t_int) Inf t_int t2).
    eauto.
    forwards*: Tred_blame_soundness H0.
    apply multi_blame_cast; eauto.
    apply multi_blame_app; eauto.
    inverts H7.
    *
    inverts H4.
Qed.


(* 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                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Cfield_facts.
Section Def.
Variable R : CFIELD.

Record Ctype : Type :=  {real :> R; imag : R}.

Definition Cadd (z z' : Ctype) : Ctype :=
  Build_Ctype (sgroup_law R (real z) (real z'))
    (sgroup_law R (imag z) (imag z')).

Definition Cmult (z z' : Ctype) : Ctype :=
  Build_Ctype
    (sgroup_law R (ring_mult (real z) (real z'))
       (group_inverse R (ring_mult (imag z) (imag z'))))
    (sgroup_law R (ring_mult (real z) (imag z'))
       (ring_mult (imag z) (real z'))).

Definition Copp (z : Ctype) : Ctype :=
  Build_Ctype (group_inverse R (real z)) (group_inverse R (imag z)).

Definition Cone : Ctype := Build_Ctype (ring_unit R) (monoid_unit R).

Definition Czero : Ctype := Build_Ctype (monoid_unit R) (monoid_unit R).

Definition Ceq (z z' : Ctype) :=
  Equal (real z) (real z') /\ Equal (imag z) (imag z').

Definition Cset : Setoid.
apply (Build_Setoid (Carrier:=Ctype) (Equal:=Ceq)).
red in |- *.
split; [ red in |- * | red in |- * ].
intros x; red in |- *; red in |- *; auto with algebra.
split; [ red in |- * | red in |- * ].
unfold app_rel, Ceq in |- *.
intros x y z H' H'0; split; [ try assumption | idtac ].
apply Trans with (real y); intuition.
apply Trans with (imag y); intuition.
unfold app_rel, Ceq in |- *.
intuition.
Defined.
Require Export Ring_util.

Lemma Build_Ctype_comp :
 forall x x' y y' : R,
 Equal x x' ->
 Equal y y' -> Equal (s:=Cset) (Build_Ctype x y) (Build_Ctype x' y').
intros x x' y y' H' H'0; try assumption.
simpl in |- *.
red in |- *; auto with algebra.
Qed.
Hint Resolve Build_Ctype_comp: algebra.

Lemma real_comp : forall x x' : Cset, Equal x x' -> Equal (real x) (real x').
simpl in |- *.
unfold Ceq in |- *.
intros x x' H'; elim H'; intros H'0 H'1; try exact H'0; clear H'.
Qed.
Hint Resolve real_comp: algebra.

Lemma imag_comp : forall x x' : Cset, Equal x x' -> Equal (imag x) (imag x').
simpl in |- *.
unfold Ceq in |- *.
intros x x' H'; elim H'; intros H'0 H'1; try exact H'1; clear H'.
Qed.
Hint Resolve imag_comp: algebra.

Lemma Build_Ctype_comp2 :
 forall x x' y y' : R,
 Equal x x' -> Equal y y' -> Ceq (Build_Ctype x y) (Build_Ctype x' y').
intros x x' y y' H' H'0; try assumption.
simpl in |- *.
red in |- *; auto with algebra.
Qed.
Hint Resolve Build_Ctype_comp2: algebra.

Definition Cring : RING.
apply
 (BUILD_RING (E:=Cset) (ringplus:=Cadd) (ringmult:=Cmult) (zero:=Czero)
    (un:=Cone) (ringopp:=Copp)).
unfold Cadd in |- *.
auto with algebra.
unfold Cadd in |- *.
simpl in |- *.
auto with algebra.
unfold Cadd, Czero in |- *.
simpl in |- *.
intros x; red in |- *.
simpl in |- *.
auto with algebra.
unfold Copp in |- *.
auto with algebra.
unfold Cadd, Czero, Copp in |- *.
simpl in |- *.
auto with algebra.
unfold Cadd in |- *.
auto with algebra.
unfold Cmult in |- *.
intros x x' y y' H' H'0; try assumption.
apply Build_Ctype_comp.
auto with algebra.
auto with algebra.
unfold Cmult in |- *.
simpl in |- *.
intros x y z; try assumption.
apply Build_Ctype_comp2.
apply
 Trans
  with
    (sgroup_law R
       (sgroup_law R (ring_mult (ring_mult x y) z)
          (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) z))
       (group_inverse R
          (sgroup_law R (ring_mult (ring_mult x (imag y)) (imag z))
             (ring_mult (ring_mult (imag x) y) (imag z))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (sgroup_law R (ring_mult x (ring_mult y z))
          (ring_mult x (group_inverse R (ring_mult (imag y) (imag z)))))
       (group_inverse R
          (sgroup_law R (ring_mult (imag x) (ring_mult y (imag z)))
             (ring_mult (imag x) (ring_mult (imag y) z))))).
apply
 Trans
  with
    (sgroup_law R (ring_mult (ring_mult x y) z)
       (sgroup_law R
          (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) z)
          (group_inverse R
             (sgroup_law R (ring_mult (ring_mult x (imag y)) (imag z))
                (ring_mult (ring_mult (imag x) y) (imag z)))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x (ring_mult y z))
       (sgroup_law R
          (ring_mult x (group_inverse R (ring_mult (imag y) (imag z))))
          (group_inverse R
             (sgroup_law R (ring_mult (imag x) (ring_mult y (imag z)))
                (ring_mult (imag x) (ring_mult (imag y) z)))))).
apply SGROUP_comp.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) z)
       (sgroup_law R
          (group_inverse R (ring_mult (ring_mult (imag x) y) (imag z)))
          (group_inverse R (ring_mult (ring_mult x (imag y)) (imag z))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (ring_mult x (group_inverse R (ring_mult (imag y) (imag z))))
       (sgroup_law R
          (group_inverse R (ring_mult (imag x) (ring_mult (imag y) z)))
          (group_inverse R (ring_mult (imag x) (ring_mult y (imag z)))))).
apply
 Trans
  with
    (sgroup_law R
       (group_inverse R (ring_mult (ring_mult x (imag y)) (imag z)))
       (sgroup_law R
          (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) z)
          (group_inverse R (ring_mult (ring_mult (imag x) y) (imag z))))).
apply
 Trans
  with
    (sgroup_law R
       (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) z)
       (sgroup_law R
          (group_inverse R (ring_mult (ring_mult x (imag y)) (imag z)))
          (group_inverse R (ring_mult (ring_mult (imag x) y) (imag z))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (group_inverse R (ring_mult (ring_mult x (imag y)) (imag z)))
       (sgroup_law R
          (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) z)
          (group_inverse R (ring_mult (ring_mult (imag x) y) (imag z))))).
auto with algebra.
auto with algebra.
apply SGROUP_comp.
apply
 Trans with (ring_mult (group_inverse R (ring_mult x (imag y))) (imag z)).
auto with algebra.
apply
 Trans with (ring_mult (ring_mult x (group_inverse R (imag y))) (imag z)).
auto with algebra.
apply
 Trans with (ring_mult x (ring_mult (group_inverse R (imag y)) (imag z))).
auto with algebra.
auto with algebra.
apply SGROUP_comp.
apply
 Trans with (group_inverse R (ring_mult (ring_mult (imag x) (imag y)) z)).
auto with algebra.
auto with algebra.
auto with algebra.
auto with algebra.
auto with algebra.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (sgroup_law R (ring_mult (ring_mult x y) (imag z))
          (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) (imag z)))
       (sgroup_law R (ring_mult (ring_mult x (imag y)) z)
          (ring_mult (ring_mult (imag x) y) z))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (sgroup_law R (ring_mult x (ring_mult y (imag z)))
          (ring_mult x (ring_mult (imag y) z)))
       (sgroup_law R (ring_mult (imag x) (ring_mult y z))
          (ring_mult (imag x) (group_inverse R (ring_mult (imag y) (imag z)))))).
apply
 Trans
  with
    (sgroup_law R (ring_mult (ring_mult x y) (imag z))
       (sgroup_law R
          (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) (imag z))
          (sgroup_law R (ring_mult (ring_mult x (imag y)) z)
             (ring_mult (ring_mult (imag x) y) z)))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x (ring_mult y (imag z)))
       (sgroup_law R (ring_mult x (ring_mult (imag y) z))
          (sgroup_law R (ring_mult (imag x) (ring_mult y z))
             (ring_mult (imag x)
                (group_inverse R (ring_mult (imag y) (imag z))))))).
apply SGROUP_comp.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult (ring_mult x (imag y)) z)
       (sgroup_law R
          (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) (imag z))
          (ring_mult (ring_mult (imag x) y) z))).
auto with algebra.
apply SGROUP_comp.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult (ring_mult (imag x) y) z)
       (ring_mult (group_inverse R (ring_mult (imag x) (imag y))) (imag z))).
auto with algebra.
apply SGROUP_comp.
auto with algebra.
apply
 Trans
  with (group_inverse R (ring_mult (ring_mult (imag x) (imag y)) (imag z))).
auto with algebra.
apply
 Trans
  with (group_inverse R (ring_mult (imag x) (ring_mult (imag y) (imag z)))).
auto with algebra.
auto with algebra.
auto with algebra.
auto with algebra.
unfold Cmult, Cone in |- *.
simpl in |- *.
intros x; try assumption.
elim x.
simpl in |- *.
unfold Ceq in |- *.
simpl in |- *.
intros real0 imag0; split; [ try assumption | idtac ].
apply Trans with (sgroup_law R real0 (group_inverse R (monoid_unit R)));
 auto with algebra.
apply Trans with (sgroup_law R real0 (monoid_unit R)); auto with algebra.
apply Trans with (sgroup_law R (monoid_unit R) imag0); auto with algebra.
unfold Cmult, Cone in |- *.
simpl in |- *.
intros x; try assumption.
elim x.
simpl in |- *.
unfold Ceq in |- *.
simpl in |- *.
intros real0 imag0; split; [ try assumption | idtac ].
apply Trans with (sgroup_law R real0 (group_inverse R (monoid_unit R)));
 auto with algebra.
apply Trans with (sgroup_law R real0 (monoid_unit R)); auto with algebra.
apply Trans with (sgroup_law R imag0 (monoid_unit R)); auto with algebra.
unfold Cmult, Cadd in |- *.
simpl in |- *.
unfold Ceq in |- *.
simpl in |- *.
intros x y z; split; [ try assumption | idtac ].
apply
 Trans
  with
    (sgroup_law R (sgroup_law R (ring_mult x y) (ring_mult x z))
       (group_inverse R (ring_mult (imag x) (sgroup_law R (imag y) (imag z))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x y)
       (sgroup_law R (ring_mult x z)
          (group_inverse R
             (ring_mult (imag x) (sgroup_law R (imag y) (imag z)))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x y)
       (sgroup_law R (group_inverse R (ring_mult (imag x) (imag y)))
          (sgroup_law R (ring_mult x z)
             (group_inverse R (ring_mult (imag x) (imag z)))))).
apply SGROUP_comp.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x z)
       (ring_mult (group_inverse R (imag x)) (sgroup_law R (imag y) (imag z)))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x z)
       (sgroup_law R (ring_mult (group_inverse R (imag x)) (imag y))
          (ring_mult (group_inverse R (imag x)) (imag z)))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult (group_inverse R (imag x)) (imag y))
       (sgroup_law R (ring_mult x z)
          (ring_mult (group_inverse R (imag x)) (imag z)))).
auto with algebra.
auto with algebra.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (sgroup_law R (ring_mult x (imag y)) (ring_mult x (imag z)))
       (sgroup_law R (ring_mult (imag x) y) (ring_mult (imag x) z))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x (imag y))
       (sgroup_law R (ring_mult x (imag z))
          (sgroup_law R (ring_mult (imag x) y) (ring_mult (imag x) z)))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x (imag y))
       (sgroup_law R (ring_mult (imag x) y)
          (sgroup_law R (ring_mult x (imag z)) (ring_mult (imag x) z)))).
apply SGROUP_comp.
auto with algebra.
auto with algebra.
auto with algebra.
unfold Cmult, Cadd in |- *.
simpl in |- *.
unfold Ceq in |- *.
simpl in |- *.
intros x y z; split; [ try assumption | idtac ].
apply
 Trans
  with
    (sgroup_law R (sgroup_law R (ring_mult x z) (ring_mult y z))
       (group_inverse R
          (sgroup_law R (ring_mult (imag x) (imag z))
             (ring_mult (imag y) (imag z))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x z)
       (sgroup_law R (ring_mult y z)
          (group_inverse R
             (sgroup_law R (ring_mult (imag x) (imag z))
                (ring_mult (imag y) (imag z)))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x z)
       (sgroup_law R (group_inverse R (ring_mult (imag x) (imag z)))
          (sgroup_law R (ring_mult y z)
             (group_inverse R (ring_mult (imag y) (imag z)))))).
apply SGROUP_comp.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult y z)
       (sgroup_law R (group_inverse R (ring_mult (imag y) (imag z)))
          (group_inverse R (ring_mult (imag x) (imag z))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult y z)
       (sgroup_law R (group_inverse R (ring_mult (imag x) (imag z)))
          (group_inverse R (ring_mult (imag y) (imag z))))).
auto with algebra.
auto with algebra.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (sgroup_law R (ring_mult x (imag z)) (ring_mult y (imag z)))
       (sgroup_law R (ring_mult (imag x) z) (ring_mult (imag y) z))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x (imag z))
       (sgroup_law R (ring_mult y (imag z))
          (sgroup_law R (ring_mult (imag x) z) (ring_mult (imag y) z)))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult x (imag z))
       (sgroup_law R (ring_mult (imag x) z)
          (sgroup_law R (ring_mult y (imag z)) (ring_mult (imag y) z)))).
apply SGROUP_comp.
auto with algebra.
auto with algebra.
auto with algebra.
Defined.

Definition Ccring : CRING.
apply (Build_cring (cring_ring:=Cring)).
apply (Build_cring_on (R:=Cring)).
red in |- *.
simpl in |- *.
unfold Cmult, Ceq in |- *; simpl in |- *.
intros x y; split; [ try assumption | idtac ].
auto with algebra.
apply Trans with (sgroup_law R (ring_mult (imag y) x) (ring_mult y (imag x)));
 auto with algebra.
apply SGROUP_comp; auto with algebra.
exact (CRING_com (R1:=R) x (imag y)).
exact (CRING_com (R1:=R) (imag x) y).
Defined.

Definition conjugate (z : Ctype) : Ctype :=
  Build_Ctype (real z) (group_inverse R (imag z)).

Definition CdivR (z : Ctype) (r : R) : Ctype :=
  Build_Ctype (field_div (real z) r) (field_div (imag z) r).

Definition Cinv (z : Ctype) : Ctype :=
  CdivR (conjugate z) (Cmult z (conjugate z)).

Definition Cinv_map : MAP Ccring Ccring.
apply (Build_Map (A:=Ccring) (B:=Ccring) (Ap:=Cinv)).
red in |- *.
unfold Cinv in |- *.
unfold CdivR in |- *.
unfold conjugate in |- *.
intros x y H'; try assumption.
simpl in |- *.
unfold Ceq in |- *; simpl in |- *.
simpl in H'.
red in H'.
elim H'; intros H'0 H'1; try exact H'0; clear H'.
split; [ try assumption | idtac ].
unfold field_div in |- *.
apply RING_comp.
auto with algebra.
apply FIELD_comp.
apply SGROUP_comp.
auto with algebra.
auto with algebra.
unfold field_div in |- *.
apply RING_comp.
auto with algebra.
apply FIELD_comp.
apply SGROUP_comp.
auto with algebra.
auto with algebra.
Defined.
Hypothesis
  sum_of_square :
    forall x y : R,
    Equal (sgroup_law R (ring_mult x x) (ring_mult y y)) (monoid_unit R) ->
    Equal x (monoid_unit R) /\ Equal y (monoid_unit R).

Lemma C_inv_r :
 forall x : Ccring,
 ~ Equal x (monoid_unit Ccring) ->
 Equal (ring_mult x (Ap Cinv_map x)) (ring_unit Ccring).
intros x; try assumption.
simpl in |- *.
unfold Ceq in |- *; simpl in |- *.
unfold field_div in |- *.
elim x.
intros r i; try assumption.
simpl in |- *.
intros H'; split; [ try assumption | idtac ].
apply
 Trans
  with
    (sgroup_law R
       (ring_mult (ring_mult r r)
          (field_inverse
             (sgroup_law R (ring_mult r r)
                (group_inverse R (ring_mult i (group_inverse R i))))))
       (group_inverse R
          (ring_mult (ring_mult i (group_inverse R i))
             (field_inverse
                (sgroup_law R (ring_mult r r)
                   (group_inverse R (ring_mult i (group_inverse R i)))))))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law (Build_field R)
       (ring_mult (ring_mult r r)
          (field_inverse
             (sgroup_law (Build_field R) (ring_mult r r)
                (group_inverse (Build_field R)
                   (ring_mult i (group_inverse (Build_field R) i))))))
       (ring_mult
          (group_inverse (Build_field R)
             (ring_mult i (group_inverse (Build_field R) i)))
          (field_inverse
             (sgroup_law (Build_field R) (ring_mult r r)
                (group_inverse (Build_field R)
                   (ring_mult i (group_inverse (Build_field R) i))))))).
auto with algebra.
apply
 Trans
  with
    (ring_mult
       (sgroup_law (Build_field R) (ring_mult r r)
          (group_inverse (Build_field R)
             (ring_mult i (group_inverse (Build_field R) i))))
       (field_inverse
          (sgroup_law (Build_field R) (ring_mult r r)
             (group_inverse (Build_field R)
                (ring_mult i (group_inverse (Build_field R) i)))))).
auto with algebra.
apply (FIELD_inverse_r (K:=R)).
red in |- *.
intros H'0; try assumption.
cut
 (Equal (sgroup_law (Build_field R) (ring_mult r r) (ring_mult i i))
    (monoid_unit (Build_field R))).
intros H'1; try assumption.
absurd (Equal r (monoid_unit R) /\ Equal i (monoid_unit R));
 auto with algebra.
apply
 Trans
  with
    (sgroup_law (Build_field R) (ring_mult r r)
       (group_inverse (Build_field R)
          (ring_mult i (group_inverse (Build_field R) i)))).
apply SGROUP_comp.
auto with algebra.
apply
 Trans
  with
    (group_inverse (Build_field R)
       (group_inverse (Build_field R) (ring_mult i i))).
auto with algebra.
auto with algebra.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (ring_mult (ring_mult r (group_inverse R i))
          (field_inverse
             (sgroup_law R (ring_mult r r)
                (group_inverse R (ring_mult i (group_inverse R i))))))
       (ring_mult (ring_mult i r)
          (field_inverse
             (sgroup_law R (ring_mult r r)
                (group_inverse R (ring_mult i (group_inverse R i))))))).
auto with algebra.
apply
 Trans
  with
    (ring_mult
       (sgroup_law (Build_field R)
          (ring_mult r (group_inverse (Build_field R) i))
          (ring_mult i r))
       (field_inverse
          (sgroup_law R (ring_mult r r)
             (group_inverse R (ring_mult i (group_inverse R i)))))).
auto with algebra.
apply
 Trans
  with
    (ring_mult (monoid_unit R)
       (field_inverse
          (sgroup_law R (ring_mult r r)
             (group_inverse R (ring_mult i (group_inverse R i)))))).
apply RING_comp.
apply
 Trans
  with
    (sgroup_law (Build_field R)
       (group_inverse (Build_field R) (ring_mult r i))
       (ring_mult i r)).
auto with algebra.
apply
 Trans
  with
    (sgroup_law (Build_field R)
       (group_inverse (Build_field R) (ring_mult i r))
       (ring_mult i r)).
auto with algebra.
auto with algebra.
auto with algebra.
auto with algebra.
Qed.

Definition C_field_on : field_on Ccring.
apply (Build_field_on (R:=Ccring) (field_inverse_map:=Cinv_map)).
exact C_inv_r.
intros x H'; try assumption.
apply Trans with (ring_mult x (Ap Cinv_map x)).
auto with algebra.
apply C_inv_r; auto with algebra.
simpl in |- *.
unfold Ceq in |- *.
simpl in |- *.
red in |- *.
intros H'; try assumption.
elim H'; intros H'0 H'1; try exact H'0; clear H'.
absurd (Equal (ring_unit R) (monoid_unit R)); auto with algebra.
Defined.

Definition CC : CFIELD := Build_cfield C_field_on.
End Def.