(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : extension for Coq.Reals.
  author    : ZhengPu Shi
  date      : 2021.05

  remark    :
  1. possible reason of "field" failure
    a. notation "/", need unfold Rdiv first.
    b. unknown variable name, need be rewrite first.
  2. why need this library?
    (1). lots of properties are lack in standard library.
    (2). more automation, especially inequality.
    (3). We want to solve any problem of equality or inequality in one step.
  3. why auto fail? and how to better naming a term?
    (1). use two lemmas like A -> B and B -> A instead of A <-> B
    (2). x * x and x² are mixed, and x² is defined as x * x, and Coq Standard
      Library prefer x², so we'd better choose x². But, notice that we should
      rewrie x² to x * x before using ring or field, it's a bit annoying.
    (3). 1 and R1 are mixed, and 1 is (IZR (Zpos xH)), and will be reduced to R1
      finally, and Coq Standard Library prefer 1, so we choose 1 as well.
    (4). x - y and x + (-y) is same, but we prefer x - y.
    (5). x / y and x * (-y), we prefer x / y as well.

  4. Coq's support for automatic proofs of equalities and inequalities.
     ref：https://coq.inria.fr/distrib/current/refman/addendum/micromega.html
(1). Micromega: a solver to solving arithmetic goals by ordered ring structure.
(2). Psatz: a solver to solvign arithmetic golas on Q,R,Z,nat, and N.
lia: linear, for integer (including Z,nat, and N)
nia: non-linear, for integer
lqa: linear, for rational number Q.
lra: linear, for real number R and rational number Q.
nra: non-linear, for real number and rational number.
psatz D n: non-linear
  here, D is Z/Q/R, n is an optional integer representing search depth.
(3). What's the ability of these solvers?
  It can solve the propositional formulas which its parameters are in the
  field D∈{Z,Q,R}. The formulas are belows:
        p ::= c | x | -p | p+p | p-p | p*p | p^n
        A ::= p=p | p>p | p<p | p<=p | p>=p
        F ::= A | P | True | False | F/\F | F\/F | F<->F | F->F | ~F | F=F
  Here,
    c is constant in D,
    x is variable in D,
    -,+,* is subtract,addition,multiplication seperately,
    p^n is power of nat n,
    F are interpreted as Prop or bool.
    (a) If F is interpreted as bool, the corresponding operaters are:
           &&,||,eqb,implb,negb.
        And if D is Z, then the relations are:
            Z.eqb,Z.gtb,Z.ltb,Z.geb,Z.leb
        And if D is Q, then the equal realtion is Qeq (==), not eq (=).
    (b) the range of constant c,
        for Z and Q, c is all possible value could be get;
        for R, c is the expression below:
            c ::= R0 | R1 | IZR z | Q2R q
                  | Rmult c c | Rplus c c | Rminus c c| Rdiv c c | Rinv c
 *)

Require Export BasicConfig.
Require Import HierarchySetoid.

Require Export ZExt.
Require Export Reals.
Open Scope R_scope.

Require Export Psatz.
Require Export Lra.

(* ######################################################################### *)
(** * Config the usage of Coq-Standard-Library Reals: Hints, Opaque, auto *)

(** Config hint db for autounfold *)
Global Hint Unfold
  Rminus        (* a - b = a + - b *)
  Rdiv          (* a / b = a * / b *)
  Rsqr          (* r² = r * r *)
  : R.

(** Config hint db for autorewrite, for rewriting of equations *)
#[export] Hint Rewrite
  (* Abs *)
  Rabs_R0             (* Rabs 0 = 0 *)
  Rabs_Ropp           (* Rabs (-x) = Rabs x *)
  Rabs_Rabsolu        (* Rabs (Rabs x) = Rabs x *)

  (* + *)
  Rplus_0_l           (* 0 + r = r *)
  Rplus_0_r           (* r + 0 = r *)

  (* -a *)
  Ropp_0              (* - 0 = 0 *)
  Rminus_0_r          (* r - 0 = r *)
  Ropp_involutive     (* - - r = r *)
  Rplus_opp_r         (* r + - r = 0 *)
  Rplus_opp_l         (* - r + r = 0 *)
  Rminus_eq_0         (* r - r = 0 *)

  (* x *)
  Rsqr_0              (* 0² = 0 *)
  Rsqr_1              (* 1² = 1 *)
  Rmult_0_l           (* 0 * r = 0 *)
  Rmult_0_r           (* r * 0 = 0 *)
  Rmult_1_l           (* 1 * r = r *)
  Rmult_1_r           (* r * 1 = r *)
(*   Ropp_mult_distr_r_reverse     (* r1 * - r2 = - (r1 * r2) *) *)
(*   Ropp_mult_distr_l_reverse     (* - r1 * r2 = - (r1 * r2) *) *)

  (* pow *)
  pow1                (* 1 ^ n = 1 *)
  pow_O               (* x ^ 0 = 1 *)
  pow_1               (* x ^ 1 = x *)

  (* Rpower *)
  Rpower_O            (* power x 0 = 1 *)
  Rpower_1            (* power x 1 = x *)

  (* sqr *)
  Rsqr_mult           (* (x * y)² = x² * y² *)

  (* sqrt *)
  sqrt_Rsqr_abs       (* (sqrt x²) = Rabs x *)
  (* Rsqr_sqrt           (* 0 <= x -> (sqrt x)² = x *) *)
  (* sqrt_Rsqr           (* 0 <= x -> sqrt x² = x *) *)
  sqrt_0              (* sqrt 0 = 0 *)
  : R.

(** Config hint db for auto，for solving equalities or inequalities *)
Global Hint Resolve
  (* equalities *)
  eq_sym              (* a = b -> b = a *)
  sqrt_0              (* sqrt 0 = 0 *)
  Rsqr_eq_0           (* x² = 0 -> x = 0 *)
(*   sqrt_sqrt           (* 0 <= x -> sqrt x * sqrt x = x *) *)
  Rsqr_sqrt           (* 0 <= x -> (sqrt x)² = x *)
  sqrt_Rsqr           (* 0 <= x -> sqrt x² = x *)
  sin2_cos2           (* (sin x)² + (cos x)² = 1 *)

  (* general inequalities *)
  Rlt_0_1             (* 0 < 1 *)
  PI_RGT_0            (* PI > 0 *)
  Rabs_pos            (* 0 <= Rabs x *)
  Rabs_no_R0          (* r <> 0 -> Rabs r <> 0 *)
  sqrt_pos            (* 0 <= sqrt x *)
  Rle_0_sqr           (* 0 <= r² *)
(*   Rsqr_inj            (* 0 <= x -> 0 <= y -> x² = y² -> x = y *) *)
  Rinv_0_lt_compat    (* 0 < r -> 0 < / r *)

  (* inequalities such as "0 <= r1 + r2" *)
  Rplus_le_le_0_compat  (* 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2 *)
  Rplus_lt_le_0_compat  (* 0 < r1 -> 0 <= r2 -> 0 < r1 + r2 *)
  Rplus_le_lt_0_compat  (* 0 <= r1 -> 0 < r2 -> 0 < r1 + r2 *)
  Rplus_lt_0_compat   (* 0 < r1 -> 0 < r2 -> 0 < r1 + r2 *)

  (* inequalities such as "0 <= r1 * r2" *)
  Rmult_lt_0_compat   (* 0 < r1 -> 0 < r2 -> 0 < r1 * r2 *)
  Rle_0_sqr           (* 0 <= x² *)
  Rsqr_pos_lt         (* x <> 0 -> 0 < x² *)

  (* inequalities such as "r1 <= r2" *)
  Rlt_gt              (* r1 < r2 -> r2 > r1 *)  (* THIS IS ALWAYS NEED! *)
  Rgt_lt              (* r1 > r2 -> r2 < r1 *)  (* THIS ONE, slow but useful *)
  Rge_le              (* r1 >= r2 -> r2 <= r1 *)
  Rle_ge              (* r1 <= r2 -> r2 >= r1 *)
  Rlt_le              (* r1 < r2 -> r1 <= r2 *)
  Rsqr_pos_lt         (* x <> 0 -> 0 < x² *)

  (* inequalities such as "r1 <> r2" *)
  Rgt_not_eq          (* r1 > r2 -> r1 <> r2 *)
  Rlt_not_eq          (* r1 < r2 -> r1 <> r2 *)

  (* inequalities containing "sqrt" *)
  sqrt_lt_R0          (* 0 < x -> 0 < sqrt x *)
  sqrt_inj            (* 0 <= x -> 0 <= y -> sqrt x = sqrt y -> x = y *)
  : R.

(** Control Opaque / Transparent of the definitions *)
Global Opaque
  PI
  sqrt
  Rpower
  sin
  cos
  tan
  asin
  atan
  acos
  ln
.

Section TEST_psatz.
  Goal forall x y, x ^ 2 + y * y >= x * y.
    intros.
    (* psatz R 1. (* require external tool CSDP *) *)
    nra.
  Qed.

End TEST_psatz.

(** arithmetric on reals : lra + nra *)
Ltac ra :=
  intros; unfold Rsqr in *; try lra; try nra; auto with R.

(* ######################################################################### *)
(** * Suplymentary properties about "real number R" *)

(* ======================================================================= *)
(** ** Rsqr, Rpow2, x*x *)

(** There are several ways to represent square:
    x * x，it is a notation for "Rmult x x"
    x ^ 2, it is a notation for "pow x 2"
    x²   , it is a notation for "Rsqr x", which defined as x * x.
    In Coq-std-lib, I should use which one to representing square? What's the
    famous way? After the search, I find that:
        x * x，9
        x ^ 2, 14
        x², 100
    So, we should mainly use x², and other ways should be converted to this way,
    and the lost lemmas should be given manually.

    Another question, the lra tactic is working well on "x * x" and "pow x 2",
    but not working on "x²".
    So, we use "try (unfold Rsqr in *; lra)" insead of "try lra".
    In addition, using the tactics ring and field also need to unfold Rsqr.

    In conclusion, there are two cases:
    1. when use "ring,field,lra", write: unfold Rsqr in *; ring.
    2. other cases, write: autorewrit with R; auto with R.
 *)

(** We always prefer x², an exception is when using ring or field tactic. *)
Lemma xx_Rsqr x : x * x = x².
Proof.
  auto.
Qed.
#[export] Hint Rewrite xx_Rsqr : R.

(** r ^ 2 = r² *)
Lemma Rpow2_Rsqr r : r ^ 2 = r².
Proof.
  ra.
Qed.
#[export] Hint Rewrite Rpow2_Rsqr : R.

(* ======================================================================= *)
(** ** R0 and 0 *)

(* (** We always prefer 0 *) *)
(* Lemma R0_eq_0 : R0 = 0. *)
(* Proof. *)
(*   auto. *)
(* Qed. *)
(* #[export] Hint Rewrite R0_eq_0 : R. *)

Lemma Rsqr_R0 : R0² = R0.
Proof.
  ra.
Qed.
#[export] Hint Rewrite Rsqr_R0 : R.
Global Hint Resolve Rsqr_R0 : R.

(* ======================================================================= *)
(** ** R1 and 1 *)

(* (** We always prefer 1 *) *)
(* Lemma R1_eq_1 : R1 = 1. *)
(* Proof. *)
(*   auto. *)
(* Qed. *)
(* #[export] Hint Rewrite R1_eq_1 : R. *)

Lemma Rsqr_1 : 1² = 1.
Proof.
  ra.
Qed.
#[export] Hint Rewrite Rsqr_1 : R.
Global Hint Resolve Rsqr_1 : R.

(** /1 = 1 *)
#[export] Hint Rewrite Rinv_1 : R.
Global Hint Resolve Rinv_1 : R.

Lemma zero_le_1 : 0 <= 1.
Proof.
  auto with R.
Qed.
Global Hint Resolve zero_le_1 : R.

Lemma zero_neq_1 : 0 <> 1.
Proof.
  auto with R.
Qed.
Global Hint Resolve zero_neq_1 : R.

Module TEST_R1_and_1.
  Goal 1 = R1. auto with R. Qed.
  Goal R1² = 1. auto with R. Qed.
  Goal 1² = R1. auto with R. Qed.
  Goal /R1 = R1. auto with R. Qed.
  Goal /R1 = 1. auto with R. Qed.
  Goal /1 = R1. auto with R. Qed.
  Goal 0 <= R1. auto with R. Qed.
End TEST_R1_and_1.

(* ======================================================================= *)
(** ** About "-a" and "a-b" *)

Lemma Rsub_opp r1 r2 : r1 - (- r2) = r1 + r2.
Proof.
  ring.
Qed.
#[export] Hint Rewrite Rsub_opp : R.           (* r1 - (- r2) = r1 + r2 *)

(* ======================================================================= *)
(** ** About "square" *)

Lemma Rle_0_xx : forall r, 0 <= r * r.
Proof.
  ra.
Qed.

(** The sum of squares of two real numbers is non-negative *)
Lemma Rplus_sqr_ge0 : forall r1 r2 : R, 0 <= r1² + r2².
Proof.
  ra.
Qed.

(** The sum of squares of two real numbers is non-negative *)
Lemma Rplus_sqr_ge0_form2 : forall r1 r2 : R, 0 <= r1 * r1 + r2 * r2.
Proof.
  ra.
Qed.

(** The sum of squares of two real numbers is positive, iff they are not both 0 *)
Lemma Rplus_sqr_gt0 : forall r1 r2 : R, 0 < r1² + r2² <-> (r1 <> 0 \/ r2 <> 0).
Proof.
  ra.
Qed.

Lemma Rplus_sqr_gt0_l : forall r1 r2, r1 <> 0 -> 0 < r1² + r2².
Proof. ra. Qed.

Lemma Rplus_sqr_gt0_r : forall r1 r2, r2 <> 0 -> 0 < r1² + r2².
Proof. ra. Qed.

(** If the sum of squares of two real numbers is zero, then the second number is 0 *)
Lemma Rplus_sqr_eq_0_r : forall r1 r2, r1² + r2² = 0 -> r2 = 0.
Proof.
  ra.
Qed.

(** Real number inequality: 2 * a * b <= a² + b² *)
Lemma R_neq1 : forall r1 r2 : R, 2 * r1 * r2 <= r1² + r2².
Proof.
  intros. apply Rge_le. apply Rminus_ge.
  (* (a-b)² = a² + b² - 2ab *)
  rewrite <- Rsqr_minus. auto with R.
Qed.

(** r1² + r2² = 0 <-> r1 = 0 /\ r2 = 0 *)
Lemma Rplus_sqr_eq0_iff : forall r1 r2, r1² + r2² = 0 <-> r1 = 0 /\ r2 = 0.
Proof.
  ra.
Qed.

(** r1² + r2² = 0 <-> r1 = 0 /\ r2 = 0 *)
Lemma Rplus_sqr_eq0_iff_form2 : forall r1 r2, r1 * r1 + r2 * r2 = 0 <-> r1 = 0 /\ r2 = 0.
Proof.
  ra.
Qed.

(** r1 <> 0 \/ r2 <> 0 <-> r1² + r2² <> 0 *)
Lemma Rplus_sqr_neq0_iff2 : forall r1 r2, r1 <> 0 \/ r2 <> 0 <-> r1² + r2² <> 0.
Proof. ra. Qed.

(** r1*r1 + r2*r2 <> 0 -> 0 < r1*r1 + r2*r2 *)
Lemma Rplus_sqr_sqr_neq0_iff_Rplus_sqr_sqr_gt0 : forall r1 r2 : R,
  r1² + r2² <> 0 <-> 0 < r1² + r2².
Proof. ra. Qed.

(** r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 <-> r1² + r2² + r3² <> 0 *)
Lemma Rplus_sqr_neq0_iff3 : forall r1 r2 r3 : R,
  r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 <-> r1² + r2² + r3² <> 0.
Proof. ra. Qed.

(** r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 \/ r4 <> 0 <->
    r1² + r2² + r3² + r4² <> 0 *)
Lemma Rplus_sqr_neq0_iff4 : forall r1 r2 r3 r4 : R,
  r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 \/ r4 <> 0 <-> r1² + r2² + r3² + r4² <> 0.
Proof. ra. Qed.

Global Hint Resolve
  Rle_0_xx             (* 0 <= x * x *)
  Rplus_sqr_ge0        (* 0 <= r1² + r2² *)
  Rplus_sqr_ge0_form2  (* 0 <= r1² + r2² *)
  Rplus_sqr_gt0        (* 0 < r1² + r2² *)
  Rplus_sqr_eq_0_l     (* r1² + r2² = 0 -> r1 = 0 *)
  Rplus_sqr_eq_0_r     (* r1² + r2² = 0 -> r2 = 0 *)
  Rplus_sqr_neq0_iff2  (* r1<>0 \/ r2<>0 <-> r1² + r2²<>0 *)
  Rplus_sqr_neq0_iff3  (* r1,r2,r3, ... *)
  Rplus_sqr_neq0_iff4  (* r1,r2,r3,r4, ... *)
  Rplus_sqr_sqr_neq0_iff_Rplus_sqr_sqr_gt0 (* r1² + r2²<>0 <-> 0 <r1² + r2² *)
  R_neq1               (* 2 * a * b <= a² + b² *)
  : R.

Section test.
  (** r * r = 0 <-> r = 0 *)
  Goal forall r, r * r = 0 <-> r = 0. ra. Qed.
  Goal forall r, r * r <> 0 <-> r <> 0. ra. Qed.
  Goal forall r1 r2 : R, 0 <= r1 * r1 + r2 * r2. ra. Qed.
  Goal forall r1 r2 : R,  r1 <> 0 \/ r2 <> 0 <-> r1 * r1 + r2 * r2 <> 0. ra. Qed.
  Goal forall r1 r2 : R,  r1 * r1 + r2 * r2 <> 0 <-> 0 < r1 * r1 + r2 * r2. ra. Qed.
  Goal forall r1 r2 r3 : R,
      r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 <-> r1 * r1 + r2 * r2 + r3 * r3 <> 0. ra. Qed.
  Goal forall r1 r2 r3 r4 : R,
      r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 \/ r4 <> 0 <->
        r1 * r1 + r2 * r2 + r3 * r3 + r4 * r4 <> 0. ra. Qed.
End test.

(* ======================================================================= *)
(** ** About "absolute value" *)

Lemma Rabs_neg_left : forall r, 0 <= r -> Rabs (-r) = r.
Proof.
  intros. rewrite Rabs_Ropp. apply Rabs_right; nra.
Qed.

Lemma Rabs_neg_right : forall r, r < 0 -> Rabs (-r) = -r.
Proof.
  intros. rewrite Rabs_Ropp. apply Rabs_left; nra.
Qed.

Global Hint Resolve
  Rabs_right     (* r >= 0 -> Rabs r = r *)
  Rabs_pos_eq    (* 0 <= r -> Rabs r = r *)
  Rabs_left      (* r < 0 -> Rabs r = - r *)
  Rabs_left1     (* r <= 0 -> Rabs r = - r *)
  Rabs_neg_left  (* 0 <= r -> Rabs (-r) = r *)
  Rabs_neg_right (* r < 0 -> Rabs (-r) = -r *)
  : R.

(* ======================================================================= *)
(** ** About "sqrt" *)

Lemma sqrt_square_abs : forall r, sqrt (r * r) = Rabs r.
Proof.
  intros. destruct (Rcase_abs r).
  - replace (r * r) with ((-r) * (-r)) by nra.
    rewrite sqrt_square; try nra. auto with R.
  - rewrite sqrt_square; auto with R.
Qed.

Lemma sqrt_1 : sqrt 1 = 1.
Proof.
  apply Rsqr_inj; autorewrite with R; auto with R.
Qed.

Lemma sqrt_le0_eq_0 : forall r, r <= 0 -> sqrt r = 0.
Proof.
  intros. Transparent sqrt. unfold sqrt. destruct (Rcase_abs r); auto.
  assert (r = 0); try lra. subst. compute.
  destruct (Rsqrt_exists). destruct a.
  symmetry in H1. auto with R.
Qed.

Lemma sqrt_lt0_eq_0 : forall r, r < 0 -> sqrt r = 0.
Proof.
  intros. apply sqrt_le0_eq_0. auto with R.
Qed.

Lemma le0_imply_sqrt_eq0 : forall (x : R), x < 0 -> sqrt x = 0.
Proof.
  intros. unfold sqrt. destruct (Rcase_abs x); auto.
  (* although, x < 0, x >= 0, all appear, lra fail to solve it. *)
  exfalso. lra.
Qed.

Lemma sqrt_gt0_imply_gt0 : forall (x : R), 0 < sqrt x -> 0 < x.
Proof.
  intros. replace 0 with (sqrt 0) in H; auto with R.
  apply sqrt_lt_0_alt in H; auto.
Qed.

Lemma sqrt_gt0_imply_ge0 : forall (x : R), 0 < sqrt x -> 0 <= x.
Proof.
  intros. apply Rlt_le. apply sqrt_gt0_imply_gt0; auto.
Qed.

Lemma sqrt_eq1_imply_eq1 : forall (x : R), sqrt x = 1 -> x = 1.
Proof.
  intros.
  assert ((sqrt x)² = 1). rewrite H. autounfold with R in *; ring.
  rewrite <- H0.
  apply eq_sym. apply Rsqr_sqrt.
  assert (0 < sqrt x). rewrite H; auto with R.
  apply sqrt_gt0_imply_gt0 in H1. auto with R.
Qed.

Lemma sqrt_eq1_imply_eq1_rev : forall (x : R), x = 1 -> sqrt x = 1.
Proof.
  intros. rewrite H. rewrite sqrt_1. auto.
Qed.

(** ( √ r1 * √ r2)^2 = r1 * r2 *)
Lemma Rsqr_sqrt_sqrt r1 r2 : 0 <= r1 -> 0 <= r2 ->
  ((sqrt r1) * (sqrt r2))² = r1 * r2.
Proof.
  destruct (Rcase_abs r1), (Rcase_abs r2); try lra.
  autorewrite with R; auto with R.
  rewrite ?Rsqr_sqrt; auto with R.
Qed.

(** If the sqrt of the sum of squares of two real numbers equal to 0, iff both of
    them are 0. *)
Lemma Rsqrt_plus_sqr_eq0_iff : forall r1 r2 : R,
  sqrt (r1² + r2²) = 0 <-> r1 = 0 /\ r2 = 0.
Proof.
  intros. autorewrite with R. split; intros H.
  - apply sqrt_eq_0 in H.
    + split; eauto with R.
    + apply Rplus_sqr_ge0.
  - destruct H; subst. autorewrite with R; auto with R.
Qed.

(** The multiplication of the square roots of two real numbers is >= 0 *)
Lemma Rmult_sqrt_sqrt_ge0 : forall r1 r2 : R, 0 <= (sqrt r1) * (sqrt r2).
Proof.
  intros. apply Rmult_le_pos; auto with R.
Qed.

(** The addition of the square roots of two real numbers is >= 0 *)
Lemma Rplus_sqrt_sqrt_ge0 : forall r1 r2 : R, 0 <= (sqrt r1) + (sqrt r2).
Proof.
  intros. apply Rplus_le_le_0_compat; auto with R.
Qed.

Lemma Rsqr_plus_sqr_neq0_l : forall r1 r2, r1 <> 0 -> sqrt (r1² + r2²) <> 0.
Proof.
  intros. auto 6 with R.
Qed.

Lemma Rsqr_plus_sqr_neq0_r : forall r1 r2, r2 <> 0 -> sqrt (r1² + r2²) <> 0.
Proof.
  intros. auto 6 with R.
Qed.

(** /(sqrt (1+(b/a)²)) = abs(a) / sqrt(a*a + b*b) *)
Lemma Rinv_sqrt_plus_1_sqr_div_a_b (a b : R) : a <> 0 ->
  (/ (sqrt (1+(b/a)²)) = (Rabs a) / sqrt(a*a + b*b)).
Proof.
  intros.
  replace (1 + (b/a)²) with ((a*a + b*b) / ((Rabs a)*(Rabs a))).
  - rewrite sqrt_div_alt.
    + rewrite sqrt_square.
      * field. split; autorewrite with R; auto 6 with R.
      * auto with R.
    + autorewrite with R; auto with R.
  - unfold Rsqr.
    destruct (Rcase_abs a).
    + replace (Rabs a) with (-a). field; auto. rewrite Rabs_left; auto.
    + replace (Rabs a) with a. field; auto. rewrite Rabs_right; auto.
Qed.

(** (√ r1 * √ r2) * (√ r1 * √ r2) = r1 * r2 *)
Lemma sqrt_mult_sqrt : forall (r1 r2 : R),
  0 <= r1 -> 0 <= r2 ->
  ((sqrt r1) * (sqrt r2)) * ((sqrt r1) * (sqrt r2)) = r1 * r2.
Proof.
  intros. ring_simplify. repeat rewrite pow2_sqrt; auto.
Qed.

#[export] Hint Rewrite
  sqrt_square_abs         (* sqrt (r * r) = Rabs r *)
  (* Rsqr_sqrt               (* 0 <= x -> (sqrt x)² = x *) *)
  sqrt_1                  (* sqrt 1 = 1 *)
  Rsqr_sqrt_sqrt          (* ( √ r1 * √ r2)² = r1 * r2 *)
  sqrt_mult_sqrt          (* (√ r1 * √ r2) * (√ r1 * √ r2) = r1 * r2 *)
  : R.

Global Hint Resolve
  sqrt_1                  (* sqrt 1 = 1 *)
  sqrt_le0_eq_0           (* r <= 0 -> sqrt r = 0 *)
  sqrt_lt0_eq_0           (* r < 0 -> sqrt r = 0 *)
  le0_imply_sqrt_eq0      (* x < 0 -> sqrt x = 0 *)
  sqrt_gt0_imply_gt0      (* 0 < sqrt x -> 0 < x *)
  sqrt_gt0_imply_ge0      (* 0 < sqrt x -> 0 <= x *)
  sqrt_eq1_imply_eq1      (* sqrt x = 1 -> x = 1 *)
  Rsqr_sqrt_sqrt          (* ( √ r1 * √ r2)² = r1 * r2 *)
  sqrt_mult_sqrt          (* (√ r1 * √ r2) * (√ r1 * √ r2) = r1 * r2 *)
  Rmult_sqrt_sqrt_ge0     (* 0 <= (sqrt r1) * (sqrt r2) *)
  Rplus_sqrt_sqrt_ge0     (* 0 <= (sqrt r1) + (sqrt r2) *)
  sqrt_square             (* 0 <= x -> sqrt (x * x) = x *)
  Rsqr_plus_sqr_neq0_l    (* r1 <> 0 -> sqrt (r1² + r2²) <> 0 *)
  Rsqr_plus_sqr_neq0_r    (* r2 <> 0 -> sqrt (r1² + r2²) <> 0 *)
  : R.

(** simplify expression has sqrt and pow2 *)
Ltac simpl_sqrt_pow2 :=
  repeat (
  (* (_²) -> x * x *)
  unfold Rsqr;
  (* (sqrt r1 * sqrt r2)^2 = r1 * r2 *)
  try rewrite sqrt_mult_sqrt;
  (* (sqrt x) ^ 2 = x *)
  try rewrite pow2_sqrt;
  (* sqrt (x ^ 2) = x *)
  try rewrite sqrt_pow2;
  (* (sqrt x * sqrt x) = x *)
  try rewrite sqrt_sqrt
  ).

Section TEST_Rsqrt.
  Goal sqrt R1 = R1. autorewrite with R; auto with R. Qed.

End TEST_Rsqrt.

(** Automatically prove the goal such as "sqrt x = y" *)
Ltac solve_sqrt_eq :=
  match goal with
  | |- sqrt ?x = ?y => apply Rsqr_inj; [ra|ra|rewrite Rsqr_sqrt;ra]
  end.

(* ======================================================================= *)
(** ** About "trigonometric functions" *)

(*  sin (- (PI/2)) = -1 *)
Lemma sin_PI2_neg : sin (- (PI/2)) = -1.
Proof.
  rewrite sin_neg. rewrite sin_PI2. auto.
Qed.

(* cos (- (PI/2)) = 0 *)
Lemma cos_PI2_neg : cos (- (PI/2)) = 0.
Proof.
  rewrite cos_neg. apply cos_PI2.
Qed.

(* sin (r + PI) = - (sin r) *)
Lemma sin_plus_PI : forall r, sin (r + PI) = (- (sin r))%R.
Proof.
  apply neg_sin.
Qed.

(* sin (r - PI) = - (sin r) *)
Lemma sin_sub_PI : forall r, sin (r - PI) = (- (sin r))%R.
Proof.
  intros. replace (r - PI)%R with (- (PI - r))%R; try ring.
  rewrite sin_neg. rewrite Rtrigo_facts.sin_pi_minus. auto.
Qed.

(* cos (r + PI) = - (cos r) *)
Lemma cos_plus_PI : forall r, cos (r + PI) = (- (cos r))%R.
Proof.
  apply neg_cos.
Qed.

(* cos (r - PI) = - (cos r) *)
Lemma cos_sub_PI : forall r, cos (r - PI) = (- (cos r))%R.
Proof.
  intros. replace (r - PI)%R with (- (PI - r))%R; try ring.
  rewrite cos_neg. apply Rtrigo_facts.cos_pi_minus.
Qed.

Lemma cos2_sin2: forall x : R, (cos x)² + (sin x)² = 1.
Proof.
  intros. rewrite Rplus_comm. apply sin2_cos2.
Qed.

#[export] Hint Rewrite
  sin_0         (* sin 0 = 0 *)
  cos_0         (* cos 0 = 1 *)
  sin_PI2       (* sin (PI / 2) = 1 *)
  cos_PI2       (* cos (PI / 2) = 0 *)
  sin_PI2_neg   (* sin (- (PI/2)) = -1 *)
  cos_PI2_neg   (* cos (- (PI/2)) = 0 *)
  sin_plus_PI   (* sin (r + PI) = - (sin r) *)
  sin_sub_PI    (* sin (r - PI) = - (sin r) *)
  cos_plus_PI   (* cos (r + PI) = - (cos r) *)
  cos_sub_PI    (* cos (r - PI) = - (cos r) *)
  sin2_cos2     (* (sin x)² + (cos x)² = 1 *)
  cos2_sin2     (* (cos x)² + (sin x)² = 1 *)
  : R.

#[export] Hint Resolve
  sin_0         (* sin 0 = 0 *)
  cos_0         (* cos 0 = 1 *)
  sin_PI2       (* sin (PI / 2) = 1 *)
  cos_PI2       (* cos (PI / 2) = 0 *)
  sin_PI2_neg   (* sin (- (PI/2)) = -1 *)
  cos_PI2_neg   (* cos (- (PI/2)) = 0 *)
  sin_plus_PI   (* sin (r + PI) = - (sin r) *)
  sin_sub_PI    (* sin (r - PI) = - (sin r) *)
  cos_plus_PI   (* cos (r + PI) = - (cos r) *)
  cos_sub_PI    (* cos (r - PI) = - (cos r) *)
  sin2_cos2     (* (sin x)² + (cos x)² = 1 *)
  cos2_sin2     (* (cos x)² + (sin x)² = 1 *)
  : R.

Section TEST_sin_cos_tan.
  Goal forall x, cos x * cos x + sin x * sin x = R1.
  intros; autorewrite with R; auto with R. Qed.

  Goal forall x, sin x * sin x + cos x * cos x = R1.
  intros; autorewrite with R; auto with R. Qed.

End TEST_sin_cos_tan.

(* ======================================================================= *)
(** ** About "Rpower" *)

(**
Rpower rules:
<<
  1. Definition of Rpower
  a^n       = a * a * ... * a    (* there are n numbers *)
  a^0       = 1 (a ≠ 0)
  a^(-n)    = 1 / a^n (a ≠ 0)
  a^(m/n)   = n√ a^m  (a > 0)
  a^(-m/n)  = 1 / n√ a^m  (a > 0)
>>
 *)
Lemma Rpower_neq0 x y : x <> 0 -> Rpower x y <> 0.
Proof.
  zify.

  Abort.

(* ######################################################################### *)
(** * Automatic solving equalites or inequalities on real numbers *)

(* ======================================================================= *)
(** ** r = 0 *)

Lemma Rmult_eq_self_imply_0_or_k1 : forall k x,
    k * x = x -> x = 0 \/ (x <> 0 /\ k = R1).
Proof. ra. Qed.

Section TEST_r_eq_0.
  Goal forall r r1 r2 : R, r * r1 = r * r2 -> r1 <> r2 -> r = 0. ra. Qed.
  Goal forall r r1 r2 : R, r1 * r = r2 * r -> r1 <> r2 -> r = 0. ra. Qed.
  Goal forall r, r = 0 -> r² = 0. ra. Qed.
End TEST_r_eq_0.

(* ======================================================================= *)
(** ** 0 <= x *)

(** deprecated *)
(* Ltac zero_le := *)
(*   intros; autorewrite with R; *)
(*   repeat (match goal with *)
(*   | |- 0 <= ?r1 * ?r2 => apply Rmult_le_pos *)
(*   | |- _ => idtac *)
(*   end; *)
(*   auto with R; try lra). *)

Section TEST_zero_le.
  Goal forall r, 0 <= r * r. ra. Qed.
  Goal forall r, 0 <= r². ra. Qed.
  Goal forall r1 r2, 0 <= r1 * r1 + r2 * r2. ra. Qed.
  Goal forall r1 r2, 0 <= r1² + r2². ra. Qed.
  Goal forall r1 r2, 0 <= r1 * r1 + r2². ra. Qed.
  Goal forall r1 r2, 0 <= r1² + r2 * r2. ra. Qed.
  Goal forall r, 0 <= r -> 0 <= r * 5. ra. Qed.
  Goal forall r, 0 <= r -> 0 <= r * 5 * 10. ra. Qed.
  Goal forall r, 0 <= r -> 0 <= r * (/5) * 10. ra. Qed.
End TEST_zero_le.

(* ======================================================================= *)
(** ** 0 < x *)

(** deprecated *)
(* Ltac zero_lt := *)
(*   intros; autorewrite with R; *)
(*   match goal with *)
(*   | H : ?r1 <> 0 |- 0 < ?r1² + ?r2² => apply Rneq0_imply_Rplus_gt0_2_1 *)
(*   | H : ?r2 <> 0 |- 0 < ?r1² + ?r2² => apply Rneq0_imply_Rplus_gt0_2_2 *)
(*   | H : 0 < ?r1  |- 0 < ?r1² + ?r2² => apply Rgt0_imply_Rplus_gt0_2_1 *)
(*   | H : 0 < ?r2  |- 0 < ?r1² + ?r2² => apply Rgt0_imply_Rplus_gt0_2_2 *)
(*   | H : 0 < ?r1  |- 0 < ?r1 * ?r2 => apply Rmult_lt_0_compat *)
(*   (* these methods are too ugly, but could work now *) *)
(*   | |- (0 < ?r1 + ?r2)%R => apply Rplus_lt_0_compat *)
(*   | |- (0 < ?r1 * ?r2)%R => apply Rmult_lt_0_compat *)
(*   | |- (0 < ?r1²)%R => apply Rlt_0_sqr *)
(*   | |- _ => idtac *)
(*   end; *)
(*   auto with R; try lra. *)

Section TEST_zero_lt.
  Goal forall r, 0 <> r -> 0 < r * r. ra. Qed.
  Goal forall r, 0 <> r -> 0 < r². ra. Qed.
  Goal forall r, 0 < r -> 0 < r * r. ra. Qed.
  Goal forall r, 0 < r -> 0 < r². ra. Qed.
  Goal forall r1 r2, r1 <> 0 -> 0 < r1 * r1 + r2 * r2. ra. Qed.
  Goal forall r1 r2, r1 <> 0 -> 0 < r1² + r2 * r2. ra. Qed.
  Goal forall r1 r2, r1 <> 0 -> 0 < r1 * r1 + r2². ra. Qed.

  Goal forall r1 r2, r2 <> 0 -> 0 < r1 * r1 + r2 * r2. ra. Qed.
  Goal forall r1 r2, r2 <> 0 -> 0 < r1² + r2 * r2. ra. Qed.
  Goal forall r1 r2, r2 <> 0 -> 0 < r1 * r1 + r2². ra. Qed.

  Goal forall r1 r2, 0 < r1 -> 0 < r1 * r1 + r2 * r2. ra. Qed.
  Goal forall r1 r2, 0 < r2 -> 0 < r1 * r1 + r2 * r2. ra. Qed.

  Goal forall r, 0 < r -> 0 < r * 10. ra. Qed.
  Goal forall r, 0 < r -> 0 < r + 10. ra. Qed.
  Goal forall r, 0 < r -> 0 < r * 100 + 23732. ra. Qed.

End TEST_zero_lt.

(** This property is used in in Complex. Although lra can solve it, but using a
    special lemma name combined with the match machanism could speed up the proof. *)
Lemma Rneq_le_lt : forall a b, a <> b -> a <= b -> a < b.
Proof. ra. Qed.

(* ======================================================================= *)
(** ** x <> 0 *)

(* (** deprecated *) *)
(* Ltac neq_zero := *)
(*   intros; autorewrite with R in *; *)
(*   repeat match goal with *)
(*   (* symmetry *) *)
(*   | H : 0 <> ?a |- ?b <> 0 => apply not_eq_sym in H *)
(*   | H : 0 <> ?a |- 0 <> ?b => apply not_eq_sym in H; apply not_eq_sym *)
(*   (* normal *) *)
(*   | _ : 0 < ?r |- ?r <> 0 => apply zero_lt_imply_Rneq0 *)
(*   | _ : ?r1 <> 0 |- ?r1² <> 0 => apply Rneq0_imply_Rsqr_neq0 *)
(*   | _ : ?r1² <> 0 |- ?r1 <> 0 => apply Rsqr_neq0_imply_Rneq0 *)
(*   | _ : ?r1 + ?r2 <> 0, _ : ?r1 = 0 |- ?r2 <> 0 =>  *)
(*     apply Rplus_neq0_imply_Rneq0_2_1 *)
(*   | _ : ?r1 + ?r2 <> 0, _ : ?r2 = 0 |- ?r1 <> 0 =>  *)
(*     apply Rplus_neq0_imply_Rneq0_2_2 *)
(*   (* default *) *)
(* (*   | |- ?b <> 0 => apply zero_lt_imply_Rneq0 *) *)
(*   | |- _ => idtac *)
(*   end; *)
(*   auto with R. *)

Section TEST_neq_zero.
  Goal forall r, r² <> 0 <-> r <> 0. ra. Qed.
  Goal forall r, r² <> 0 -> r <> 0. ra. Qed.
  Goal forall r, r <> 0 -> r * r <> 0. ra. Qed.
  Goal forall r, r <> 0 -> r² <> 0. ra. Qed.

  Goal forall r, 0 <> r * r -> r <> 0. ra. Qed.
  Goal forall r, r * r <> 0 -> 0 <> r. ra. Qed.
  Goal forall r, 0 <> r * r -> 0 <> r. ra. Qed.

  Goal forall r1 r2 r3 r4 : R,
    r1 <> 0 \/ r2 <> 0 \/ r3 <> 0 \/ r4 <> 0 <->
    r1 * r1 + r2 * r2 + r3 * r3 + r4 * r4 <> 0.
  Proof. ra. Qed.

End TEST_neq_zero.

(* ======================================================================= *)
(** ** a < b *)

Lemma Rdiv_le_imply_Rmul_gt a b c : b > 0 -> a * /b < c -> a < b * c.
Proof.
  intros.
  apply (Rmult_lt_compat_l b) in H0; auto.
  replace (b * (a * /b)) with a in H0; auto.
  field. auto with R.
Qed.
Global Hint Resolve Rdiv_le_imply_Rmul_gt : R.

Lemma Rmul_gt_imply_Rdiv_le a b c : b > 0 -> a < b * c -> a * /b < c.
Proof.
  intros.
  apply (Rmult_lt_compat_l (/b)) in H0; auto with R.
  autorewrite with R in *.
  replace (/b * a) with (a / b) in *; try field; auto with R.
  replace (/b * (b * c)) with c in *; try field; auto with R.
Qed.
Global Hint Resolve Rmul_gt_imply_Rdiv_le : R.

(* Global Hint Resolve  *)
(*     Rminus_gt_0_lt  (* 0 < b - a -> a < b *) *)
(*     Rlt_Rminus      (* a < b -> 0 < b - a *) *)
(*     Rlt_minus       (* r1 < r2 -> r1 - r2 < 0 *) *)
(*     : R. *)

Ltac tac_le :=
  autounfold with R;
  match goal with
  | |- 0 < ?a + - ?b => apply Rlt_Rminus
  | |- ?a * (?b * /?c) < ?e => replace (a * (b * /c)) with ((a * b) * /c)
  | |- ?a * /?b < ?c => assert (a < b * c); assert (0 < b)
  | |- _ => idtac
  end; try lra; auto with R.

Section TEST_tac_le.

  (** This proof cannot be finished in one step *)
  Goal forall h T, 0 < h -> h < 9200 -> -60 < T -> T < 60 -> h / (273.15 + T) < 153.
    ra. Abort.

  (** Naming the hypothesises *)
  Variable h T : R.
  Hypothesis Hh1 : 0 < h.
  Hypothesis Hh2 : h < 9200.
  Hypothesis HT1 : -60 < T.
  Hypothesis HT2 : T < 60.

  (** a simpler proposition can be proved in one step *)
  Goal h * 0.0065 < 273.15 + T. ra. Qed.

  (** We can finish the original proof with manually help *)
  Goal h / (273.15 + T) < 153.
    autounfold with R.
    assert (273.15 + T > 0). ra.
    assert (h < (273.15 + T) * 153). ra. auto with R.
  Qed.

  (** Another example, also need to manually *)
  Goal h / (273.15 + T) < 1 / 0.0065.
  Proof.
    ra. (* can not finish it *)
    autounfold with R.
    assert (273.15 + T > 0). ra.
    assert (h < (273.15 + T) * (1/0.0065)). ra. auto with R.
  Qed.

  (* This example shows the usage of tac_le tactic *)
  Goal h / (273.15 + T) < 1 / 0.0065.
  Proof.
    tac_le.
  Qed.

  (** This example shows the usage of tac_le and ra together. *)
  Goal  0 < 1 - (0.0065 * (h * / (273.15 + T))).
  Proof.
    (* construct condition manually, then try to automate *)
    assert (h / (273.15 + T) < 1/0.0065).
    tac_le. ra.
  Qed.

  Goal 0 < 1 - (0.0065 * (h * / (273.15 + T))).
  Proof.
    do 3 tac_le.
  Qed.

End TEST_tac_le.

(* ======================================================================= *)
(** ** Compare with PI *)
Section compare_with_PI.

  (** How to prove the inequalities about PI *)
  Goal 2 < PI.
  Proof.
  Abort.

  (** One method: give the upper and lower bound of PI with concrete value by axiom,
      then use transitivity to solve it by lra. *)
  Definition PI_ub : R := 3.14159266.
  Definition PI_lb : R := 3.14159265.
  Axiom PI_lt : PI < PI_ub.
  Axiom PI_gt : PI_lb < PI.

  Goal 2 < PI.
  Proof.
    apply Rlt_trans with PI_lb; unfold PI_lb. lra. apply PI_gt.
  Qed.

End compare_with_PI.

(* ======================================================================= *)
(** ** These are old code early, need to be discarded gradually *)

(* (** a + b <> 0 *) *)
(* Ltac plus_neq0 := *)
(*   match goal with *)
(*   | |- ?a + ?b <> 0 => apply Rgt_not_eq,Rlt_gt,Rplus_lt_0_compat;  *)
(*     auto with R fcs *)
(*   end. *)

(* (** 0 < a *) *)
(* Ltac zero_lt := *)
(*   repeat match goal with *)
(*   (* 0 *) *)
(*   | H: ?a <> 0 |- 0 < ?a * ?a => apply Rlt_0_sqr; apply H *)
(*   | |- 0 < ?a + ?b => apply Rplus_lt_0_compat *)
(*   | |- 0 < ?a * ?b => apply Rmult_lt_0_compat *)
(*   | |- 0 < sqrt ?a => apply sqrt_lt_R0 *)
(*   | |- 0 < ?a / ?b => unfold Rdiv *)
(*   | |- 0 < / ?a => apply Rinv_0_lt_compat *)
(*   | |- 0 < ?a ^ _ => simpl *)
(*   | |- 0 < (?a)² => unfold Rsqr *)
(*   | |- 0 < ?a => auto with R fcs; try lra *)
(*   (* R0 *) *)
(*   | |- R0 < ?a * ?b => apply Rmult_lt_0_compat; try lra; auto with R fcs *)
(*   | |- R0 < sqrt ?a => apply sqrt_lt_R0 *)
(*   | |- R0 < ?a / ?b => unfold Rdiv *)
(*   | |- R0 < / ?a => apply Rinv_0_lt_compat *)
(*   | |- R0 < ?a ^ _ => simpl *)
(*   | |- R0 < (?a)² => unfold Rsqr *)
(*   | |- R0 < ?a => auto with R fcs; try lra *)
(*   end. *)

(* (** 0 <= a *) *)
(* Ltac zero_le := *)
(*   (* simplify sqrt+pow2 *) *)
(*   repeat ( *)
(*   try simpl_sqrt_pow2; *)
(*   try match goal with *)
(*   (* 0 <= sqrt x *) *)
(*   | |- 0 <= sqrt _ => apply sqrt_pos *)
(*   (* 0 <= a * a *) *)
(*   | |- 0 <= ?a * ?a => apply Rle_0_sqr *)
(*   (* 0 <= a -> 0 <= b -> 0 <= a + b *)  *)
(*   | |- 0 <= ?a + ?b => apply Rplus_le_le_0_compat *)
(*   (* 0 <= a -> 0 <= b -> 0 <= a * b *) *)
(*   | |- 0 <= ?a * ?b => apply Rmult_le_pos *)
(*   (* if fail, proof < again *) *)
(* (*   | |- 0 <= ?a => apply Rlt_le; zero_le *)
(*   | |- R0 <= ?a => apply Rlt_le; zero_le *) *)
(*   end). *)

(* (** a * b <> 0 *) *)
(* Ltac mult_neq0 := *)
(*   match goal with *)
(*   | |- ?a * ?b <> 0 => apply Rgt_not_eq,Rlt_gt;zero_le *)
(*   end. *)

(* (** a <> 0 *) *)
(* Ltac neq0 := *)
(*   repeat match goal with *)
(*   | |- ?a /\ ?b => repeat split *)
(*   | |- ?a <> 0 => apply Rgt_not_eq,Rlt_gt; zero_le *)
(*   end. *)

(** Simplification for trigonometric functions *)

(* Lemma xx_sqr : forall x:R, x * x = Rsqr x. *)
(* Proof. auto. Qed. *)

(* Lemma cos2_sin2' : forall x:R, Rsqr (cos x) + Rsqr (sin x) = 1. *)
(* Proof. intros. autorewrite with R. auto with R. Qed. *)

(* Lemma cos_sin : forall x:R, cos x * sin x = sin x * cos x. *)
(* Proof. ra. Qed. *)

(* Lemma x_neg_x : forall x:R, x + - x = 0. *)
(* Proof. ra. Qed. *)

(* Lemma neg_x_x : forall x:R, -x + x = 0. *)
(* Proof. intros. lra. Qed. *)

(* Lemma x_mul_neg_x : forall x y : R, y * -x = - (x * y). *)
(* Proof. intros. lra. Qed. *)

(* Lemma neg_x_mul_x : forall x y : R, -y * x = - (y * x). *)
(* Proof. intros. lra. Qed. *)

(* Lemma sqrR1_R1 : R1² = R1. *)
(* Proof. unfold Rsqr. ring. Qed. *)

(* Lemma one_R1 : 1 = R1. *)
(* Proof. ring. Qed. *)

(* Lemma inv1_R1 : /1 = R1. *)
(* Proof. field. Qed. *)

(* Lemma invR1_R1 : /R1 = R1. *)
(* Proof. field. Qed. *)

(* Lemma sqrtR1_R1 : sqrt R1 = R1. *)
(* Proof. apply Rsqr_inj. zero_le. lra. rewrite Rsqr_sqrt. *)
(*   rewrite sqrR1_R1. auto. lra. *)
(* Qed. *)

(* Lemma sqrt1_R1 : sqrt 1 = R1. *)
(* Proof. rewrite one_R1. apply sqrtR1_R1. Qed. *)

(* Lemma coscos_sinsin : forall x : R, (cos x * cos x + sin x * sin x) = 1. *)
(* Proof. intros. rewrite ?xx_sqr. rewrite ?cos2_sin2. auto. Qed. *)

(* Lemma sinsin_coscos : forall x : R, (sin x * sin x + cos x * cos x) = 1. *)
(* Proof. intros. rewrite ?xx_sqr. rewrite ?sin2_cos2. auto. Qed. *)

(* (** r1 - (-r2) = r1 + r2 *) *)
(* Lemma Rsub_Rneg : forall (r1 r2 : R), r1 - (- r2) = r1 + r2. *)
(* Proof. intros. ring. Qed. *)

(* (** Simplify trigonometric function and expression of real number *) *)
(* Ltac trigo_simp :=  *)
(*   rewrite ?Rmult_opp_opp;   (* -x * -x = x * x *) *)
(* (*   rewrite ?xx_sqr;          (* x * x = Rsqr x  *) *) *)
(*   rewrite ?Rsub_Rneg,       (* r1 - (-r2) = r1 + r2 *) *)
(*           ?sin2_cos2,       (* sin^2 + cos^2 = 1 *) *)
(*           ?cos2_sin2,       (* cos^2 + sin^2 = 1 *) *)
(*           ?coscos_sinsin,   (* cos*cos + sin*sin = 1 *) *)
(*           ?sinsin_coscos,   (* sin*sin + cos*cos = 1 *) *)
(*           ?cos_sin,         (* cos * sin = sin * cos *) *)
(*           ?x_mul_neg_x,     (* y * -x = - (x * y) *) *)
(*           ?neg_x_mul_x,     (* -y * x = - (x * y) *) *)
(*           ?x_neg_x,         (* x + -x = 0 *) *)
(*           ?neg_x_x,         (* -x + x = 0 *) *)
(*           ?sqrtR1_R1,       (* sqrt R1 = R1 *) *)
(*           ?sqrt1_R1,        (* sqrt 1 = 1 *) *)
(*           ?sqrR1_R1,        (* R1² = R1 *) *)
(* (*           ?Rinv_1,           (* /1 = 1 *) *) *)
(*           ?inv1_R1,         (* /1 = R1 *) *)
(*           ?invR1_R1,        (* /R1 = R1 *) *)
(*           ?one_R1           (* 1 = R1 *) *)
(*   ; *)
(*   autorewrite with R;       (* +0, 0+, *0, 0*, *1, 1* *) *)
(*   try field; *)
(*   auto. *)

(* (* sqrt x = R1 -> x = R1 *) *)
(* Lemma sqrt_eqR1_imply_R1 : forall (x : R), sqrt x = R1 -> x = R1. *)
(* Proof. *)
(*   intros. *)
(*   assert ((sqrt x)² = R1). rewrite H. unfold Rsqr. lra. rewrite <- H0. *)
(*   rewrite Rsqr_sqrt; auto. *)
(*   assert (0 < sqrt x). rewrite H. lra.  *)
(*   apply sqrt_gt0_imply_gt0 in H1. lra. *)
(* Qed. *)

(* ######################################################################### *)
(** * Conversion between R and other types *)

(** Remark:

    We need two functions commonly used in computer: floor (rounding down), and
    ceiling (rounding up). Although the function "up" in Coq-std-lib is looks like
    a rounding up function, but it is a bit different. We need to explicitly
    define them. Meanwhile, we tested their behaviors on negative numbers

    The behavior of "up" is this:
        r∈[2.0,3.0) -> up(r)=3,
    and there is a lemma saying this:
        Check archimed. (* IZR (up r) > r /\ IZR (up r) - r <= 1 *)

    But we need the behavior of floor and ceiling are these below exactly:
    1. floor
       r∈[2.0,3.0), floor(r)=2
       So, floor(r) = up(r) - 1
    2. ceiling
       r∈(2.0,3.0), ceiling(r)=3
       r=2.0, ceiling(r)=2
       So, if IZR(up(r))=r，then ceiling(r)=up(r)-1，else ceiling(r)=up(r).

    When talking about negative numbers, their behaviors are below:
    floor    2.0 = 2
    floor    2.5 = 2
    floor   -2.0 = -2
    floor   -2.5 = -3

    ceiling  2.0 = 2
    ceiling  2.5 = 3
    ceiling -2.0 = -2
    ceiling -2.5 = -2
 *)

(** ** Properties about up and IZR *)

(** Eliminate the up_IZR *)
Lemma up_IZR : forall z, up (IZR z) = (z + 1)%Z.
Proof.
  intros.
  rewrite up_tech with (r:=IZR z); auto; ra.
  apply IZR_lt. lia.
Qed.

(** There is a unique integer if such a IZR_up equation holds. *)
Lemma IZR_up_unique : forall r, r = IZR (up r - 1) -> exists! z, IZR z = r.
Proof.
  intros.
  exists (up r - 1)%Z. split; auto.
  intros. subst.
  rewrite up_IZR in *.
  apply eq_IZR. auto.
Qed.

(** There isn't any integer z and real number r such that r ∈(IZR z, IZR (z+1)) *)
Lemma IZR_in_range_imply_no_integer : forall r z,
    IZR z < r ->
    r < IZR (z + 1) ->
    ~(exists z', IZR z' = r).
Proof.
  intros. intro. destruct H1. subst.
  apply lt_IZR in H0.
  apply lt_IZR in H. lia.
Qed.

(* ######################################################################### *)
(** ** Conversion between R and other types *)

(** *** Conversion between Z and R *)

(** Z to R *)
Definition Z2R (z : Z) : R := IZR z.

(** Rounding R to z, take the floor: truncate to the nearest integer
    not greater than it *)
Definition R2Z_floor (r : R) : Z := (up r) - 1.

(** Rounding R to z, take the ceiling: truncate to the nearest integer
    not less than it *)
Definition R2Z_ceiling (r : R) : Z :=
  let z := up r in
  if Req_EM_T r (IZR (z - 1)%Z)
  then z - 1
  else z.

(* Compute R2Z_floor 0.5 *)

(** r∈[z,z+1.0) -> floor(r) = z *)
Lemma R2Z_floor_spec : forall r z,
    IZR z <= r < IZR z + 1.0 -> R2Z_floor r = z.
Proof.
  intros. unfold R2Z_floor in *. destruct H.
  assert (up r = z + 1)%Z; try lia.
  rewrite <- up_tech with (z:=z); auto.
  rewrite plus_IZR. lra.
Qed.

(** (r=z -> ceiling r = z) /\ (r∈(z,z+1.0) -> ceiling r = z+1) *)
Lemma R2Z_ceiling_spec : forall r z,
    (r = IZR z -> R2Z_ceiling r = z) /\
      (IZR z < r < IZR z + 1.0 -> R2Z_ceiling r = (z+1)%Z).
Proof.
  intros. unfold R2Z_ceiling in *. split; intros.
  - destruct (Req_EM_T r (IZR (up r - 1))).
    + rewrite H. rewrite up_IZR. lia.
    + rewrite H in n. destruct n.
      rewrite up_IZR. f_equal. lia.
  - destruct H. destruct (Req_EM_T r (IZR (up r - 1))).
    + apply IZR_in_range_imply_no_integer in H; auto.
      * destruct H. exists (up r - 1)%Z; auto.
      * rewrite plus_IZR. ra.
    + rewrite up_tech with (r:=r); auto; ra.
      rewrite plus_IZR. ra.
Qed.

(** Z2R (R2Z_floor r) is less than r *)
Lemma Z2R_R2Z_floor_le : forall r, Z2R (R2Z_floor r) <= r.
Proof.
  intros. unfold Z2R,R2Z_floor. rewrite minus_IZR.
  destruct (archimed r). ra.
Qed.

(** r-1 is less than Z2R (R2Z_floor r) *)
Lemma Z2R_R2Z_floor_gt : forall r, r - 1 < Z2R (R2Z_floor r).
Proof.
  intros. unfold Z2R,R2Z_floor. rewrite minus_IZR.
  destruct (archimed r). ra.
Qed.

(** *** Conversion between nat and R *)

Definition nat2R (n : nat) : R := Z2R (nat2Z n).
Definition R2nat_floor (r : R) : nat := Z2nat (R2Z_floor r).
Definition R2nat_ceiling (r : R) : nat := Z2nat (R2Z_ceiling r).

(* ######################################################################### *)
(** * Reqb,Rleb,Rltb: Boolean comparison of R *)

Definition Reqb (r1 r2 : R) : bool := HierarchySetoid.Aeqb r1 r2.
Definition Rleb (r1 r2 : R) : bool := if Rle_lt_dec r1 r2 then true else false.
Definition Rltb (r1 r2 : R) : bool := if Rlt_le_dec r1 r2 then true else false.
Infix "=?"  := Reqb : R_scope.
Infix "<=?" := Rleb : R_scope.
Infix "<?"  := Rltb : R_scope.
Infix ">?"  := (fun x y => y <? x) : R_scope.
Infix ">=?" := (fun x y => y <=? x) : R_scope.

(** Reflection of (=) and (=?) *)
(* Lemma Reqb_true : forall x y, x =? y = true <-> x = y. *)
(* Proof. *)
(*   apply Aeqb_true. *)
(* Qed. *)

(* Lemma Reqb_false : forall x y, x =? y = false <-> x <> y. *)
(* Proof. *)
(*   apply Aeqb_false. *)
(* Qed. *)
Lemma Reqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros. unfold Reqb,Aeqb. destruct (decidable); constructor; auto.
Qed.

Lemma Reqb_refl : forall r, r =? r = true.
Proof.
  intros. cbv. destruct Req_EM_T; auto.
Qed.

Lemma Reqb_comm : forall r1 r2, (r1 =? r2) = (r2 =? r1).
Proof.
  intros. cbv. destruct Req_EM_T,Req_EM_T; subst; auto. easy.
Qed.

Lemma Reqb_trans : forall r1 r2 r3, r1 =? r2 = true ->
  r2 =? r3 = true -> r1 =? r3 = true.
Proof.
  intros. cbv in *. destruct Req_EM_T,Req_EM_T,Req_EM_T; subst; auto.
Qed.

Lemma Rltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros. unfold Rltb. destruct (Rlt_le_dec x y); constructor; lra.
Qed.

Lemma Rleb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros. unfold Rleb. destruct (Rle_lt_dec x y); constructor; lra.
Qed.

Lemma Rgtb_reflect : forall x y, reflect (x > y) (x >? y).
Proof.
  intros. unfold Rltb. destruct (Rlt_le_dec y x); constructor; lra.
Qed.

Lemma Rgeb_reflect : forall x y, reflect (x >= y) (x >=? y).
Proof.
  intros. unfold Rleb. destruct (Rle_lt_dec y x); constructor; lra.
Qed.

(* ######################################################################### *)
(** * Approximate of two real numbers *)

(** r1 ≈ r2, that means |r1 - r2| <= diff *)
Definition Rapprox (r1 r2 diff : R) : Prop := Rabs (r1 - r2) <= diff.

(** boolean version of approximate function *)
Definition Rapproxb (r1 r2 diff : R) : bool := Rleb (Rabs (r1 - r2)) diff.

(* ######################################################################### *)
(** * Mathematical Hierarchy *)

(* Global Instance EqReflect_R : EqReflect Reqb. *)
(* Proof. *)
(*   constructor. intros. *)
(*   destruct (a =? b) eqn:E1. *)
(*   - apply Reqb_eq in E1. constructor. auto. *)
(*   - apply Reqb_neq in E1. constructor. auto. *)
(* Defined. *)

(* ######################################################################### *)
(** * Examples which cannot automatically solved now *)

(** This example is occurred in the proof about Carg in Complex. *)
Goal forall a b r, a > 0 -> b <= r / a -> 0 <= r - b *a.
Proof.
  intros.
  ra. (* No effect *)
  apply Rmult_le_compat_r with (r:=a) in H0; ra.
  unfold Rdiv in H0. rewrite Rmult_assoc in H0.
  rewrite Rinv_l in H0; ra.
Qed.

(* ######################################################################### *)
(** * Temporarily added lemmas, need to be arranged to proper places *)

Lemma mult_PI_gt0 : forall r, 0 < r -> 0 < r * PI.
Proof.
  ra.
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                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                     SF_Eval.v                                      *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Max.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.
Require Import IntensionalLib.Wave_as_SF.SF_reduction.
Require Import IntensionalLib.Wave_as_SF.SF_Normal.
Require Import IntensionalLib.Wave_as_SF.SF_Closed.
Require Import IntensionalLib.Wave_as_SF.Substitution.

Definition eval_app M N :=
match M with
| App (App (Op Node) (Op Node)) M1  => M1
| App (App (Op Node) (App (Op Node) M1)) M2 =>
      App (App M2 N) (App M1 N)
| App (App (Op Node) (App (App (Op Node) M1) M2)) M3 =>
    App (App N M1) M2
| x => App x N
end.

Lemma eval_app_from_SF : forall M N, sf_red (App M N) (eval_app M N).
Proof.
induction M; split_all.
gen_case IHM1 M1. gen_case IHM1 s.  gen_case IHM1 o.
gen_case IHM1 s0.
(* 2 *)
case o0; auto. red; one_step.
(* 1 *)
case s1; split_all.
(* 2 *)
case o0; split_all. red; one_step.
(* 1 *)
case s3; split_all. case o0; split_all. red; one_step.
Qed.

Fixpoint eval0 (M: SF) :=
match M with
| Ref i => Ref i
| Op o => Op o
| App (Op Fop) M11 => App (Op Fop) (eval0 M11)
| App M1 M11 => eval_app (eval0 M1) M11
end.

Lemma eval0_from_SF : forall M, sf_red M (eval0 M).
Proof.
induction M; split_all.
eapply transitive_red.
eapply preserves_app_sf_red. eapply2 IHM1. auto.
eapply transitive_red.
eapply2 eval_app_from_SF.
case M1; split_all.
case o; split_all.
eapply preserves_app_sf_red. auto. eapply2 IHM2.
Qed.

Ltac eval_tac := unfold_op;
match goal with
| |-  sf_red ?M _ => red; eval_tac
| |-  multi_step sf_red1 ?M _ =>
  (apply transitive_red with (eval0 M);
[eapply2 eval0_from_SF |
  unfold eval0, eval_app;  unfold subst; split_all])
| _ => auto
end.

(* Boolean operations *)

Definition not M := App (App M (App k_op i_op)) k_op.

Lemma not_true : sf_red (not k_op) (App k_op i_op).
Proof. unfold not; eval_tac. Qed.

Lemma not_false : sf_red (not (App k_op i_op)) k_op.
Proof. eval_tac.  eval_tac.  Qed.

Definition  iff M N := App (App M N) (not N).

Lemma true_true : sf_red (iff k_op k_op) k_op.
Proof. unfold iff; unfold not; eval_tac; split_all. Qed.
Lemma true_false : sf_red (iff k_op (App k_op i_op)) (App k_op i_op).
Proof. unfold iff; unfold not; eval_tac; split_all. Qed.
Lemma false_true : sf_red (iff (App k_op i_op) k_op) (App k_op i_op).
Proof. unfold iff; unfold not; eval_tac; eval_tac; eval_tac; eval_tac; split_all. Qed.
Lemma false_false : sf_red (iff (App k_op i_op) (App k_op i_op)) k_op.
Proof.
unfold iff, not. unfold_op. repeat eval_tac. Qed.


Set Primitive Projections.
Set Implicit Arguments.
Set Universe Polymorphism.
Set Asymmetric Patterns.

Inductive sum A B := inl : A -> sum A B | inr : B -> sum A B.
Inductive Empty :=.

Record category :=
  { ob :> Type;
    hom : ob -> ob -> Type
  }.
Set Printing All.
Definition sum_category (C D : category) : category :=
  {|
    ob := sum (ob C) (ob D);
    hom x y := match x, y with
                 | inl x, inl y => @hom _ x y (* Toplevel input, characters 177-178:
Error:
In environment
C : category
D : category
x : sum (ob C) (ob D)
y : sum (ob C) (ob D)
x0 : ob C
y0 : ob C
The term "x0" has type "ob C" while it is expected to have type
"ob ?6" (unable to find a well-typed instantiation for
"?6": cannot unify"Type" and "category"). *)
                 | inr x, inr y => @hom _ x y
                 | _, _ => Empty
               end |}.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C Oprime Aprime Bprime : Universe, ((wd_ B Bprime /\ (wd_ Bprime C /\ (wd_ O A /\ (wd_ Oprime Aprime /\ (wd_ A C /\ (wd_ Aprime Bprime /\ (wd_ B C /\ (wd_ A Aprime /\ (wd_ O Aprime /\ (wd_ A Bprime /\ (wd_ C Aprime /\ (wd_ O Oprime /\ (wd_ A Oprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O A C /\ (col_ Oprime Aprime Bprime /\ (col_ B Bprime C /\ (col_ Bprime Bprime C /\ col_ Oprime Bprime Bprime))))))))))))))))))) -> col_ A C B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Coq Require Import ssreflect ssrfun ssrbool.
From Coq Require FunctionalExtensionality.

From Mon Require Export Base.
From Coq Require Import Relation_Definitions Morphisms.
From Mon Require Import SPropBase SPropMonadicStructures
  MonadExamples SpecificationMonads DijkstraMonadExamples.
From Relational Require Import OrderEnrichedCategory
  OrderEnrichedRelativeMonadExamples.

Section Commutations.
  Context {M:Monad}.

  Definition commute {A B} (ma : M A) (mb : M B) :=
    bind ma (fun a => bind mb (fun b => ret ⟨a,b⟩)) =
    bind mb (fun b => bind ma (fun a => ret ⟨a,b⟩)).

  Definition swap {A B} (ab : A × B) : B × A := ⟨nsnd ab, nfst ab⟩.

  Import FunctionalExtensionality.
  Lemma eq_bind {A B} (m : M A) :
    forall (f1 f2 : A -> M B), (forall a, f1 a = f2 a) -> bind m f1 = bind m f2.
  Proof. move=> ? ? /functional_extensionality -> //. Qed.

  Lemma map_ret {A B} (f : A -> B) (a : A) : f <$> ret a = @ret M _ (f a).
  Proof. rewrite /map /bind monad_law1 //. Qed.

  Lemma commute_elim {A B C} (f : A × B -> M C) (ma : M A) (mb : M B) :
    commute ma mb ->
    bind ma (fun a=> bind mb (fun b => f ⟨a,b⟩)) = bind mb (fun b=> bind ma (fun a=> f ⟨a,b⟩)).
  Proof.
    rewrite /commute=> /(f_equal (fun t => bind t f)).
    rewrite /bind !monad_law3. repeat rewrite -/bind.
    under eq_bind => a do (rewrite /bind !monad_law3 -/bind ; under eq_bind => b do rewrite monad_law1).
    under (@eq_bind B _) => a do (rewrite /bind !monad_law3 -/bind ; under eq_bind => b do rewrite monad_law1).
    done.
  Qed.

  Lemma commute_sym {A B} (ma : M A) (mb : M B)
    : commute ma mb -> commute mb ma.
  Proof.
    move=> /(commute_elim (fun p => ret (swap p))) //=.
  Qed.

  Import FunctionalExtensionality.
  Lemma commute_ret {A B} (a : A) (mb : M B) : commute (ret a) mb.
  Proof.
    rewrite /commute /bind monad_law1 ; f_equal.
    extensionality a2; rewrite monad_law1 //.
  Qed.

  Ltac apply_commute_elim H :=
    match goal with
    | [|- context c [bind ?m1 (fun a1 => bind ?m2 (fun a2 => @?f a1 a2))]] =>
      move: (commute_elim (fun p => f (nfst p) (nsnd p)) m1 m2 H) => /= ->
    end.

  Lemma commute_bind {A1 A2 B} (m1 : M A1) (f1 : A1 -> M A2) (m2:M B)
    : commute m1 m2 -> (forall a1, commute (f1 a1) m2) -> commute (bind m1 f1) m2.
  Proof.
    move=> Hm Hf ; rewrite /commute /bind monad_law3. repeat rewrite -/bind.
    under eq_bind => a1 do rewrite (Hf a1).
    apply_commute_elim Hm.
    under eq_bind => b do rewrite /bind -monad_law3.
    done.
  Qed.
End Commutations.

Ltac apply_commute_elim H :=
  match goal with
  | [|- context c [bind ?m1 (fun a1 => bind ?m2 (fun a2 => @?f a1 a2))]] =>
    move: (commute_elim (fun p => f (nfst p) (nsnd p)) m1 m2 H) => /= ->
  end.

Section FromFreeCommute.
  Context (W : OrderedMonad).
  Context {S1:Type} {P1:S1 -> Type} (wop1 : forall s1, W (P1 s1)).
  Context {S2:Type} {P2:S2 -> Type} (wop2 : forall s2, W (P2 s2)).
  Context (Hcom : forall s1 s2, commute (wop1 s1) (wop2 s2)).

  Let θ1 := OpSpecEffObs wop1.
  Let θ2 := OpSpecEffObs wop2.

  Import FunctionalExtensionality.
  Lemma fromFreeCommute A1 A2 : forall c1 c2, commute (θ1 A1 c1) (θ2 A2 c2).
  Proof.
    move=> c1.
    elim: c1 A2 => [a1|s1 k1 IH1] A2 c2; first by apply commute_ret.
    simpl; apply commute_bind ; last by move=> a1; apply: IH1.
    elim: c2 => [a2| s2 k2 IH2] ; first by apply commute_sym, commute_ret.
    simpl ; apply commute_sym, commute_bind; first by apply commute_sym, Hcom.
    move=> a2; apply commute_sym, IH2.
  Qed.

End FromFreeCommute.

Section CommuteEffectObs.
  Context (W : OrderedMonad) (M1 M2:Monad).
  Context (θ1 : MonadMorphism M1 W) (θ2 : MonadMorphism M2 W).
  Context (Hcom : forall A1 A2 c1 c2, commute (θ1 A1 c1) (θ2 A2 c2)).

  Definition Wrel : RelationalSpecMonad0 :=
    relativeMonad_precomposition typeCat_prod (ordmonad_to_relmon W).

  Import SPropNotations.
  Import FunctionalExtensionality.
  Program Definition commute_effObs : RelationalEffectObservation0 M1 M2 Wrel
    :=
      mkREO0 M1 M2 Wrel
             (fun '⟨A1,A2⟩ => ⦑fun '⟨c1,c2⟩ => bind (θ1 A1 c1) (fun a1=> bind (θ2 A2 c2)
                                               (fun a2=> ret ⟨a1,a2⟩))⦒) _ _.
  Next Obligation. move=> ? ? H ; induction H; reflexivity. Qed.
  Next Obligation.
    apply sig_eq=> /= ; extensionality a=> /=.
    now do 2 rewrite mon_morph_ret /bind monad_law1.
  Qed.
  Next Obligation.
    apply sig_eq=> /= ; extensionality x=> /=.
    rewrite mon_morph_bind {1 2}/bind monad_law3; repeat rewrite -/bind.
    under eq_bind => a.
      under eq_bind => b.
        rewrite mon_morph_bind /bind monad_law3 ; repeat rewrite -/bind.
        over.
      apply_commute_elim (Hcom _ _ (nfst f a) (nsnd x)).
      over.
    rewrite /bind monad_law3; repeat rewrite -/bind.
    f_equal ; extensionality a1.
    rewrite /bind monad_law3; repeat rewrite -/bind.
    f_equal ; extensionality a2.
    rewrite /bind monad_law1 //.
  Qed.

End CommuteEffectObs.

Section ConverseCommute.
  Context (M1 M2 : Monad).
  Context (W : OrderedMonad).
  Let Wrel := relativeMonad_precomposition typeCat_prod (ordmonad_to_relmon W).

  Context (θ : RelationalEffectObservation0 M1 M2 Wrel).

  Let θapp (A B : Type) := proj1_sig (θ ⟨A , B⟩).

  Definition unitt : Type := unit.

  Import FunctionalExtensionality.

  Lemma θret (A B : Type) (a : A) (b : B) : θapp A B ⟨ ret a, ret b ⟩ = ret ⟨ a, b ⟩.

    move: (rmm_law1 _ _ _ _ θ ⟨A,B⟩) => /(f_equal sval) e.
    apply (equal_f e ⟨a, b ⟩).
  Qed.

  Lemma θbind (A1 A2 B1 B2 : Type) (m1 : M1 A1) (f1 : A1 -> M1 B1) (m2 : M2 A2) (f2 : A2 -> M2 B2) : θapp B1 B2 ⟨ bind m1 f1 ,  bind m2 f2 ⟩ = bind (θapp A1 A2 ⟨m1, m2⟩) (fun p => θapp B1 B2 ⟨ f1 (nfst p), f2 (nsnd p) ⟩).
    move: (rmm_law2 _ _ _ _ θ ⟨A1,A2⟩ ⟨B1, B2⟩ (⟨f1, f2⟩)) => /(f_equal sval) e.
    apply (equal_f e ⟨m1, m2⟩).
  Qed.

  Lemma bind_comm : forall (M : Monad) A1 A2 A3 (f : A1 -> A2) (m : M A1) (k : A2 -> M A3), bind (f <$> m) k = bind m (fun a => k (f a)).
    move=> M A1 A2 A3 f m k //=.
    rewrite /bind (monad_law3 m).
    f_equal; extensionality a; rewrite (monad_law1); reflexivity.
  Qed.

  Program Definition effobs_from_releffobs1 : MonadMorphism M1 W := @mkMorphism _ _ (fun A v => nfst <$> θapp A unitt ⟨ v, ret tt ⟩) _ _.
  Next Obligation.
    rewrite /map θret.
    rewrite /bind /ret monad_law1. reflexivity.
  Qed.
  Next Obligation.
    rewrite bind_comm.
    rewrite <- (monad_law2 (ret tt)) at 1.
    rewrite θbind //.
    rewrite /map /bind monad_law3. f_equal; extensionality a; destruct a as [a []].
    reflexivity.
  Qed.

  Let θ1 := effobs_from_releffobs1.

  Program Definition effobs_from_releffobs2 : MonadMorphism M2 W := @mkMorphism _ _ (fun A v => nsnd <$> θapp unitt A ⟨ ret tt, v ⟩) _ _.
  Next Obligation.
    rewrite /map θret.
    rewrite /bind /ret monad_law1. reflexivity.
  Qed.
  Next Obligation.
    rewrite bind_comm.
    rewrite <- (monad_law2 (ret tt)) at 1.
    rewrite θbind //.
    rewrite /map /bind monad_law3. f_equal; extensionality a; destruct a as [[] a]. reflexivity.
  Qed.

  Let θ2 := effobs_from_releffobs2.

  Lemma releffobs_eq_effobs1 :
    forall A1 A2 c1 c2,
      θapp A1 A2 ⟨c1, c2⟩ =
      bind (θ1 A1 c1) (fun a : A1 => bind (θ2 A2 c2) (fun b : A2 => ret ⟨ a, b ⟩)).
  Proof.
    move=> A1 A //= c1 c2.
    rewrite <- (monad_law2 c1) at 1.
    rewrite <- (monad_law1 tt (fun _ => c2)) at 1.
    rewrite θbind /=. rewrite bind_comm.
    apply (f_equal (bind (θapp A1 unit ⟨ c1, monad_ret M2 tt ⟩))).
    extensionality a. destruct a as [a1 []].
    rewrite bind_comm //=.
    rewrite <- (monad_law2 c2) at 1.
    rewrite <- (monad_law1 tt (fun _ => monad_ret M1 a1)).
    rewrite θbind.
    apply (f_equal (bind (θapp unit A ⟨ monad_ret M1 tt, c2 ⟩))).
    extensionality b. destruct b as [[] a2].
    apply θret.
  Qed.

  Lemma releffobs_eq_effobs2 : forall A1 A2 c1 c2, θapp A1 A2 ⟨c1, c2⟩ = bind (θ2 A2 c2) (fun b : A2 => bind (θ1 A1 c1) (fun a : A1 => ret ⟨ a, b ⟩)).
    move=> A1 A2 //= c1 c2.
    rewrite <- (monad_law2 c2) at 1.
    rewrite <- (monad_law1 tt (fun _ => c1)) at 1.
    rewrite θbind /=. rewrite bind_comm.
    congr bind.
    extensionality a. destruct a as [[] a2].
    rewrite bind_comm //=.
    rewrite <- (monad_law2 c1) at 1. rewrite <- (monad_law1 tt (fun _ => monad_ret M2 a2)).
    rewrite θbind.
    congr bind. extensionality b. destruct b as [a1 []].
    apply θret.
  Qed.

  Lemma effobs12_commute : forall A1 A2 c1 c2, commute (θ1 A1 c1) (θ2 A2 c2).
    move=> A1 A2 c1 c2. unfold commute.
    rewrite /commute -releffobs_eq_effobs1 -releffobs_eq_effobs2. reflexivity.
  Qed.

  Let θ' : RelationalEffectObservation0 M1 M2 Wrel := commute_effObs _ _ _ θ1 θ2 effobs12_commute.

  Theorem converse_to_commute_effObs : forall A1 A2 c1 c2,
      proj1_sig (θ ⟨ A1, A2 ⟩) ⟨ c1, c2 ⟩  = proj1_sig (θ' ⟨ A1, A2 ⟩) ⟨ c1, c2 ⟩.
    move=> A1 A2 //= c1 c2. apply releffobs_eq_effobs1.
  Qed.
End ConverseCommute.


(*

Author:  Adam Petz, ampetz@ku.edu
*)

Require Import Coq.ZArith.ZArith_base Coq.Strings.String Coq.Strings.Ascii.
Require Import ExtLib.Data.Monads.StateMonad ExtLib.Data.Monads.ReaderMonad ExtLib.Structures.Monads ExtLib.Data.Monads.IdentityMonad.
Require Import List.

Import MonadNotation.
Import ListNotations.
Local Open Scope monad_scope.

Record Env : Type := mk_Env
                          { envA : nat}.

Record St : Type := mk_St
                         { stB : nat}.

Definition M := readerT Env (stateT St ident).
(*Context {State_m: MonadReader Env M}.*)

Definition empty_state := (mk_St 0).
Definition init_env := (mk_Env 0).

Definition inc : M nat :=
  myEnvVal <- asks envA ;;
  myState <- get ;;
  let oldStVal := (stB myState) in
  put (mk_St (oldStVal + 1)) ;;
      ret oldStVal.

Check runReaderT.

Definition incVal :=
  evalStateT (runReaderT inc init_env) empty_state.

Definition incSt : ident St :=
  execStateT (runReaderT inc init_env) empty_state.

Compute (unIdent incVal).
Compute (unIdent incSt).

Definition inc_no_reader : M nat :=
  myState <- get ;;
  let oldStVal := (stB myState) in
  put (mk_St (oldStVal + 1)) ;;
  ret oldStVal.

Definition inc_no_reader_Val : ident nat :=
  evalStateT (inc_no_reader) empty_state.

Definition inc_no_reader_St : ident St :=
  execStateT (inc_no_reader) empty_state.

Compute (unIdent inc_no_reader_Val).
Compute (stB (unIdent inc_no_reader_St)).

Definition just_reader : M nat :=
  myEnvVal <- asks envA ;;
           ret 42.

Definition just_reader_Val : ident nat :=
  evalStateT (just_reader) empty_state.

Definition just_reader_St : ident St :=
  execStateT (just_reader) empty_state.

Compute (unIdent just_reader_Val).
Compute (stB (unIdent just_reader_St)).

Definition R := readerT Env (ident).
Context {asdf: MonadState St R}.


(* Paolo Torrini,
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* example of concrete module *)

Require Import EnvLibA.
Require Import IdModTypeA.
Require Import PRelLibA.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.

Module ModNat1 <: IdModType.

  Definition Id := string.

  Definition IdEqDec := string_dec.

  Instance IdEq2 : DEq Id :=
  {
  dEq := IdEqDec
  }.

  Definition IdEq := IdEq2.

  Definition W := nat.

  Definition Loc_PI := valTyp_irrelevance.

  Definition BInit := 0.

  Instance WP2 : PState W :=
  {
  loc_pi := Loc_PI;

  b_init := BInit
  }.

  Definition WP := WP2.

End ModNat1.


From App Require Export
     AppMessage.
From ITree Require Export
     ITree.
From HTTP Require Export
     Semantics.

Variant appE {requestT responseT server_state} : Type -> Type :=
  App__Recv : server_state -> appE (clientT * requestT)
| App__Send : clientT -> responseT -> appE unit.
Arguments appE : clear implicits.

Inductive exp : Type -> Type :=
  Exp__Var   : var -> exp N
| Exp__Const : N   -> exp N
| Exp__Nth   : exp N -> list (exp N) -> exp nat.

Fixpoint exp_eq {X Y} (x : exp X) (y : exp Y) : bool :=
  match x, y with
  | Exp__Var   a, Exp__Var   b
  | Exp__Const a, Exp__Const b => a = b?
  | Exp__Nth x l, Exp__Nth y m => exp_eq x y &&& eqb_list exp_eq l m
  | _, _ => false
  end.

Fixpoint exp_to_sexp {T} (e : exp T) : sexp :=
  match e with
  | Exp__Var   x => [Atom "Variable"; Atom x]
  | Exp__Const n => [Atom "Number"; Atom n]
  | Exp__Nth x l => [Atom "Nth"; exp_to_sexp x; List (map exp_to_sexp l)]
  end%sexp.

#[global]
Instance Serialzie__exp {T} : Serialize (exp T) := exp_to_sexp.

Variant symE : Type -> Type :=
  Sym__Fresh : symE (exp N)
| Sym__Eval  : exp nat -> symE nat.

Class  Is__smE q r s E `{appE q r s -< E} `{symE -< E}.
Notation smE q r s := (appE q r s +' symE).
#[global]
Instance smE_Is__smE {q r s} : Is__smE q r s (smE q r s). Defined.

Definition server_smi {q r s E} `{Is__smE q r s E}
           (handler : forall {F} `{symE -< F}, q -> Monads.stateT s (itree F) r)
  : s -> itree E void :=
  iter_forever
    (fun ss : s =>
       '(c, req) <- embed App__Recv ss;;
       '(ss', res) <- handler req ss;;
       embed App__Send c res;;
       ret ss) .

Definition swap_state exp_ : Type :=
  list (accountT exp_) * list (orderT exp_).

Definition findAccount {exp_} (uid : user_id) (ticker : assetT)
           (a : accountT exp_) : bool :=
  let '(_, (u, t, _)) := a in
  (uid =? u) &&& (ticker =? t).

Definition getx {V E} `{symE -< E} (k : exp N) (l : list (exp N * V))
  : itree E (option V) :=
  n <- embed Sym__Eval (Exp__Nth k (map fst l));;
  ret (snd <$> nth_error l n).

Definition replace {V} (n : nat) (v : V) (l : list V) : list V :=
  firstn n l ++ v :: skipn (S n) l.

Definition updatex {V E} `{symE -< E} (k : exp N) (v : V) (l : list (exp N * V))
  : itree E (list (exp N * V)) :=
  n <- embed Sym__Eval (Exp__Nth k (map fst l));;
  ret (replace n (k, v) l).

Definition credit {E} `{symE -< E} (aid : exp account_id) (amount : amountT)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    let (accounts, orders) := ss in
    oa <- getx aid accounts;;
    if oa is Some (uid, ticker, x)
    then let acnt' := (uid, ticker, x + amount) in
         accounts' <- updatex aid acnt' accounts;;
         ret (accounts', orders, Response__Account (aid, acnt'))
    else ret (ss, Response__NotFound).

Definition create {E} `{symE -< E} (uid : user_id) (ticker : assetT)
  : Monads.stateT (swap_state exp) (itree E) (exp account_id) :=
  fun ss =>
    let (accounts, orders) := ss in
    xaid <- trigger Sym__Fresh;;
    ret (put xaid (uid, ticker, 0) accounts, orders, xaid).

Definition locate {E} `{symE -< E} (uid : user_id) (ticker : assetT)
  : Monads.stateT (swap_state exp) (itree E) (exp account_id) :=
  fun ss =>
    let (accounts, orders) := ss in
    if find (findAccount uid ticker) accounts is Some (aid, _)
    then ret (ss, aid)
    else create uid ticker ss.

Definition deposit {E} `{symE -< E}
           (uid : user_id) (ticker : assetT) (amount : amountT)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    if min (String.length ticker) $ N.to_nat $ N.min uid amount is O
    then ret (ss, Response__BadRequest)
    else let (accounts, orders) := ss in
         '(s1, aid) <- locate uid ticker ss;;
         credit aid amount s1.

Definition debit {E} `{symE -< E} (aid : exp account_id) (amount : amountT)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    let (accounts, orders) := ss in
    oa <- getx aid accounts;;
    if oa is Some (uid, ticker, x)
    then if amount <=? x
         then let acnt' := (uid, ticker, x - amount) in
              accounts' <- updatex aid acnt' accounts;;
              ret (accounts', orders, Response__Account (aid, acnt'))
         else ret (ss, Response__InsufficientFund)
    else ret (ss, Response__NotFound).

Definition withdraw {E} `{symE -< E}
           (uid : user_id) (ticker : assetT) (amount : amountT)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    if min (String.length ticker) $ N.to_nat $ N.min uid amount is O
    then ret (ss, Response__BadRequest)
    else let (accounts, orders) := ss in
         if find (findAccount uid ticker) accounts is Some (aid, _)
         then debit aid amount ss
         else ret (ss, Response__InsufficientFund).

Definition swap_handler E `(symE -< E) (req : swap_request id)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    let (accounts, orders) := ss in
    match req with
    | Request__Clean => ret ([], [], Response__NoContent)
    | Request__ListOrders => ret (ss, Response__ListOrders orders)
    | Request__ListAccount uid =>
      if uid is 0 then ret (ss, Response__BadRequest) else
      let acs : list (accountT exp) :=
          filter (N.eqb uid ∘ fst ∘ fst ∘ snd) accounts in
      ret (ss, Response__ListAccount acs)
    | Request__Deposit  uid ticker amount => deposit uid ticker amount ss
    | Request__Withdraw uid ticker amount => withdraw uid ticker amount ss
    | Request__MakeOrder uid bt ba st sa =>
      '(s1, r1) <- withdraw uid st sa ss;;
      if r1 is Response__Account (sid, _)
      then
        if min (String.length bt) $ N.to_nat ba is O
        then ret (ss, Response__BadRequest)
        else
          '(s2, bid) <- locate uid bt s1;;
          let (a2, o2) := s2 : swap_state exp in
           oid <- trigger Sym__Fresh;;
           let order : orderT exp := (oid, (bid, ba, sid, sa)) in
           ret (a2, order::o2, Response__Order order)
      else ret (ss, r1)
    | Request__TakeOrder uid oid =>
      if N.min uid oid is 0 then ret (ss, Response__BadRequest) else
      let coid : exp order_id := Exp__Const oid in
      oo <- getx coid orders;;
      if oo is Some (bid, ba, sid, sa)
      then
        ob <- getx bid accounts;;
        os <- getx sid accounts;;
        if (ob, os) is (Some (_, bt, _), Some (_, st, _))
        then
          '(s1, r1) <- withdraw uid bt ba ss;;
          if r1 is Response__Account _
          then
            '(s2, r2) <- credit bid ba s1;;
            if r2 is Response__Account _
            then
              '(s3, r3) <- deposit uid st sa s2;;
              ret (if r3 is Response__Account _ then s3 else ss, r3)
            else ret (ss, r2)
          else ret (ss, r1)
        else ret (ss, Response__NotFound)
      else ret (ss, Response__NotFound)
    end.

Definition swap_smi := server_smi swap_handler.


(*|
#############################
Definition by property in Coq
#############################

:Link: https://stackoverflow.com/q/30171995
|*)

(*|
Question
********

I am having trouble with formalizing definitions of the following
form: define an integer such that some property holds.

Let's say that I formalized the definition of the property:

.. code-block:: coq

    Definition IsGood (x : Z) : Prop := ...

Now I need a definition of the form:

.. code-block:: coq

    Definition Good : Z := ...

assuming that I proved that an integer with the property exists and is
unique:

.. code-block:: coq

    Lemma Lemma_GoodExistsUnique : exists! (x : Z), IsGood x.

Is there an easy way of defining ``Good`` using ``IsGood`` and
``Lemma_GoodExistsUnique``?

Since, the property is defined on integer numbers, it seems that no
additional axioms should be necessary. In any event, I don't see how
adding something like the axiom of choice can help with the
definition.

Also, I am having trouble with formalizing definitions of the
following form (I suspect this is related to the problem I described
above, but please indicate if that is not the case): for every ``x``,
there exists ``y``, and these ``y`` are different for different ``x``.
Like, for example, how to define that there are ``N`` distinct good
integer numbers using ``IsGood``:

.. code-block:: coq

    Definition ThereAreNGoodIntegers (N : Z) (IsGood : Z -> Prop) := ...?

In real-world mathematics, definitions like that occur every now and
again, so this should not be difficult to formalize if Coq is intended
to be suitable for practical mathematics.
|*)

(*|
Answer
******

The short answer to your first question is: in general, it is not
possible, but in your particular case, yes.

In Coq's theory, propositions (i.e., ``Prop``\ s) and their proofs
have a very special status. In particular, it is in general not
possible to write a choice operator that extracts the witness of an
existence proof. This is done to make the theory compatible with
certain axioms and principles, such as proof irrelevance, which says
that all proofs of a given proposition are equal to each other. If you
want to be able to do this, you need to add this choice operator as an
additional axiom to your theory, as in the `standard library
<https://coq.inria.fr/distrib/current/stdlib/Coq.Logic.Epsilon.html>`__.

However, in certain particular cases, it *is* possible to extract a
witness out of an abstract existence proof without recurring to any
additional axioms. In particular, it is possible to do this for
countable types (such as ``Z``) when the property in question is
decidable. You can for instance use the ``choiceType`` interface in
the `Ssreflect
<http://ssr.msr-inria.inria.fr/~jenkins/current/mathcomp.ssreflect.choice.html>`__
library to get exactly what you want (look for the ``xchoose``
function).

That being said, I would usually advice *against* doing things in this
style, because it leads to unnecessary complexity. It is probably
easier to define ``Good`` directly, without resorting to the existence
proof, and then prove separately that ``Good`` has the sought
property.
|*)

Require Import ZArith. (* .none *)
Definition Good : Z. (* ... *) Admitted.
Definition IsGood (z : Z) : Prop. (* ... *) Admitted.

Lemma GoodIsGood : IsGood Good.
Proof. (* ... *) Admitted.

Lemma GoodUnique : forall z : Z, IsGood z -> z = Good.
Proof. (* ... *) Admitted.

(*|
If you absolutely want to define ``Good`` with an existence proof, you
can also change the proof of ``Lemma_GoodExistsUnique`` to use a
connective in ``Type`` instead of ``Prop``, since it allows you to
extract the witness directly using the ``proj1_sig`` function:
|*)

Lemma Lemma_GoodExistsUnique :
  {z : Z | IsGood z /\ forall z', IsGood z' -> z' = z}.
Proof. (* ... *) Admitted.

(*|
As for your second question, yes, it is a bit related to the first
point. Once again, I would recommend that you write down a function
``y_from_x`` with type ``Z -> Z`` that will compute ``y`` given ``x``,
and then prove separately that this function relates inputs and
outputs in a particular way. Then, you can say that the ``y``\ s are
different for different ``x``\ s by proving that ``y_from_x`` is
injective.

On the other hand, I'm not sure how your last example relates to this
second question. If I understand what you want to do correctly, you
can write something like
|*)

Require Import List. (* .none *)
Definition ThereAreNGoodIntegers (N : Z) (IsGood : Z -> Prop) :=
  exists zs : list Z,
    Z.of_nat (length zs) = N
    /\ NoDup zs
    /\ Forall IsGood zs.

(*|
Here, ``Z.of_nat : nat -> Z`` is the canonical injection from naturals
to integers, ``NoDup`` is a predicate asserting that a list doesn't
contain repeated elements, and ``Forall`` is a higher-order predicate
asserting that a given predicate (in this case, ``IsGood``) holds of
all elements of a list.

As a final note, I would advice against using ``Z`` for things that
can only involve natural numbers. In your example, your using an
integer to talk about the cardinality of a set, and this number is
always a natural number.
|*)


(**************************************)
(**************************************)
(****                              ****)
(****   The preservation theorem   ****)
(****                              ****)
(**************************************)
(**************************************)

Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Main.SystemF.Context.
Require Import Main.SystemF.FreeVar.
Require Import Main.SystemF.Name.
Require Import Main.SystemF.OpeningSubstitution.
Require Import Main.SystemF.Semantics.
Require Import Main.SystemF.Substitution.
Require Import Main.SystemF.Syntax.
Require Import Main.SystemF.Typing.
Require Import Main.Tactics.

Theorem eSubstitutionPreservesTyping :
  forall c1 c2 e1 e2 t1 t2 x,
  hasType (cConcat (cEExtend c1 x t2) c2) e1 t1 ->
  hasType c1 e2 t2 ->
  hasType (cConcat c1 c2) (eeSub e1 x e2) t1.
Proof.
  clean. remember (cConcat (cEExtend c1 x t2) c2). outro c2.
  induction H; eSearch; clean.
  - destruct (nameEq x x0); clean.
    + pose proof (cELookupNone (cEExtend c1 x0 t2) c2 t2 x0). clean.
      pose proof (cELookupConcatLeft (cEExtend c1 x0 t2) c2 t2 x0). clean.
      assert (t = t2); search. clean. clear H3.
      replace (cConcat c1 c2) with (cConcat (cConcat c1 c2) cEmpty); search.
      apply contextWeakening; search. clean.
      apply cWellFormedESkip with (t := t2) (x := x0). search.
    + constructor.
      * apply cWellFormedESkip with (t := t2) (x := x). search.
      * clear H H0. induction c2; search.
  - apply htAbs with (l := x :: l). clean.
    specialize (H1 x0). feed H1.
    replace (
      cEExtend (cConcat c1 c2) x0 t0
    ) with (
      cConcat c1 (cEExtend c2 x0 t0)
    ); search.
    pose proof (typingRegularity c1 e2 t2).
    replace (eFreeVar x0) with (eeSub (eFreeVar x0) x e2); search.
    rewrite <- eeeeSubOpen with (it := 0); search.
  - apply htTAbs with (l := x :: l). clean.
    specialize (H1 x0). feed H1.
    replace (
      cTExtend (cConcat c1 c2) x0
    ) with (
      cConcat c1 (cTExtend c2 x0)
    ); search.
    pose proof (typingRegularity c1 e2 t2).
    rewrite <- eeetSubOpen with (ie := 0); search.
  - apply htTApp; search.
    unfold tWellFormed in *. clean. split; search.
    unfold incl in *. clean. specialize (H2 a). clean.
    rewrite tDomainConcat in *. clean. search.
Qed.

#[export] Hint Resolve eSubstitutionPreservesTyping : main.

Theorem tSubstitutionPreservesTyping :
  forall c1 c2 e t1 t2 x,
  hasType (cConcat (cTExtend c1 x) c2) e t1 ->
  tWellFormed c1 t2 ->
  hasType (cConcat c1 (cSub c2 x t2)) (etSub e x t2) (ttSub t1 x t2).
Proof.
  clean. remember (cConcat (cTExtend c1 x) c2). outro c2.
  induction H; eSearch; clean.
  - constructor.
    + apply cWellFormedTSkip; search.
    + clear H0. induction c2; invert H; search; clean.
      rewrite tttSubBound; search.
      pose proof (tWellFormedClosed c1 t x).
      feed H. apply tLookupWellFormed with (x := x0); search.
  - apply htAbs with (l := x :: l). clean.
    specialize (H1 x0). feed H1.
    replace (
      cEExtend (cConcat c1 (cSub c2 x t2)) x0 (ttSub t0 x t2)
    ) with (
      cConcat c1 (cEExtend (cSub c2 x t2) x0 (ttSub t0 x t2))
    ); search.
    unfold tWellFormed in H0.
    replace (eFreeVar x0) with (etSub (eFreeVar x0) x t2); search.
    rewrite <- eteeSubOpen; search.
    replace (
      cEExtend (cSub c2 x t2) x0 (ttSub t0 x t2)
    ) with (
      cSub (cEExtend c2 x0 t0) x t2
    ); search.
  - apply htTAbs with (l := x :: l). clean.
    specialize (H1 x0). feed H1.
    replace (
      cTExtend (cConcat c1 (cSub c2 x t2)) x0
    ) with (
      cConcat c1 (cSub (cTExtend c2 x0) x t2)
    ); search.
    unfold tWellFormed in H0.
    replace (tFreeVar x0) with (ttSub (tFreeVar x0) x t2); search.
    rewrite <- etetSubOpen; search.
    rewrite <- ttttSubOpen; search.
  - unfold tWellFormed in H0.
    rewrite ttttSubOpen; search.
    apply htTApp; search.
    unfold tWellFormed in *. clean.
    split; search.
    apply incl_tran with (
      m := tFreeVars t2 ++ remove nameEq x (tFreeVars t0)
    ); search.
    unfold incl in *. clean.
    pose proof (
      in_app_or (tFreeVars t2) (remove nameEq x (tFreeVars t0)) a H4
    ).
    clear H4. destruct H5; search.
    rewrite tDomainConcat in *.
    pose proof (nameInRemove (tFreeVars t0) a x H4). clean. clear H4.
    specialize (H3 a). feed H3.
    rewrite cSubTDomain.
    pose proof (in_app_or (tDomain c2) (x :: tDomain c1) a H3).
    destruct H4; search.
Qed.

#[export] Hint Resolve tSubstitutionPreservesTyping : main.

Theorem preservation :
  forall e1 e2 t,
  hasType cEmpty e1 t ->
  step e1 e2 ->
  hasType cEmpty e2 t.
Proof.
  clean. outro e2. remember cEmpty. induction H; search; clean.
  - invert H; search; invert H1; eSearch.
    pose proof (nameFresh (eeFreeVars e ++ l)). clean.
    specialize (H5 x). feed H5.
    rewrite eeSubIntro with (x := x); search.
    replace cEmpty with (cConcat cEmpty cEmpty); eSearch.
  - invert H0; search; invert H1; search.
    pose proof (nameFresh (etFreeVars e0 ++ tFreeVars t1 ++ l)). clean.
    specialize (H5 x). feed H5.
    rewrite etSubIntro with (x := x); search.
    rewrite ttSubIntro with (x := x); search.
    replace cEmpty with (cConcat cEmpty (cSub cEmpty x t2)); eSearch.
Qed.

#[export] Hint Resolve preservation : main.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal35.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (IHx:@eq natural (plus (mult x y) x) (mult x (Succ y))):@eq natural (plus (plus (mult x y) y) (Succ x))
  (plus (mult x (Succ y)) (Succ y)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_mult_succ_78_plus_succ/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y.
QuickChick collect_data.
Success.