(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library 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 library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Export Complex.
Require Import Cpow_plus.

Lemma Rdiv_1 : forall r : R, (r/1)%R = r.
Proof.
intros. field.
Qed.

Ltac ring_simpl1 :=
match goal with
 | id : _|- _ => (ring_simplify in id) ; generalize dependent id
end
with ring_simpl := unfold Rdiv in * ; unfold Cdiv in * ;
do 10 (try ring_simpl1) ; intros ; try ring_simplify.

Ltac apply_tactic1 := fun tactic =>
match goal with
 | id : _|- _ => (apply tactic in id)
end.

(* begin hide *)
(** Tactic CusingR2 to simplify some expressions and to go in R *)
(*
********************************************
Warning ! these tactics were written to avoid very long
normalization. It should be improved or deleted !
The reader is strongly advised not to use this tactic because
of very long computation.
********************************************
*)
Ltac CusingRR2 := simpl in * ;
try rewrite <- Ceq in * ; unfold Cdiv in * ; unfold Cconj in * ; unfold Cminus in * ;
unfold Rdiv in * ;
try rewrite Rplus_0_l ; try rewrite Rplus_0_r ;
try rewrite Cadd_0_l ; try rewrite Cadd_0_r ;
try rewrite Rmult_0_l ; try rewrite Rmult_0_r ;
try rewrite Cmult_0_l ; try rewrite Cmult_0_r ;
try rewrite Rmult_0_l ; try rewrite Rmult_0_r ;
try rewrite <- Cre_add_compat in * ;
try rewrite Cim_add_compat in * ; try rewrite Cre_INC_INR in * ;
try rewrite <- Cre_opp_compat in * ; try rewrite Cim_INC in * ;
try rewrite Cpow_Cim_0 in * ;
try rewrite Cpow_Cre_0 in * ;
try rewrite Cim_inv_INC in *
with CusingRR3 := repeat CusingRR2.

Ltac CusingR_rec2 := unfold not in *;
match goal with
(* destruct complex *)
     | id:C |- _ => destruct id ; try CusingR_rec2
(* logical destruct in goal *)
     | id: _|- _ -> _ => intros ; try CusingR_rec2
     | id: _|- _ /\ _ => split ; try CusingR_rec2
     | id: _ /\ _ |- _ => destruct id ; CusingRR3 ; try CusingR_rec2
     | id: _ \/ _ |- _ => destruct id ; CusingRR3 ; try CusingR_rec2
(* false*)
     | id: _ |- False => (apply id ; CusingR2)

     | id: _|- _ \/ _ => try ((left ; CusingR2 ; fail) || (right ; CusingR2 ; fail)) ; simpl in *
     | _ => simpl in *
end
with
CusingR2 := intros ; CusingRR3 ; CusingR_rec2 ; subst.
(* end hide *)

(** Proof of existence of a squareroot *)

(* begin hide*)
Lemma Rle_Rminus: forall a b : R, a <= b -> 0 <= b - a.
Proof.
intuition. unfold "<=" in *. elim H ; intros. left ; apply Rlt_Rminus. assumption.
right. rewrite H0. ring.
Qed.

Lemma Croot_sqrt_pos : forall a b : R, 0 <= (sqrt (a * a + b * b) - a) / 2.
Proof.
intros.
unfold Rdiv. replace 0%R with (0 * /2)%R by field. apply Rmult_le_compat_r.
fourier. apply Rle_Rminus.
apply Rle_trans with (Rabs a).
split_Rabs. fourier. intuition.
apply Rsqr_incr_0_var. rewrite Rsqr_sqrt.
rewrite <- Rsqr_abs. replace (Rsqr a) with (a * a)%R by intuition.
replace (a * a)%R with ((a * a) + 0)%R by intuition.
rewrite Rplus_assoc. apply Rplus_le_compat_l.
replace (0 + b * b)%R with (Rsqr b) by intuition.
intuition. apply (Cnorm_sqr_pos a b). apply sqrt_positivity.
apply (Cnorm_sqr_pos a b).
Qed.

Lemma Croot_sqrt_pos_plus : forall a b : R, 0 <= (sqrt (a * a + b * b) + a) / 2.
Proof.
intros.
unfold Rdiv. replace 0%R with (0 * /2)%R by field. apply Rmult_le_compat_r.
fourier. replace a with (--a)%R by intuition. apply Rle_Rminus.
apply Rle_trans with (Rabs a).
split_Rabs. fourier. intuition. fourier.
replace (--a)%R with a by intuition.
apply Rsqr_incr_0_var. rewrite Rsqr_sqrt.
rewrite <- Rsqr_abs. replace (Rsqr a) with (a * a)%R by intuition.
replace (a * a)%R with ((a * a) + 0)%R by intuition.
rewrite Rplus_assoc. apply Rplus_le_compat_l.
replace (0 + b * b)%R with (Rsqr b) by intuition.
intuition. apply (Cnorm_sqr_pos a b). apply sqrt_positivity.
apply (Cnorm_sqr_pos a b).
Qed.

Lemma sqrt_square2 : forall a : R, (a >= 0 -> (sqrt a) ^ 2 = a)%R.
Proof.
intros.
simpl. rewrite Rmult_1_r. apply sqrt_sqrt. intuition.
Qed.
(* end hide *)

Lemma Croot_pol_2 : forall z : C, {z1 | z1 ^ 2 = z}.
Proof.
intros.
destruct z as (a, b).
destruct (Rlt_le_dec b 0).
(* case b < 0 *)
exists (sqrt ( (sqrt ( a * a + b * b) + a)/2),
- sqrt ( (sqrt ( a * a + b * b) - a)/2))%R.
CusingR_simpl ; ring_simplify.
(* real part *)
repeat rewrite sqrt_square2. field. destruct (Croot_sqrt_pos a b). intuition. intuition.
destruct (Croot_sqrt_pos_plus a b). intuition. intuition.
(* imaginary part *)
rewrite Rmult_assoc. rewrite <- sqrt_mult.
field_simplify ((sqrt (a * a + b * b) + a) / 2 * ((sqrt (a * a + b * b) - a) / 2))%R.
rewrite sqrt_square2. field_simplify ((a * a + b * b - a ^ 2) / 4)%R.
unfold Rdiv. replace (/4)%R with (/2 * /2)%R by field. rewrite sqrt_mult.
replace (sqrt (/2 * /2))%R with (/2)%R by (rewrite sqrt_square ; try reflexivity ; fourier).
replace (b ^ 2)%R with (-b * -b)%R by ring. rewrite sqrt_square.
field. fourier.
replace (b ^ 2)%R with (Rsqr b) by (simpl ; rewrite Rmult_1_r ; intuition).
intuition. fourier. apply Rle_ge . apply (Cnorm_sqr_pos a b).
apply Croot_sqrt_pos_plus. apply Croot_sqrt_pos.
(* case b >= 0 *)
exists (sqrt ( (sqrt ( a * a + b * b) + a)/2),
sqrt ( (sqrt ( a * a + b * b) - a)/2))%R.
CusingR_simpl ; ring_simplify.
(* real part *)
repeat rewrite sqrt_square2. field.
apply Rle_ge. apply Croot_sqrt_pos.
apply Rle_ge. apply Croot_sqrt_pos_plus.
(* imaginary part *)
rewrite Rmult_assoc.
repeat rewrite <- sqrt_mult.
field_simplify ((sqrt (a * a + b * b) + a) / 2 * ((sqrt (a * a + b * b) - a) / 2))%R.
repeat rewrite sqrt_square2.
field_simplify ((a * a + b * b - a ^ 2) / 4)%R.
unfold Rdiv. replace (/4)%R with (/2 * /2)%R by field. rewrite sqrt_mult.
replace (sqrt (/2 * /2))%R with (/2)%R by (rewrite sqrt_square ; try reflexivity ; fourier).
replace (b ^ 2)%R with (b * b)%R by ring. rewrite sqrt_square.
field. fourier.
replace (b ^ 2)%R with (Rsqr b) by (simpl ; rewrite Rmult_1_r ; intuition).
intuition. fourier. apply Rle_ge . apply (Cnorm_sqr_pos a b).
apply Croot_sqrt_pos_plus. apply Croot_sqrt_pos.
Qed.

(* begin hide*)
Lemma sum_f_R0_eq_seq : forall (n : nat) (f g : nat -> R),
        (forall m : nat, (m <= n)%nat -> f m = g m) ->
	sum_f_R0 f n = sum_f_R0 g n.
Proof.
intros n f g H.
induction n.
simpl. apply H. intuition.
simpl. rewrite IHn. rewrite H with (S n). reflexivity. intuition. intros m H2. apply H. intuition.
Qed.

Lemma Cnorm_sqr_real : forall r9 r10,
(r9 +i r10) <> 0 ->
((r9 + r9) * (r9 + r9) + (r10 + r10) * (r10 + r10))%R <> 0%R.
Proof.
intros a b H Habs.
apply (HC0_norm_R0 ((a + a)%R +i (b + b)%R)) in Habs.
apply H. replace ((a + a)%R +i (b + b)%R) with ((2 +i 0%R) * (a +i b)) in Habs by CusingR_f.
apply Cmult_integral in Habs. destruct Habs ;
assert (H1 : (2 +i 0%R) = 0 -> False) ; CusingR2 ; (fourier || intuition).
Qed.

Lemma Rpow_2_inf_0 : forall x, (x^2 < 0 -> False)%R.
Proof.
intros.
replace (x ^ 2)%R with (Rsqr x) in * by (unfold Rsqr ; simpl ; ring).
assert (Rsqr x >= 0) by (auto with real).
fourier.
Qed.

Lemma Rpow_2_opp_inf_0 : forall x, (-x^2 > 0 -> False)%R.
Proof.
intros.
replace (x ^ 2)%R with (Rsqr x) in * by (unfold Rsqr ; simpl ; ring).
assert (Rsqr x >= 0) by (auto with real).
fourier.
Qed.
(* end hide*)

(** Equality to 0 of a polynom of degree one *)

Lemma Pol_degree_1 : forall a b, (forall x, a * x + b = 0) -> (a = 0 /\ b = 0).
Proof.
intros.
assert (H1 : (a * 0 + b = 0)).
apply H.
assert (H2 : (a * 1 + b = 0)).
apply H.
rewrite Cmult_0_r in H1.
rewrite Cmult_1_r in H2.
rewrite Cadd_0_l in H1.
subst. rewrite Cadd_0_r in H2.
subst.
intuition.
Qed.

(** Unicicty of roots of a polynom of degree two*)

Lemma Cpol_2_root_unicity : forall x1 x2 x3 x4,
(forall x, (x + x1) * (x + x2) = (x + x3) * (x + x4)) ->
(x1 = x3 /\ x2 = x4) \/ (x1 = x4 /\ x2 = x3).
Proof.
intros x1 x2 x3 x4 H.
assert (H1 : (forall x : C, (x + x1) * (x + x2) = (x + x3) * (x + x4)) ->
(forall x, (x1 + x2 - x3 - x4) * x + x1 * x2 - x3 * x4 = 0)).
intros H0 x.
assert (H1 : ((x + x1) * (x + x2) = (x + x3) * (x + x4) ->
(x1 + x2 - x3 - x4) * x + x1 * x2 - x3 * x4 = 0)).
intros H1.
apply Cminus_diag_eq in H1. ring_simplify in H1.
repeat rewrite <- Cmult_add_distr_l in H1.
repeat rewrite <- Cmult_minus_distr_l in H1.
rewrite Cmult_comm in H1.
assumption.
apply H1. apply H0.
assert (H2 : (x1 + x2 - x3 - x4 = 0 /\ x1 * x2 - x3 * x4 = 0)).
apply Pol_degree_1.
intros x.
replace ((x1 + x2 - x3 - x4) * x + (x1 * x2 - x3 * x4)) with
((x1 + x2 - x3 - x4) * x + x1 * x2 - x3 * x4) by ring.
apply H1.
intros x0.
apply H.
destruct H2 as [H0 H2].
assert (H3 : ((-x1 + x1) * (-x1 + x2) = (-x1 + x3) * (-x1 + x4))).
apply H.
assert (H4 : ((-x2 + x1) * (-x2 + x2) = (-x2 + x3) * (-x2 + x4))).
apply H. rewrite Cadd_opp_l in *.
(* From this point we do all in parallel *)
destruct (Ceq_dec x2 x1) ;
rewrite Cmult_0_l in *; rewrite Cmult_0_r in * ;
symmetry in H3 ; symmetry in H4 ;
apply Cmult_integral in H3 ; apply Cmult_integral in H4 ;
destruct H3 as [H3|H3] ; destruct H4 as [H4|H4] ;
rewrite Cadd_comm in * ; apply Cminus_diag_uniq in H3 ;
apply Cminus_diag_uniq in H4 ; subst ; ring_simpl ; intuition.
Qed.

(** Solve a polynom of degree two in the Complex field as a function of delta *)
Lemma Cpol_d_2 : forall a b c delta, (delta = b^2 - 4*a * c) ->
a <> 0 -> Cim a = 0%R -> Cim b = 0%R -> Cim c = 0%R ->
exists x1, exists x2, forall x,
a * x ^ 2 + b * x + c =  a * (x + x1) * (x + x2)
/\ ((Cim delta) = 0%R /\ Cre delta > 0%R -> Cim x1 = 0%R /\ Cim x2 = 0%R)
/\ ((Cim delta) = 0%R /\ Cre delta < 0%R -> Cim x1 <> 0%R /\ Cim x2 <> 0%R)
/\ ((Cim delta) = 0%R /\ Cre delta = 0%R -> x1 = x2 /\ Cim x1 = 0%R).
Proof.
intros a b c delta Hdelta Ha Hima Himb Himc.
destruct (Croot_pol_2 delta) as [delta1 Hsquare].
exists (( b / (a + a) - delta1 / (a + a))).
exists (( b / (a + a) + delta1 / (a + a))).
intros x.
repeat split. unfold Cdiv. ring_simplify.
rewrite Hsquare. rewrite Hdelta.
unfold Cminus. repeat rewrite Cadd_assoc.
apply Cadd_eq_compat_l.
ring_simplify. rewrite Rplus_0_l.
assert (H : (2 * 2 = 4)) by (CusingR_simpl ; ring).
rewrite <- H. replace (2, 0%R) with (IRC 2) by (reflexivity).
replace (a + a) with (2 * a) by (CusingR_simpl ; ring).
field. split. assumption. intro H0. rewrite <- Ceq in H0. simpl in H0.
destruct H0. assert (2 <> 0)%R by discrR. intuition.
CusingR2. ring_simpl.
generalize H2. intro H3.
(apply Rmult_integral in H3 ; destruct H3 as [H3|H3]).
(apply Rmult_integral in H3 ; destruct H3 as [H3|H3]).
fourier.
rewrite H3 in *. rewrite <- H1 in H0. ring_simpl.
apply Rpow_2_opp_inf_0 in H0. destruct H0.
rewrite H3. ring.
CusingR2. ring_simpl.
(apply Rmult_integral in H2 ; destruct H2 as [H2|H2]).
(apply Rmult_integral in H2 ; destruct H2 as [H2|H2]).
fourier. rewrite H2 in H1. rewrite <- H1 in H0. ring_simpl.
apply Rpow_2_opp_inf_0 in H0. destruct H0.
rewrite H2. ring.
CusingR2. ring_simpl.
apply Rmult_integral in H0 ; destruct H0 as [H0|H0].
apply Rmult_integral in H0 ; destruct H0 as [H0|H0].
apply Rmult_integral in H0 ; destruct H0 as [H0|H0].
fourier.
apply Rinv_neq_0_compat in H0. destruct H0.
intro H8. ring_simplify in H8. apply Rmult_integral in H8. destruct H8 as [H8|H8].
fourier.
replace (r9 ^ 2)%R with (Rsqr r9) in H8 by (unfold Rsqr ; simpl ; ring).
assert (H5 : (r9 = 0)%R). apply Rsqr_0_uniq ; assumption.
rewrite H5 in *. apply Ha. split ; reflexivity.
assumption.
rewrite H0 in *. ring_simpl. rewrite <- H2 in H1.
apply Rpow_2_inf_0 in H1. destruct H1. reflexivity.
CusingR2. ring_simpl.
apply Rmult_integral in H0 ; destruct H0 as [H0|H0].
apply Rmult_integral in H0 ; destruct H0 as [H0|H0].
apply Rmult_integral in H0 ; destruct H0 as [H0|H0].
fourier.
apply Rinv_neq_0_compat in H0. destruct H0.
intro H8. ring_simplify in H8. apply Rmult_integral in H8. destruct H8 as [H8|H8].
fourier.
replace (r9 ^ 2)%R with (Rsqr r9) in H8 by (unfold Rsqr ; simpl ; ring).
assert (H5 : (r9 = 0)%R). apply Rsqr_0_uniq ; assumption.
rewrite H5 in *. apply Ha. split ; reflexivity.
assumption.
rewrite H0 in *. ring_simpl. rewrite <- H2 in H1.
apply Rpow_2_inf_0 in H1. destruct H1.
reflexivity. unfold Cminus. apply Cadd_eq_compat_l.
assert (H0 : (delta = 0)) by (rewrite <- Ceq ; intuition).
rewrite H0 in *.
assert (H1 : delta1 = 0). simpl in Hsquare. rewrite Cmult_1_r in Hsquare.
apply Cmult_integral in Hsquare. destruct Hsquare ; assumption.
rewrite H1. unfold Cdiv. ring.
CusingR2. ring_simpl.
apply Rmult_integral in H2 ; destruct H2 as [H2|H2].
apply Rmult_integral in H2 ; destruct H2 as [H2|H2].
fourier.
rewrite H2 in *. ring_simplify in H1.
rewrite <- H1 in H0. replace (r2 ^ 2)%R with (Rsqr r2) in H0 by (unfold Rsqr ; simpl ; ring).
assert (H10 : (r2 = 0)%R). apply Rsqr_0_uniq. apply Ropp_eq_0_compat in H0.
ring_simplify in H0. assumption.
rewrite H10 in *. ring.
rewrite H2 in *. ring.
Qed.

(** Real properties that can be deduced from the resolution of a complex polynom*)
Lemma Cpol_2_real_delta_pos : forall a b c delta, ((delta = b^2 - 4*a * c ) ->
delta > 0 -> a <> 0 ->
exists x1, exists x2, forall x,
a * x ^ 2 + b * x + c =  a * (x + x1) * (x + x2))%R.
Proof.
intros a b c delta deltadef Hdelta Ha.
destruct (Cpol_d_2 (a +i 0%R) (b +i 0%R) (c +i 0%R) (delta +i 0%R)) as [x1 [x2 H1]].
CusingR2.
ring.
ring.
CusingR2.
reflexivity.
CusingR2.
reflexivity.
CusingR2.
reflexivity.
CusingR2.
reflexivity.
exists (Cre x1). exists (Cre x2).
assert (HRtoC : (forall x, Cre ((a +i 0%R) * (x +i 0%R) ^ 2 + (b +i 0%R) * (x +i 0%R) + (c +i  0%R)) =
Cre ((a +i 0%R) * ((x +i 0%R) + x1) * ((x +i 0%R) + x2)))).
intros x.
apply Cre_eq_compat. generalize (H1 (x +i 0%R)). intro H0.
destruct H0 as [H2 [H3 [H4 H5]]].
 apply H2.
intros x.
generalize (H1 (x +i 0%R)). intro H0.
destruct H0 as [H2 [H3 [H4 H5]]].
assert (HCroot : (Cim x1 = 0%R /\ Cim x2 = 0%R)). apply H3. simpl. split. reflexivity. assumption.
CusingR2. ring_simpl. assumption.
Qed.

Lemma Cpol_2_real_delta_eq_0 : forall a b c delta, ((delta = b^2 - 4*a * c) ->
delta = 0 -> a <> 0 ->
exists x1, exists x2, forall x,
a * x ^ 2 + b * x + c =  a * (x + x1) * (x + x2))%R.
Proof.
intros a b c delta deltadef Hdelta Ha.
destruct (Cpol_d_2 (a +i 0%R) (b +i 0%R) (c +i 0%R) (delta +i 0%R)) as [x1 [x2 H1]].
CusingR2.
ring.
ring.
CusingR2.
reflexivity.
CusingR2.
reflexivity.
CusingR2.
reflexivity.
CusingR2.
reflexivity.
exists (Cre x1). exists (Cre x2).
assert (HRtoC : (forall x, Cre ((a +i 0%R) * (x +i 0%R) ^ 2 + (b +i 0%R) * (x +i 0%R) + (c +i  0%R)) =
Cre ((a +i 0%R) * ((x +i 0%R) + x1) * ((x +i 0%R) + x2)))).
intros x.
apply Cre_eq_compat. generalize (H1 (x +i 0%R)). intro H0.
destruct H0 as [H2 [H3 [H4 H5]]].
 apply H2.
intros x.
generalize (H1 (x +i 0%R)). intro H0.
destruct H0 as [H2 [H3 [H4 H5]]].
assert (HCroot : (x1 = x2 /\ Cim x1 = 0%R)). apply H5. simpl. split. reflexivity. assumption.
CusingR2. subst. ring_simpl. assumption.
Qed.

Lemma Cpol_2_real_delta_eq_neg : forall a b c delta, ((delta = b^2 - 4*a * c) ->
delta < 0 -> a <> 0 ->
~ (exists x1, exists x2, forall x,
a * x ^ 2 + b * x + c =  a * (x + x1) * (x + x2)))%R.
Proof.
intros a b c delta deltadef Hdelta Ha.
destruct (Cpol_d_2 (a +i 0%R) (b +i 0%R) (c +i 0%R) (delta +i 0%R)) as [x1 [x2 H1]].
CusingR2.
ring.
ring.
CusingR2.
reflexivity.
CusingR2.
reflexivity.
CusingR2.
reflexivity.
CusingR2.
reflexivity.
intro H.
destruct H as (x3, H) . destruct H as (x4, H).
assert (forall x : C, (a +i 0%R) * x ^ 2 + (b +i  0%R) * x + (c +i  0%R) =
     (a +i 0%R) * (x + x1) * (x + x2)).
intro x.
generalize (H1 x). intros H0.
destruct H0 as [H2 [H3 [H4 H5]]].
apply H2.
assert (H10 : forall x : C, (a +i 0%R) * x ^ 2 + (b +i  0%R) * x + (c +i  0%R) =
     (a +i 0%R) * (x + (x3 +i 0%R)) * (x + (x4 +i 0%R))).
intros x.
destruct x as (r, r0).
rewrite <- Ceq. split.
simpl. ring_simplify.
generalize (H r). intro H15. ring_simplify in H15.
replace (a * r ^ 2 - a * r0 ^ 2 + r * b + c)%R with ((a * r ^ 2 + r * b + c) - a* r0^2)%R by ring.
rewrite H15. ring.
simpl. ring_simplify.
generalize (H 1%R). intro H15. ring_simplify in H15.
generalize (H 0%R). intro H16. ring_simplify in H16.
rewrite <- H16 in H15. ring_simplify in H15.
rewrite <- Rmult_plus_distr_l in H15.
rewrite Rplus_comm in H15. symmetry in H15. rewrite Rplus_comm in H15.
apply Rplus_eq_reg_l in H15. rewrite Rplus_comm in H15.
apply Rplus_eq_reg_l in H15.
rewrite <- H15. ring.
assert (Htra :  (x1 = (x3 +i 0%R) /\ x2 = (x4 +i 0%R) \/ x1 = (x4 +i 0%R) /\ x2 = (x3 +i 0%R))).
assert (forall x : C, (x + (x3 +i 0%R)) * (x + (x4 +i 0%R))  = (x + x1) * (x + x2)).
intro x. apply Cmult_eq_reg_l with (a +i 0%R).
CusingR2. reflexivity. generalize (H0 x). generalize (H10 x).
intros abs1 abs2.
ring_simplify in abs1 ; ring_simplify in abs2 ; ring_simplify.
rewrite <- abs1. rewrite abs2. reflexivity.
apply Cpol_2_root_unicity.
intros x. rewrite H2. reflexivity.
generalize (H1 0). intros Hdeltas.
destruct Hdeltas as [H2 [H3 [H4 H5]]].
clear H3 H5 H2.
assert (Habss : (Cim x1 <> 0%R /\ Cim x2 <> 0%R)).
apply H4. intuition. clear H4.
destruct Habss as (Habss1, Habss2).
destruct Htra as [[Htra1 Htra2]|[Htra1 Htra2]].
rewrite <- Ceq in Htra1.
destruct Htra1 as (Htra1, Htraabs).
simpl in Htraabs.
apply Habss1. assumption.
rewrite <- Ceq in Htra1.
destruct Htra1 as (Htra1, Htraabs).
simpl in Htraabs.
apply Habss1. assumption.
Qed.

Lemma Cfpol_root : forall a b c delta, ((delta = b^2 - 4*a * c) ->
delta >= 0 -> a <> 0 -> exists x, a * x ^ 2 + b * x + c = 0)%R.
Proof.
intros a b c delta Hdelta deltapos Ha.
destruct deltapos.
destruct (Cpol_2_real_delta_pos a b c delta) as [x H0].
assumption. assumption. assumption.
destruct H0 as (x1, H0).
exists (-x1)%R. rewrite H0. ring.
destruct (Cpol_2_real_delta_eq_0 a b c delta) as [x2 H5].
assumption. assumption. assumption.
destruct H5 as (x1, H0).
exists (-x1)%R. rewrite H0. ring.
Qed.

Lemma Cpol_pos : forall a b c delta, (delta = b^2 - 4*a * c)%R ->
 a <> 0%R ->
(forall x, 0 <> a*x*x+b*x+c)%R -> delta < 0%R.
intros a b c delta Hdelta Ha.
intro Hpoly.
destruct (total_order_T delta 0) as [[H|H]|H].
assumption.
destruct (Cfpol_root a b c delta).
assumption. intuition. assumption.
destruct (Hpoly x). ring_simplify. symmetry.
ring_simplify in H0. assumption.
destruct (Cfpol_root a b c delta).
assumption. intuition. assumption.
destruct (Hpoly x). ring_simplify. symmetry.
ring_simplify in H0. assumption.
Qed.

Lemma Pos_poly_del : forall a b c : R,
a <> 0%R -> a > 0%R -> (forall x, 0 <= a*x*x+b*x+c) -> b^2 - 4*a*c <=0.
Proof.
intros a b c Ha Haa Hpoly.
pose ( b^2 - 4*a*c)%R as delta.
destruct (total_order_T delta 0) as [[H|H]|H].
intuition. intuition.
destruct (Cfpol_root a b c delta).
reflexivity.
intuition.
assumption.
assert (H1 : (exists x1, exists x2, forall x,
a * x ^ 2 + b * x + c =  a * (x + x1) * (x + x2))%R).
apply Cpol_2_real_delta_pos with delta.
ring_simplify.
reflexivity.
assumption.
assumption.
destruct H1 as [x1 [x2 H1]].
assert (H9 : (0 > a * ( -(x1 + x2)/2 + x1) * ( - (x1 + x2)/2 + x2))%R).
replace ((- (x1 + x2) / 2 + x1))%R with ((x1 - x2) /2)%R by field.
replace ((- (x1 + x2) / 2 + x2))%R with (-(x1 - x2) /2)%R by field.
replace (a * ((x1 - x2) / 2) * (- (x1 - x2) / 2))%R with ( ((x1 - x2) / 2)^2 * (-a))%R by field.
replace 0%R with (  ((x1 - x2) / 2) ^ 2 * 0 )%R by ring.
apply Rmult_gt_compat_l.
assert (H10 : (x1 <> x2)).
intro H11. rewrite H11 in H1.
assert ((a * 0 ^ 2 + b * 0 + c)%R = (a * (0 + x2) * (0 + x2)))%R.
apply H1.
assert ((a * 1 ^ 2 + b * 1 + c)%R = (a * (1 + x2) * (1 + x2)))%R.
apply H1.
ring_simpl.
rewrite <- H2 in H3. unfold delta in H.
replace (a + b + c)%R with (c + a + b)%R in H3 by ring.
replace (c + 2 * a * x2 +a)%R with (c + a + 2 * a * x2)%R in H3 by ring.
apply Rplus_eq_reg_l in H3. subst.
replace ((2 * a * x2) ^ 2 - 4 * a * (a * x2 ^ 2))%R with (0)%R in H by ring .
fourier.
replace (((x1 - x2) / 2) ^ 2)%R with (Rsqr (((x1 - x2) / 2))) by (unfold Rsqr ; simpl ; ring).
apply Rlt_0_sqr.
intro H30. replace 0%R with (0/2)%R in H30 by field.
unfold Rdiv in *. rewrite Rmult_comm in H30.
symmetry in H30. rewrite Rmult_comm in H30.
apply Rmult_eq_reg_l in H30.
apply H10. symmetry in H30. auto with *.
apply Rinv_neq_0_compat.
discrR.
intuition.
assert ( 0 <= a * (- (x1 + x2) / 2 + x1) * (- (x1 + x2) / 2 + x2)).
rewrite <- H1. replace ( (- (x1 + x2) / 2) ^ 2)%R with ((- (x1 + x2) / 2) * (- (x1 + x2) / 2) )%R by ring.
rewrite <- Rmult_assoc. apply Hpoly.
fourier.
Qed.

Require Import Cpolar.
Require Import Cexp.

Open Scope C_scope.

Lemma ast_fun_pos : forall n r, (n > 0)%nat -> r > 0 -> (r + 1) ^ n - r > 0.
Proof.
intros n r Hn Hr.
induction Hn.
simpl. ring_simplify. fourier.
simpl. rewrite Rmult_plus_distr_r. replace 0%R with (0 + 0)%R by intuition.
unfold Rminus. rewrite Rplus_assoc. apply Rplus_lt_compat.
apply Rmult_gt_0_compat.
assumption.
apply pow_lt. fourier.
rewrite Rmult_1_l. apply IHHn.
Qed.

(** ** Every positive real has a n root *)
Lemma exist_root_n_pos : forall r n, r >= 0 -> (n > 0)%nat -> {root | root ^ n = r}%R.
Proof.
intros r n Hr Hn.
pose (f := (fun x => x ^ n - r)%R).
assert (Cont_pow : forall x, continuity_pt f x).
unfold f. intros x. reg.
destruct (total_order_T r 0) as [[order|order]|order].
fourier.
exists 0. rewrite order.
rewrite pow_ne_zero. reflexivity.
intuition.
assert (Hsup0 : r+1 > 0) by fourier.
assert (Hpos : forall n, (n > 0)%nat -> (r + 1) ^ n - r > 0).
 intros n1 Hn1. apply ast_fun_pos. assumption. assumption.
assert (Hneg : 0 ^ n - r < 0). rewrite pow_ne_zero. fourier.
 intuition.

generalize (IVT (fun x => x ^ n - r) 0 (r + 1) Cont_pow Hsup0 Hneg)%R.

intros H. destruct H as (x, H).
apply Hpos. assumption.
exists  x. intuition.
Qed.

(** ** Every complex has a n root *)

Lemma exist_root_n : forall n z, (n > 0)%nat -> {root | root ^ n = z}.
Proof.
intros n z Hn.
destruct (polar z) as [r [theta Hrt]].
destruct Hrt as [Hrpos [Htheta Hpol]].
rewrite Cmult_IRC_compat_l in Hpol.
rewrite <- Cexp_trigo_compat in Hpol.
destruct (exist_root_n_pos r n Hrpos) as (root_real, Hreal).
apply Hn.
exists ( root_real * Cexp ((0 +i theta ) / INC n)).
rewrite Cpow_mul_distr_l.
rewrite IRC_pow_compat. rewrite Hreal. rewrite <- Cexp_mult.
field_simplify (INC n * ((0 +i  theta) / INC n)).
unfold Cdiv. rewrite Cinv_1. rewrite Cmult_1_r.
apply Hpol.
apply not_0_INC. intuition.
Qed.


From Hammer Require Import Hammer.

Require Export RegExp.Utility.
Require Export RegExp.Definitions.

Lemma Empty_false : forall s, Empty ~!= s.
Proof. hammer_hook "Boolean" "Boolean.Empty_false".
induction s.
reflexivity.
simpl.  apply IHs.
Qed.

Lemma Eps_true : Eps ~== EmptyString.
Proof. hammer_hook "Boolean" "Boolean.Eps_true".
simpl.  reflexivity.
Qed.

Lemma Eps_false : forall s, s <> ""%string -> Eps ~!= s.
Proof. hammer_hook "Boolean" "Boolean.Eps_false".
induction s.
intro Hs. elim Hs. auto.
intro Has. simpl. eapply Empty_false.
Qed.

Add Parametric Morphism : Or with
signature re_eq ==> re_eq ==> re_eq as Or_morphism.
Proof.
intros x y H x0 y0 H0.  unfold re_eq in *.  intro s.
generalize dependent x.  generalize dependent y.
generalize dependent x0. generalize dependent y0.
induction s.

intros y0 x0 H0 y x H.  specialize (H0 ""%string).  specialize (H ""%string).
simpl in *.  rewrite <- H0.  rewrite <- H.  reflexivity.

simpl.  intros y0 x0 H0 y x H.  eapply IHs.
intros.  repeat rewrite <- derivation.  eapply H0.
intros.  repeat rewrite <- derivation.  eapply H.
Qed.

Add Parametric Morphism : And with
signature re_eq ==> re_eq ==> re_eq as And_morphism.
Proof.
intros x y H x0 y0 H0.  unfold re_eq in *.  intros s.
generalize dependent x.  generalize dependent y.
generalize dependent x0. generalize dependent y0.
induction s.

intros y0 x0 H0 y x H.  specialize (H0 ""%string).  specialize (H ""%string).
simpl in *.  rewrite <- H0.  rewrite <- H.  reflexivity.

simpl.  intros y0 x0 H0 y x H.  eapply IHs.
intros s0.  repeat rewrite <- derivation.  eapply H0.
intros s0.  repeat rewrite <- derivation.  eapply H.
Qed.

Add Parametric Morphism : Not with
signature re_eq ==> re_eq as Not_morphism.
Proof.
intros x y H.  unfold re_eq in *.  intros s.
generalize dependent x. generalize dependent y.
induction s.

intros y x H.  specialize (H ""%string).  simpl in *.  rewrite <- H.  reflexivity.

simpl.  intros y x H.  eapply IHs.
intros s0.  repeat rewrite <- derivation.  eapply H.
Qed.

Lemma matches_Or : forall s r r',  r || r' ~= s = ((r ~= s) || (r' ~= s))%bool.
Proof. hammer_hook "Boolean" "Boolean.matches_Or".
induction s.
simpl.  reflexivity.
simpl.  intros r r'.  eapply IHs.
Qed.

Lemma matches_And : forall s r r',  matches (And r r') s = ((r ~= s) && (r' ~= s))%bool.
Proof. hammer_hook "Boolean" "Boolean.matches_And".
induction s.
simpl.  reflexivity.
simpl.  intros.  eapply IHs.
Qed.

Lemma matches_Not : forall s r,  (Not r) ~= s = negb (r ~= s).
Proof. hammer_hook "Boolean" "Boolean.matches_Not".
induction s.
simpl.  reflexivity.
simpl.  intros.  eapply IHs.
Qed.

Lemma Or_comm_s : forall s r r', (r || r') ~= s = (r' || r) ~= s.
Proof. hammer_hook "Boolean" "Boolean.Or_comm_s".
intros s r r'.  repeat erewrite matches_Or.
destruct (r ~= s); destruct (r' ~= s); reflexivity.
Qed.

Theorem Or_comm : forall r r', r || r' =R= r' || r.
Proof. hammer_hook "Boolean" "Boolean.Or_comm".
unfold re_eq.  intros r r' s.  eapply Or_comm_s.
Qed.

Lemma Or_assoc_s : forall s r r' r'',
((r || r') || r'') ~= s = (r || (r' || r'')) ~= s.
Proof. hammer_hook "Boolean" "Boolean.Or_assoc_s".
intros.   repeat erewrite matches_Or.
destruct (r ~= s); destruct (r' ~= s); destruct (r'' ~= s); reflexivity.
Qed.

Theorem Or_assoc : forall r r' r'', (r || r') || r'' =R= r || (r' || r'').
Proof. hammer_hook "Boolean" "Boolean.Or_assoc".
unfold re_eq.  intros r r' r'' s.  eapply Or_assoc_s.
Qed.

Lemma And_comm : forall r r', And r r' =R= And r' r.
Proof. hammer_hook "Boolean" "Boolean.And_comm".
unfold re_eq.  intros r r' s.  repeat erewrite matches_And.
destruct (r ~= s); destruct (r' ~= s); reflexivity.
Qed.

Lemma And_assoc : forall r r' r'', And (And r r') r'' =R= And r (And r' r'').
Proof. hammer_hook "Boolean" "Boolean.And_assoc".
unfold re_eq.  intros r r' r'' s.  repeat erewrite matches_And.
destruct (r ~= s); destruct (r' ~= s); destruct (r'' ~= s); reflexivity.
Qed.

Lemma Or_left_id_s : forall s r, (Empty || r) ~= s = r ~= s.
Proof. hammer_hook "Boolean" "Boolean.Or_left_id_s".
induction s.
simpl.  reflexivity.
simpl.  intros r.  eapply IHs.
Qed.

Theorem Or_left_id : forall r, Empty || r =R= r.
Proof. hammer_hook "Boolean" "Boolean.Or_left_id".
unfold re_eq.  intros r s.  eapply Or_left_id_s.
Qed.

Theorem Or_right_id : forall r, r || Empty =R= r.
intros.  setoid_rewrite Or_comm.
eapply Or_left_id.
Qed.

Corollary Or_right_id_s : forall s r, (r || Empty) ~= s = r ~= s.
Proof. hammer_hook "Boolean" "Boolean.Or_right_id_s".
intros s r.  specialize Or_right_id.
intros H.  unfold re_eq in H.  eapply H.
Qed.

Lemma Or_idem_s : forall s r, (r || r) ~= s = r ~= s.
Proof. hammer_hook "Boolean" "Boolean.Or_idem_s".
intros s r.  erewrite matches_Or.  destruct (r ~= s); reflexivity.
Qed.

Theorem Or_idem : forall r, r || r =R= r.
Proof. hammer_hook "Boolean" "Boolean.Or_idem".
unfold re_eq.  intros r s.  eapply Or_idem_s.
Qed.


From Coq Require Import
     Arith Lia (* nia *)
     Morphisms
.

From ExtLib Require Import
     Data.String
.

From ITree Require Import
     Axioms
     ITree
     ITreeFacts
     Events.MapDefault
     Events.State
     Events.StateFacts
     Props.Infinite.

From ITree.Extra Require Import
     Dijkstra.DijkstraMonad
     Dijkstra.PureITreeBasics
     Dijkstra.IterRel
     Dijkstra.DelaySpecMonad
     Dijkstra.StateSpecT
     Dijkstra.StateDelaySpec
.

From Paco Require Import paco.

From hoare Require Import Imp.

Import Monads.
Import MonadNotation.
Import ImpNotations.
#[local] Open Scope monad_scope.
#[local] Open Scope itree_scope.
#[local] Open Scope imp_scope.

Definition denote_imp (c : com) : stateT env Delay unit :=
  interp_imp (denote_com c).

Definition hoare_triple (P Q : env -> Prop) (c : com) : Prop :=
  forall (s s' :env), P s -> (denote_imp c s ≈ ret (s',tt)) -> Q s'.

Definition lift_imp_post (P : env -> Prop) : Delay (env * unit) -> Prop :=
  fun (t : Delay (env * unit) ) => (exists (s : env), ret (s, tt) ≈ t /\ P s).

Notation "{{ P }} c {{ Q }}" := (hoare_triple P Q c) (at level 70).

Definition is_bool (E : Type -> Type) (bc : bool) (be : bexp) (s : env) : Prop :=
   @interp_imp E bool (denote_bexp be) s ≈ ret (s, bc).

Definition is_true (b : bexp) (s : env) : Prop :=
  is_bool void1 true b s.

Definition is_false  (b : bexp) (s : env) : Prop :=
  is_bool void1 false b s.

(*
Ltac unf_intep := unfold interp_imp, interp_map, interp_state, interp, Basics.iter, MonadIter_stateT0, interp, Basics.iter, MonadIter_stateT0.
*)

Lemma aexp_term : forall (E : Type -> Type) (ae : aexp) (s : env),
    exists (n : nat), @interp_imp void1 _ (denote_aexp ae) s ≈ Ret (s,n).
Proof.
  intros. induction ae.
  - exists n. cbn. tau_steps. reflexivity.
    (*getvar case, extract to a lemma*)
  - cbn. exists (lookup_default x 0 s).
    tau_steps. reflexivity.
  - basic_solve. exists (n0 + n)%nat.
    cbn. setoid_rewrite interp_imp_bind. rewrite IHae1.
    setoid_rewrite bind_ret_l. setoid_rewrite interp_imp_bind. rewrite IHae2.
    tau_steps. reflexivity.
  - basic_solve. exists (n0 - n)%nat.
    cbn. setoid_rewrite interp_imp_bind. rewrite IHae1.
    setoid_rewrite bind_ret_l. setoid_rewrite interp_imp_bind. rewrite IHae2.
    tau_steps. reflexivity.
  - basic_solve. exists (n0 * n)%nat.
    cbn. setoid_rewrite interp_imp_bind. rewrite IHae1.
    setoid_rewrite bind_ret_l. setoid_rewrite interp_imp_bind. rewrite IHae2.
    tau_steps. reflexivity.
Qed.

Lemma bools_term : forall (be : bexp) (s : env),
    exists (bc : bool), @interp_imp void1 _ (denote_bexp be) s ≈ Ret (s,bc).
Proof.
  intros. induction be.
  - exists true. cbn. unfold interp_imp, interp_map, interp_state. repeat rewrite interp_ret.
    tau_steps. reflexivity.
  - exists false. tau_steps. reflexivity.
  - specialize (aexp_term void1 a1 s) as Ha1. specialize (aexp_term void1 a2 s) as Ha2.
    basic_solve. exists (n0 =? n)%nat.
    cbn. setoid_rewrite interp_imp_bind. rewrite Ha1.
    setoid_rewrite bind_ret_l. setoid_rewrite interp_imp_bind.
    rewrite Ha2. tau_steps. reflexivity.
  - specialize (aexp_term void1 a1 s) as Ha1. specialize (aexp_term void1 a2 s) as Ha2.
    basic_solve. exists (n0 <=? n).
    cbn. setoid_rewrite interp_imp_bind. rewrite Ha1.
    setoid_rewrite bind_ret_l. setoid_rewrite interp_imp_bind.
    rewrite Ha2. tau_steps. reflexivity.
  - basic_solve. exists (negb bc). cbn.
    setoid_rewrite interp_imp_bind. rewrite IHbe. tau_steps.
    reflexivity.
  - basic_solve. exists (bc0 && bc)%bool.
    cbn. setoid_rewrite interp_imp_bind. rewrite IHbe1. setoid_rewrite bind_ret_l.
    cbn. setoid_rewrite interp_imp_bind. rewrite IHbe2. tau_steps.
    reflexivity.
Qed.

Lemma classic_bool : forall (b : bexp) (s : env), is_true b s \/ is_false b s.
Proof.
  intros. specialize (bools_term b s) as Hbs.
  basic_solve. destruct bc; auto.
Qed.

(*   *)

Lemma hoare_seq : forall (c1 c2 : com) (P Q R : env -> Prop), {{P}} c1 {{Q}} -> {{Q}} c2 {{R}}  ->
                                                               {{P}} c1 ;;; c2 {{R}}.
Proof.
  unfold hoare_triple. intros c1 c2 P Q R Hc1 Hc2 s s' Hs Hs'.
  unfold denote_imp in Hs'. cbn in Hs'. rewrite interp_imp_bind in Hs'.
  fold (denote_imp c1) in Hs'. fold (denote_imp c2) in Hs'.
  destruct (eutt_reta_or_div (denote_imp c1 s) ); basic_solve.
  - destruct a as [s'' [] ]. rewrite <- H in Hs'. setoid_rewrite bind_ret_l in Hs'. symmetry in H.
    eapply Hc2; eauto.
  - apply div_spin_eutt in H. rewrite H in Hs'. rewrite <- spin_bind in Hs'.
    symmetry in Hs'. exfalso. eapply not_ret_eutt_spin. eauto.
Qed.

Lemma hoare_if : forall (c1 c2 : com) (b : bexp) (P Q : env -> Prop),
    {{fun s => is_true b s /\ P s}} c1 {{Q}} ->
    {{fun s => is_false b s /\ P s}} c2 {{Q}} ->
    {{ P }} TEST b THEN c1 ELSE c2 FI {{Q}}.
Proof.
  unfold hoare_triple. intros c1 c2 b P Q Hc1 Hc2 s s' Hs.
  unfold denote_imp. cbn.
  destruct (classic_bool b s).
  - unfold is_true, is_bool in H. rewrite interp_imp_bind.
    rewrite H. setoid_rewrite bind_ret_l. apply Hc1. auto.
  - unfold is_false, is_bool in H. rewrite interp_imp_bind.
    rewrite H. setoid_rewrite bind_ret_l. apply Hc2. auto.
Qed.

Definition app {A B : Type} (f : A -> B) (a : A) := f a.

Definition run_state_itree {A S : Type} {E : Type -> Type} (s : S) (m : stateT S (itree E) A )  : itree E (S * A) :=
  m s.

Global Instance EqStateEq {S R: Type} {E : Type -> Type} : Equivalence (@state_eq E R S).
Proof.
  constructor; repeat intro.
  - reflexivity.
  -  unfold state_eq in H. symmetry. auto.
  - unfold state_eq in *. rewrite H. auto.
Qed.

Global Instance run_state_proper_eq_itree {E : Type -> Type} {S R : Type} {s : S} :
  Proper (@state_eq E S R ==> eq_itree eq) (@run_state_itree R S E s).
Proof.
  repeat intro. unfold run_state_itree. unfold state_eq in H. rewrite H. reflexivity.
Qed.

Global Instance run_state_proper_eutt {E : Type -> Type} {S R : Type} {s : S} :
  Proper (@state_eq E S R ==> eutt eq) (@run_state_itree R S E s).
Proof.
  repeat intro. unfold run_state_itree. unfold state_eq in H. rewrite H. reflexivity.
Qed.

Global Instance eutt_proper_under_interp_state
       {E F: Type -> Type} {S R : Type} {h : E ~> stateT S (itree F) } :
  Proper (eq_itree eq ==> @state_eq F S R) (fun (t : itree E R) =>  interp_state h t).
Proof.
  repeat intro. unfold interp_state. rewrite H. reflexivity.
Qed.

(*
Check (case_ (handle_map (V := value) pure_state ) ).

Timeout 5 Definition run_state_map {value A : Type} (t : itree (mapE var 0 +' void1)  A) s  : itree void1 ( env * A):=
  interp_state (case_ (handle_map (V := value) ) pure_state) t s.
*)

Section interp_state_eq_iter.
  Context {E F: Type -> Type}.
  Context (S : Type).
  Context (f : E ~> stateT S (itree F) ).
  Context (A B : Type).
  Context (g : A ->itree E (A + B) ).
  Context (a : A).

  Lemma interp_state_eq_iter : state_eq (interp_state f (ITree.iter g a) )
                              (MonadIter_stateT0 _ _ (fun a0 => interp_state f (g a0)) a).
  Proof.
    unfold ITree.iter, Iter_Kleisli, Basics.iter, MonadIter_itree.
    eapply interp_state_iter; reflexivity.
  Qed.

End interp_state_eq_iter.
Set Default Timeout 15.

Global Instance proper_state_eq_iter {S: Type} :
  Proper (@state_eq void1 S (unit + unit) ==> @state_eq void1 S (unit) ) (fun body => @MonadIter_stateT0 Delay S _ _ unit unit (fun _ : unit => body) tt ).
Proof.
  repeat intro.
  unfold MonadIter_stateT0, Basics.iter, MonadIterDelay. eapply eq_itree_iter.
  repeat intro. subst. destruct y0 as [s' [] ].
  simpl. specialize (H s'). rewrite H. reflexivity.
Qed.

Lemma interp_state_bind_state : forall (E F : Type -> Type) (A B S : Type)
                   (h : forall T : Type, E T -> S -> itree F (S * T) ) (t : itree E A)
                   (k : A -> itree E B),
    state_eq (interp_state h (ITree.bind t k))
             (bind (interp_state h t) (fun a => interp_state h (k a) ) ).

Proof.
  unfold state_eq. intros. eapply interp_state_bind.
Qed.

Definition state_eq2 {E : Type -> Type} {A B S : Type} (k1 k2 : A -> stateT S (itree E) B ) : Prop :=
  forall a, state_eq (k1 a)  (k2 a).

Lemma eq_itree_clo_bind {E : Type -> Type} {R1 R2 : Type} :
  forall (RR : R1 -> R2 -> Prop) (U1 U2 : Type) (UU : U1 -> U2 -> Prop)
         (t1 : itree E U1) (t2 : itree E U2)
         (k1 : U1 -> itree E R1) (k2 : U2 -> itree E R2),
    eq_itree UU t1 t2 ->
    (forall (u1 : U1) (u2 : U2), UU u1 u2 -> eq_itree RR (k1 u1) (k2 u2)  ) ->
    eq_itree RR (ITree.bind t1 k1) (ITree.bind t2 k2).
Proof.
  intros. unfold eq_itree in *. eapply eqit_bind'; eauto.
Qed.

Global Instance bind_state_eq2 {E : Type -> Type} {A B S : Type} {m : stateT S (itree E) A} :
  Proper (@state_eq2 E A B S ==> @state_eq E S B) (bind m).
Proof.
  repeat intro. unfold state_eq2, state_eq in H. cbn.
  eapply eq_itree_clo_bind; try reflexivity. intros. subst.
  destruct u2 as [s' a]. simpl. rewrite H. reflexivity.
Qed.

(*can actually make this nicer*)
Lemma compile_while : forall (b : bexp) (c : com),
                             ((denote_imp ( WHILE b DO c END )) ≈ MonadIter_stateT0 unit unit
                                         (fun _ : unit => bind (interp_imp (denote_bexp b))
                                                               (fun b : bool => if b
                                                                         then bind (denote_imp c) (fun _ : unit => interp_imp (Ret (inl tt)) )
                                                                         else interp_imp (Ret (inr tt))) ) tt)%monad.
Proof.
  intros. simpl. unfold denote_imp. simpl. unfold while. unfold interp_imp at 1, interp_map at 1.
  cbn. red. red. intros. symmetry.
  rewrite interp_iter. do 3 red.
  match goal with | |- _ ≈ ?m _ => set m as while_denote; fold while_denote end.
  assert (Hwhile_rewrite : state_eq while_denote while_denote); try reflexivity.
  unfold while_denote in Hwhile_rewrite at 2.
  setoid_rewrite interp_state_eq_iter in Hwhile_rewrite.
  fold (run_state_itree s while_denote). rewrite Hwhile_rewrite.
  clear Hwhile_rewrite. unfold run_state_itree.
  match goal with |- MonadIter_stateT0 _ _ (fun _ :unit => ?m1) _ _ ≈ MonadIter_stateT0 _ _ (fun _ : unit => ?m2) _ _ =>
                  enough (state_eq m1 m2) end.
  - eapply proper_state_eq_iter in H.
    match goal with |- ?m1 s ≈ ?m2 s => set m1 as while_denote1; fold while_denote1;
                                        set m2 as while_denote2; fold while_denote2 end.
    fold (run_state_itree s while_denote1). fold (run_state_itree s while_denote2).
    unfold while_denote1. unfold while_denote2. rewrite H. reflexivity.
 - rewrite interp_bind. rewrite interp_state_bind_state.
   clear s. intro s. eapply eq_itree_clo_bind; try reflexivity.
   intros. subst. destruct u2 as [s' b0 ]. simpl. destruct b0.
   + rewrite interp_bind. rewrite interp_state_bind.
     unfold interp_imp, interp_map. reflexivity.
   + unfold interp_imp, interp_map. reflexivity.
Qed.

Lemma hoare_while : forall (c : com) (b : bexp) (P : env -> Prop),
    {{fun s => is_true b s /\ P s}} c {{ P  }} ->
    {{ P }} WHILE b DO c END {{ fun s => is_false b s /\ P s}}.
Proof.
  unfold hoare_triple. intros.
  specialize (compile_while b c) as Hbc. red in Hbc. red in Hbc.
  rewrite Hbc in H1. clear Hbc.
  specialize (loop_invar_state env unit unit) as Hloop. unfold State in Hloop.
  rename H1 into Heutt. rename H0 into Hs.
  set ((fun _ : unit =>
             b <-
             interp_imp
               (denote_bexp b);;
             (if b
              then
               _ <- denote_imp c;;
               interp_imp
                 (Ret (inl tt))
              else
               interp_imp
                 (Ret (inr tt))))) as body.
  split.
  - set (fun (t : Delay (env * unit) ) =>
           (exists s, t ≈ ret (s,tt) /\ is_false b s) \/ any_infinite t
        ) as p.
    set (fun (t : Delay (env * unit + env * unit)) =>
           (exists s, (t ≈ ret (inl (s,tt)) ) \/ ((t ≈ ret (inr (s,tt)) /\ is_false b s)) )  \/ any_infinite t
        ) as q.
    assert (resp_eutt p) as Hp.
    {
      unfold p. unfold is_false, is_bool.
      intros t1 t2 He. split; intro; basic_solve.
      - left. exists s0.  split; auto. rewrite <- He. auto.
      - rewrite He in H0. auto.
      - left. exists s0. split; auto. rewrite He. auto.
      - rewrite <- He in H0. auto.
    }
    assert (resp_eutt q) as Hq.
    {
      unfold q. unfold is_true, is_false, is_bool.
      intros t1 t2 He. split; intros; basic_solve.
      - left. exists s0. rewrite He in H0. auto.
      - left. exists s0. rewrite He in H0. auto.
      - rewrite He in H0. auto.
      - left. exists s0. rewrite He. auto.
      - left. exists s0. rewrite He. auto.
      - rewrite <- He in H0. auto.
    }
   enough (p (Ret (s',tt) ) ).
    {
      unfold p in H0. basic_solve; auto. pinversion H0.
    }
    enough (p (CategoryOps.iter body tt s) ).
    {
      eapply Hp; try apply H0. unfold CategoryOps.iter, Iter_Kleisli, Basics.iter.
      unfold body. symmetry. auto.
    }
    enough ((p \1/ any_infinite) (CategoryOps.iter body tt s) ).
    {
      destruct H0; auto. unfold p. auto.
    }
    specialize Hloop with (s := s) (p := p) (q := q).
    eapply Hloop; eauto.
    + unfold reassoc. unfold body.
      destruct (eutt_reta_or_div (interp_imp (denote_com c) s ) );
      destruct (classic_bool b s); basic_solve.
      * do 2 red in H1. unfold interp_imp, interp_map in H1.
        destruct a as [s'' [] ].
        eapply Hq.
        -- cbn. setoid_rewrite bind_bind.
           rewrite H1.
           setoid_rewrite bind_ret_l. simpl.
           setoid_rewrite bind_bind. rewrite <- H0.
           tau_steps. reflexivity.
        -- unfold q. left. exists s''. left. reflexivity.
      * do 2 red in H1. unfold interp_imp, interp_map in H1.
        destruct a as [s'' [] ].
        eapply Hq.
        -- cbn. rewrite H1. setoid_rewrite bind_bind. setoid_rewrite bind_ret_l.
           simpl. tau_steps. reflexivity.
        -- unfold q. left. exists s. right. split; auto. reflexivity.
      * do 2 red in H1. unfold interp_imp, interp_map in H1.
        eapply Hq.
        -- cbn. rewrite H1. setoid_rewrite bind_bind. setoid_rewrite bind_ret_l.
           simpl. apply div_spin_eutt in H0. rewrite H0. setoid_rewrite bind_bind.
           rewrite <- spin_bind. reflexivity.
        -- red. right. apply spin_infinite.
      * do 2 red in H1. unfold interp_imp, interp_map in H1.
        eapply Hq.
        -- cbn. rewrite H1. setoid_rewrite bind_bind. setoid_rewrite bind_ret_l.
           simpl. apply div_spin_eutt in H0.
           tau_steps. reflexivity.
        -- red. left. exists s. right. split; auto; reflexivity.
   + unfold q,p. unfold DelaySpecMonad.loop_invar_imp. intros.
     basic_solve.
     * cbn in H0. exfalso. destruct (eutt_reta_or_div t); basic_solve.
       -- rewrite <- H1 in H0. setoid_rewrite bind_ret_l in H0. basic_solve.
       -- apply div_spin_eutt in H1. rewrite H1 in H0. rewrite <- spin_bind in H0.
          symmetry in H0. eapply not_ret_eutt_spin; eauto.
     * cbn in H0. destruct (eutt_reta_or_div t); basic_solve; auto.
       rewrite <- H2 in H0. setoid_rewrite bind_ret_l in H0. basic_solve. left.
       exists s0. split; auto. symmetry. auto.
     * right. destruct (eutt_reta_or_div t); basic_solve; auto.
       cbn in H0. rewrite <- H1 in H0. setoid_rewrite bind_ret_l in H0.
       pinversion H0.
  + unfold q.
    unfold DelaySpecMonad.iter_lift, iso_destatify_arrow, reassoc.
    basic_solve; try (destruct (classic_bool b s0) );
      try (destruct (eutt_reta_or_div (interp_imp (denote_com c) s0 ) )); basic_solve.
    * eapply Hq.
      -- cbn. rewrite H0. setoid_rewrite bind_ret_l.
         setoid_rewrite bind_bind. do 2 red in H1. unfold interp_imp, interp_map in H1.
         rewrite H1. setoid_rewrite bind_ret_l. simpl.
         destruct a as [s1 [] ]. rewrite <- H2. setoid_rewrite bind_bind.
         setoid_rewrite bind_ret_l. simpl. tau_steps. reflexivity.
      -- red. left. destruct a as [s'' [] ]. exists s''. left. reflexivity.
    * eapply Hq.
      -- cbn. rewrite H0. setoid_rewrite bind_ret_l. setoid_rewrite bind_bind.
         do 2 red in H1. unfold interp_imp, interp_map in H1. rewrite H1.
         setoid_rewrite bind_ret_l. simpl. apply div_spin_eutt in H2. rewrite H2.
         setoid_rewrite bind_bind. rewrite <- spin_bind. reflexivity.
      -- right. apply spin_infinite.
    * destruct a as [s'' [] ]. eapply Hq.
      -- cbn.  rewrite H0. setoid_rewrite bind_ret_l.
         do 2 red in H1. unfold interp_imp, interp_map in H1. rewrite H1.
         setoid_rewrite bind_bind. setoid_rewrite bind_ret_l. simpl. tau_steps. reflexivity.
      -- left. exists s0. right. split; auto. reflexivity.
    * eapply Hq.
      -- cbn.  rewrite H0. setoid_rewrite bind_ret_l.
         do 2 red in H1. unfold interp_imp, interp_map in H1. rewrite H1.
         setoid_rewrite bind_bind. setoid_rewrite bind_ret_l. simpl. tau_steps. reflexivity.
      -- left. exists s0. right. split; auto. reflexivity.
    * do 2 red in H1. do 2 red in H2. rewrite H1 in H2.
      apply eutt_inv_Ret in H2. injection H2. discriminate.
    * do 2 red in H1. do 2 red in H2. rewrite H1 in H2.
      apply eutt_inv_Ret in H2. injection H2. discriminate.
    * eapply Hq.
      -- cbn.  rewrite H0. setoid_rewrite bind_ret_l.  reflexivity.
      -- left. exists s0. right. split; auto. reflexivity.
    * eapply Hq.
      -- cbn.  rewrite H0. setoid_rewrite bind_ret_l.  reflexivity.
      -- left. exists s0. right. split; auto. reflexivity.
    * right. cbn. apply div_spin_eutt in H0. rewrite H0. rewrite <- spin_bind.
      apply spin_infinite.
   - set (fun (t : Delay (env * unit)) =>
           (exists s, t ≈ ret (s,tt) /\ P s ) \/ any_infinite t
        ) as p.
    set (fun (t : Delay (env * unit + env * unit)) =>
           (exists s, (t ≈ ret (inl (s,tt) ) \/ t ≈ ret (inr (s,tt) ) ) /\ P s )\/ any_infinite t )  as q.
    assert (resp_eutt p) as Hp.
    {
      unfold p. intros t1 t2 He. split; intros; basic_solve.
      - left. exists s0. rewrite He in H0. auto.
      - right. rewrite He in H0. auto.
      - left.  exists s0. rewrite <- He in H0. split; auto.
      - right. rewrite He. auto.
    }
      assert (resp_eutt q) as Hq.
      {
        unfold q. intros t1 t2 He. split; intros; basic_solve.
        - left. exists s0. rewrite He in H0. auto.
        - left. exists s0. rewrite He in H0. auto.
        - right. rewrite He in H0. auto.
        - left. rewrite <- He in H0. exists s0. auto.
        - left. rewrite <- He in H0. exists s0. auto.
        - right. rewrite He. auto.
      }
      specialize Hloop with (s := s) (p := p) (q := q).

      enough (p (Ret (s',tt))).
      {
        unfold p in H0. basic_solve; auto. pinversion H0.
      }
      enough ((p \1/ any_infinite) (CategoryOps.iter body tt s ) ).
      {
        destruct H0.
        - eapply Hp; try apply H0. rewrite <- Heutt. reflexivity.
        - unfold CategoryOps.iter, Iter_Kleisli, Basics.iter in H0.
          unfold body in H0. rewrite Heutt in H0. pinversion H0.
      }
      eapply Hloop; eauto.
      + unfold reassoc. unfold body. destruct (classic_bool b s).
        * assert (is_true b s /\ P s); auto.
          destruct (eutt_reta_or_div (interp_imp (denote_com c) s) ); basic_solve.
          -- destruct a as [s'' [] ].
             unfold is_true, is_bool in H0.
             unfold interp_imp, interp_map in H0.
             eapply Hq.
             ++ cbn. setoid_rewrite bind_bind. rewrite H0.
                setoid_rewrite bind_ret_l. simpl. setoid_rewrite bind_bind.
                rewrite <- H2. tau_steps.
                reflexivity.
             ++ specialize (H s s''). unfold q. left. exists s''. split; try (left; reflexivity).
                eapply H; eauto. symmetry. auto.
          -- apply div_spin_eutt in H2.
             cbn. rewrite bind_bind.
             unfold is_true, is_bool in H0.
             unfold interp_imp, interp_map in H0. rewrite H0.
             setoid_rewrite bind_ret_l. simpl. rewrite H2.
             setoid_rewrite bind_bind. rewrite <- spin_bind.
             right. apply spin_infinite.
        * unfold is_false, is_bool, interp_imp, interp_map in H0. cbn.
          eapply Hq.
          -- setoid_rewrite bind_bind. rewrite H0. setoid_rewrite bind_ret_l.
             simpl. cbn. tau_steps. reflexivity.
          -- unfold q. left. exists s. split; auto. right. reflexivity.
      + red. intros. unfold p. unfold q in H0. basic_solve.
        * cbn in H0.
          destruct (eutt_reta_or_div t); basic_solve.
          -- destruct a as [s'' [] ]. rewrite <- H2 in H0.
             setoid_rewrite bind_ret_l in H0. basic_solve.
          -- exfalso. apply div_spin_eutt in H2. rewrite H2 in H0. rewrite <- spin_bind in H0.
             symmetry in H0. apply not_ret_eutt_spin in H0. auto.
        * cbn in H0.
        destruct (eutt_reta_or_div t); basic_solve.
        -- destruct a as [s'' [] ]. rewrite <- H2 in H0.
           setoid_rewrite bind_ret_l in H0. basic_solve. left. exists s0.
           symmetry in H2. auto.
        -- exfalso. apply div_spin_eutt in H2. rewrite H2 in H0.
           rewrite <- spin_bind in H0. symmetry in H0. apply not_ret_eutt_spin in H0. auto.
      * cbn in H0. right. destruct (eutt_reta_or_div t); auto.
        basic_solve. rewrite <- H1 in H0. setoid_rewrite bind_ret_l in H0.
        pinversion H0.
    + unfold DelaySpecMonad.iter_lift, iso_destatify_arrow, reassoc.
      intros t Ht. cbn.
      destruct (eutt_reta_or_div t);
         basic_solve.
      * destruct a as [s'' [] ].
        destruct (classic_bool b s'');
          destruct (eutt_reta_or_div (interp_imp (denote_com c) s'' )); basic_solve;
        eapply Hq.
        -- rewrite <- H0. setoid_rewrite bind_ret_l.
           setoid_rewrite bind_bind. do 2 red in H1.
           unfold interp_imp, interp_map in H1. rewrite H1. setoid_rewrite bind_ret_l.
           simpl. setoid_rewrite bind_bind.
           rewrite <- H2. setoid_rewrite bind_ret_l. destruct a as [s3 [] ].
           simpl. tau_steps. reflexivity.
        -- destruct a as [s3 [] ]. unfold q in Ht. basic_solve.
           ++ rewrite  H3 in H0. basic_solve.
              unfold q. left. exists s3. split; try (left; reflexivity). symmetry in H2.
              cbn in H0. pinversion H0. subst. injection REL; intros; subst.
              eapply H; eauto.
           ++ rewrite H3 in H0. cbn in *; basic_solve; pinversion H0; try discriminate; basic_solve.
           ++ rewrite <- H0 in H3. pinversion H3.
        -- rewrite <- H0. setoid_rewrite bind_ret_l. setoid_rewrite bind_bind.
           do 2 red in H1. unfold interp_imp, interp_map in H1. rewrite H1.
           setoid_rewrite bind_ret_l. simpl. apply div_spin_eutt in H2.
           setoid_rewrite bind_bind. rewrite H2.
           rewrite <- spin_bind. reflexivity.
        -- unfold q. right. apply spin_infinite.
        -- rewrite <- H0. setoid_rewrite bind_ret_l.
           unfold is_false, is_bool in H1. unfold interp_imp, interp_map in H1.
           rewrite H1. setoid_rewrite bind_bind. setoid_rewrite bind_ret_l. simpl.
           tau_steps. reflexivity.
        -- unfold q. left. exists s''. split; try (right; reflexivity). unfold q in Ht.
           basic_solve.
           ++ rewrite H3 in H0. basic_solve. auto. pinversion H0. injection REL; intros; subst; auto.
           ++ rewrite H3 in H0. basic_solve. pinversion H0. discriminate.
           ++ rewrite <- H0 in H3. pinversion H3.
        -- rewrite <- H0. setoid_rewrite bind_ret_l.
           setoid_rewrite bind_bind.
           do 2 red in H1. unfold interp_imp, interp_map in H1.
           rewrite H1. setoid_rewrite bind_ret_l. simpl. tau_steps.
           reflexivity.
        -- unfold q. left. exists s''.
           split; try (right; reflexivity). unfold q in Ht.
           basic_solve.
           ++ rewrite H3 in H0. basic_solve. pinversion H0; injection REL; intros; subst; auto.
           ++ rewrite H3 in H0. basic_solve. pinversion H0; discriminate.
           ++ rewrite <- H0 in H3. pinversion H3.
     * destruct b0 as [s'' [] ]. eapply Hq.
       -- rewrite <- H0. setoid_rewrite bind_ret_l.
          reflexivity.
       -- unfold q. left. exists s''. split; try (right; reflexivity).
          unfold q in Ht. basic_solve.
          ++ rewrite H1 in H0. basic_solve. pinversion H0. discriminate.
          ++ rewrite H1 in H0. basic_solve. pinversion H0; injection REL; intros; subst; auto.
          ++ rewrite <- H0 in H1. pinversion H1.
     * clear Ht. unfold q. right. apply div_spin_eutt in H0.
       rewrite H0. rewrite <- spin_bind. apply spin_infinite.

Qed.

Lemma denote_imp_bind : forall (c1 c2 : com), state_eq (denote_imp (c1 ;;; c2)) (denote_imp c1 ;; denote_imp c2).
Proof.
  intros. intro. cbn. unfold denote_imp. simpl. setoid_rewrite interp_imp_bind.
  eapply eq_itree_clo_bind; try reflexivity. intros. subst. destruct u2. reflexivity.
Qed.

Definition state_eq_eutt {R S : Type} {E : Type -> Type} (m0 m1 : stateT S (itree E) R) :Prop :=
  forall s, m0 s ≈ m1 s.

Global Instance equiv_state_eq_eutt {R S} {E} : Equivalence (@state_eq_eutt R S E).
Proof.
  constructor; red; red; intros.
  - reflexivity.
  - red in H. rewrite H. reflexivity.
  - red in H. red in H0.  rewrite H. rewrite H0. reflexivity.
Qed.

Lemma state_eq_sub_state_eutt : forall (E : Type -> Type) (R S: Type) ,
    subrelation (@state_eq E S R) state_eq_eutt.
Proof.
  red. intros E R S m0 m1 Heq.
  red. red in Heq. intros. rewrite Heq. reflexivity.
Qed.

Global Instance state_eq_prop_state_eutt {R S} {E} : Proper (@state_eq E S R ==> state_eq ==> impl) state_eq_eutt.
Proof.
  red. red. intros m0 m1 Heq0. red. intros m2 m3. intros Heq2.
  red. intros. red. red in H. red in Heq2. red in Heq0. intros.
  rewrite <- Heq2. rewrite <- H. rewrite Heq0. reflexivity.
Qed.

Lemma set_var_val_interp : forall x n E, @state_eq_eutt _ _ E (interp_imp (trigger (SetVar x n))) (fun s => Ret (Maps.add x n s,tt)).
Proof.
  intros. intro. tau_steps. reflexivity.
Qed.

Fixpoint compute_aexp (a : aexp) (s : env) : value :=
  match a with
  | ANum n => n
  | AId x => lookup_default x 0 s
  | APlus a1 a2 => (compute_aexp a1 s) + (compute_aexp a2 s)
  | AMinus a1 a2 => (compute_aexp a1 s) - (compute_aexp a2 s)
  | AMult a1 a2 => (compute_aexp a1 s) * (compute_aexp a2 s)
  end.

Fixpoint compute_bexp (b : bexp) (s : env)  : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (compute_aexp a1 s) =? (compute_aexp a2 s)
  | BLe a1 a2 => (compute_aexp a1 s) <=? (compute_aexp a2 s)
  | BNot b0 => negb (compute_bexp b0 s)
  | BAnd b1 b2 => (compute_bexp b1 s) && (compute_bexp b2 s)
  end.

Lemma compute_aexp_sc : forall (a : aexp),
    @state_eq_eutt value env void1 (interp_imp (denote_aexp a)) (fun s => Ret (s, compute_aexp a s)).
Proof.
  intros. red. intros. induction a; simpl;
  try (tau_steps; reflexivity);
  try (rewrite interp_imp_bind; rewrite IHa1; rewrite bind_ret_l;
    rewrite interp_imp_bind; rewrite IHa2; rewrite bind_ret_l; tau_steps; reflexivity).
Qed.

Lemma compute_aexp_sc_tree : forall (a : aexp) (s : env),
    (@interp_imp void1 value (denote_aexp a) s) ≈ (Ret (s, compute_aexp a s) ).
Proof.
  intros. apply compute_aexp_sc.
Qed.

Lemma compute_bexp_sc : forall (b : bexp),
    @state_eq_eutt bool env void1 (interp_imp (denote_bexp b) ) (fun s => Ret (s, compute_bexp b s)).
Proof.
  intros. red. intros. induction b; simpl;
  try (tau_steps; reflexivity).
  - rewrite interp_imp_bind. rewrite compute_aexp_sc_tree.
    rewrite bind_ret_l. rewrite interp_imp_bind. rewrite compute_aexp_sc_tree.
    rewrite bind_ret_l. tau_steps. reflexivity.
  - rewrite interp_imp_bind. rewrite compute_aexp_sc_tree.
    rewrite bind_ret_l. rewrite interp_imp_bind. rewrite compute_aexp_sc_tree.
    rewrite bind_ret_l. tau_steps. reflexivity.
  - rewrite interp_imp_bind. rewrite IHb. rewrite bind_ret_l.
    tau_steps. reflexivity.
  - rewrite interp_imp_bind. rewrite IHb1. rewrite bind_ret_l.
    rewrite interp_imp_bind. rewrite IHb2. rewrite bind_ret_l.
    tau_steps. reflexivity.
Qed.

Lemma compute_bexp_sc_tree : forall (b : bexp) (s : env),
    (@interp_imp void1 bool (denote_bexp b) s ) ≈ (Ret (s, compute_bexp b s) ).
Proof.
  intros. apply compute_bexp_sc.
Qed.

Definition inc_var (x : var) (s : env) : env:=
  Maps.add x (1 + lookup_default x 0 s)%nat  s.

Lemma compute_assign_sc : forall (x : var) (a : aexp),
    state_eq_eutt (@interp_imp void1 unit (denote_com (x ::= a) ) )
                  (fun s => Ret (Maps.add x (compute_aexp a s) s, tt) ).
Proof.
  intros. simpl. intro. rewrite interp_imp_bind.
  rewrite compute_aexp_sc_tree. rewrite bind_ret_l. tau_steps. reflexivity.
Qed.

Lemma compute_assign_sc_tree : forall (x : var) (a : aexp) (s : env),
    (@interp_imp void1 unit (denote_com (x ::= a)) s ) ≈ Ret (Maps.add x (compute_aexp a s) s, tt ).
Proof.
  intros. apply compute_assign_sc.
Qed.
(*state_eq_eutt is proper wrt to verify_cond*)

Global Instance proper_verify_cond {S A : Type} {w : StateDelaySpec S A} :
  Proper (state_eq_eutt ==> iff) (verify_cond S w).
Proof.
  repeat intro. unfold verify_cond, DijkstraProp. split; intros.
  - repeat red in H0. repeat red. intros. specialize (H0 s p). destruct p as [p Hp].
    simpl in *.
    eapply Hp; [symmetry; apply H | eauto].
  - repeat red in H0. repeat red. intros. specialize (H0 s p). destruct p as [p Hp].
    simpl in *.
    eapply Hp; auto.
Qed.

Global Instance proper_verify_cond_strong {S A : Type} {w : StateDelaySpec S A} :
  Proper (state_eq ==> iff) (verify_cond S w).
Proof.
  repeat intro. unfold verify_cond, DijkstraProp. split; intros.
  - repeat red in H0. repeat red. intros. specialize (H0 s p). destruct p as [p Hp].
    simpl in *. apply state_eq_sub_state_eutt in H.
    eapply Hp; [symmetry|]; auto.
  - repeat red in H0. repeat red. intros. specialize (H0 s p). destruct p as [p Hp].
    simpl in *. apply state_eq_sub_state_eutt in H. eapply Hp; eauto.
Qed.

Global Instance state_eutt_iter {A B S: Type} {E : Type -> Type} :
  Proper (pointwise_relation A (@state_eq_eutt (A + B) S E ) ==>
                             pointwise_relation A (@state_eq_eutt B S E) ) (MonadIter_stateT0 B A).
Proof.
  repeat intro. red in H. red. red. unfold MonadIter_stateT0.
  apply eutt_iter. red. intros. destruct a0 as [s' a']. simpl. red in H.
  rewrite H. reflexivity.
Qed.

Global Instance state_eutt_bind_l {A B S : Type} {E : Type -> Type} :
  Proper ((@state_eq_eutt A S E) ==> pointwise_relation _ (@state_eq_eutt B S E)  ) bind.
Proof.
  unfold Proper, respectful, pointwise_relation. intros m0 m1 Heutt k.
  intro. cbn. red in Heutt. rewrite Heutt. reflexivity.
Qed.
(*we need a way to generate properness goals, this is fucking ridiculous*)
Global Instance state_eutt_bind_r {A B S : Type} {E : Type -> Type}
       {m : stateT S (itree E) A } :
  Proper ((pointwise_relation _ state_eq_eutt) ==>  (@state_eq_eutt B S E )  ) (bind m).
Proof.
  repeat intro. rename x into k0. rename y into k1. rename H into Heutt.
  red. red. red in Heutt. red in Heutt. cbn.
  eapply eutt_clo_bind; try reflexivity. intros. subst. destruct u2 as [s' a]. simpl.
  rewrite Heutt. reflexivity.
Qed.

Global Instance state_eutt_bind_l' {A B S : Type} {E : Type -> Type} :
  Proper ((@state_eq_eutt A S E) ==> pointwise_relation _ (@state_eq_eutt B S E) ==> state_eq_eutt  ) bind.
Proof.
  unfold Proper, respectful, pointwise_relation. intros m0 m1 Hmeutt k0 k1 Hkeutt.
  intro. cbn. red in Hmeutt. rewrite Hmeutt.
  eapply eutt_clo_bind; try reflexivity. intros. subst. destruct u2 as [s' a].
  simpl. red in Hkeutt. rewrite Hkeutt. reflexivity.
Qed.

Global Instance run_state_eutt_proper_eutt : forall (E : Type -> Type) (S R : Type) (s : S),
          Proper (@state_eq_eutt R S E  ==> eutt eq) (run_state_itree s).
Proof.
  repeat intro. red in H. unfold run_state_itree. rewrite H. reflexivity.
Qed.

Lemma lookup_nin : forall (x : var) (s : env), (forall v : value, ~ Maps.mapsto x v s) -> Maps.lookup x s = None.
Proof.
  intros. red in s. red in s. generalize dependent x. induction s; intros; auto.
  - cbn. destruct a as [y v]. destruct (Strings.String.string_dec x y).
    + subst. exfalso. apply (H v). red. cbn. red. cbn.
      rewrite RelDec.rel_dec_eq_true; auto. apply RelDec_Correct_string.
    + rewrite RelDec.rel_dec_neq_false; auto; try apply RelDec_Correct_string.
      unfold Maps.lookup in IHs. cbn in *. apply IHs; auto. intros.
      intro Hcontra. apply (H v0). red. cbn.
      rewrite RelDec.rel_dec_neq_false; auto; try apply RelDec_Correct_string.
Qed.

Lemma lookup_neq : forall (s : env) (x y: var) (v d: value), x <> y ->
                lookup_default x d (Maps.add y v s)  = lookup_default x d s.
Proof.

  intros.
  destruct (classic (exists v', Maps.mapsto x v' s)).
  - destruct H0 as [v' Hv'].
    assert (Maps.mapsto x v' (Maps.add y v s)).
    {
      eapply Maps.mapsto_add_neq in Hv'; eauto.
    }
    apply Maps.mapsto_lookup in H0. apply Maps.mapsto_lookup in Hv'. unfold lookup_default.
    rewrite Hv'. rewrite H0. auto.
  - assert (forall v',~ Maps.mapsto x v' s).
    { intros v' Hc. apply H0. exists v'. auto. }
    clear H0. apply lookup_nin in H1 as Hs. unfold lookup_default.
    rewrite Hs.
    assert (forall v', ~Maps.mapsto x v' (Maps.add y v s)).
    {
      intros v' Hcontra. apply Maps.mapsto_add_neq in Hcontra; auto.
      eapply H1; eauto.
    }
    apply lookup_nin in H0 as Hs'. rewrite Hs'. auto.
Qed.

Lemma lookup_eq : forall (s : env) (x : var) (v d : value),
    lookup_default x d (Maps.add x v s) = v.
Proof.
  intros. assert (Maps.mapsto x v (Maps.add x v s) ).
  { apply Maps.mapsto_add_eq; try reflexivity. }
  eapply Maps.mapsto_lookup in H. unfold lookup_default. rewrite H. auto.
Qed.

Definition assign_aexp (P : env -> Prop) (x : var) (a : aexp) : env -> Prop :=
  fun s => P (Maps.add x (compute_aexp a s) s).

Lemma hoare_assign : forall (P : env -> Prop) (x : var) (a : aexp),
    {{assign_aexp P x a}} x ::= a {{P}}.
Proof.
  intros. red. intros s s' Hassign Hret. unfold denote_imp in Hret.
  rewrite compute_assign_sc_tree in Hret. basic_solve. auto.
Qed.

Lemma hoare_consequence : forall (P0 P1 Q0 Q1: env -> Prop) (c : com),
    (forall s, P0 s -> P1 s) -> (forall s, Q0 s -> Q1 s) ->
    {{P1}} c {{Q0}} -> {{P0}} c {{Q1}}.
Proof.
  unfold hoare_triple. intros P0 P1 Q0 Q1 c HP HQ Hc s s' Hs Hcomp.
  apply HQ. eapply Hc; eauto.
Qed.

Section SQRTEx.

  Context (i n : var).
  Context ( Hneq : i <> n).

  Definition nat_sqrt : com :=
    i ::= 0;;;
    WHILE (~ (i * i = n) ) DO
       i ::= i + 1
    END.

  Local Open Scope nat_scope.
  Local Close Scope imp_scope.

  Definition is_square : nat -> Prop := fun (n : nat) => exists (m : nat), (m * m = n).

  Definition pre1 : env -> Prop := fun s => is_square (lookup_default n 0 s).
  Definition pre2 : env -> Prop := fun s => ~ is_square (lookup_default n 0 s).

  Definition post1 (s0 : env) (t : Delay (env * unit) ) : Prop :=
    exists s, t ≈ ret (s,tt) /\ (lookup_default i 0 s * lookup_default i 0 s) = lookup_default n 0 s0.

  Definition post2 : env -> Delay (env * unit) -> Prop := fun _ t => any_infinite t.

  Lemma burn_tree : forall (E : Type -> Type) (R : Type) (n : nat) (t : itree E R),
      t ≈ burn n t.
  Proof.
    intros. symmetry. generalize dependent t. induction n0; intros; try reflexivity.
    simpl. destruct (observe t) eqn : Heq.
    - specialize (itree_eta t) as Ht. rewrite Heq in Ht. rewrite Ht. reflexivity.
    - specialize (itree_eta t) as Ht. rewrite Heq in Ht. rewrite Ht.
      rewrite tau_eutt. auto.
    - specialize (itree_eta t) as Ht. rewrite Heq in Ht. rewrite Ht. reflexivity.
  Qed.
(*
  Global Instance proper_state_eq_eutt_iter {S Type: } :
    Proper (state_eq_eutt ==> pointwise_relation _ (state_eq_eutt) )
           (fun body)
*)

  Lemma compile_nat_sqrt_body :
    state_eq_eutt (denote_imp (WHILE (~ i * i  = n) DO i ::= i + 1 END)%imp)
                              (MonadIter_stateT0 _ _  (fun (_ :unit) (s : env) =>
                                                         if (compute_bexp (~ i * i = n) s)
                                                         then Ret (inc_var i s, inl tt)
                                                         else Ret (s, inr tt) ) tt ) .
  Proof.
    rewrite compile_while. apply state_eutt_iter. intro.
    rewrite compute_bexp_sc. intro. simpl. rewrite bind_ret_l. simpl.
    destruct (lookup_default i 0 s * lookup_default i 0 s =? lookup_default n 0 s); simpl.
    - tau_steps. reflexivity.
    - unfold denote_imp. rewrite compute_assign_sc_tree. rewrite bind_ret_l.
      cbn. tau_steps. rewrite Nat.add_comm. reflexivity.
  Qed.

  Let body_arrow (s : env) : Delay (env * (unit + unit) ) :=
    if (compute_bexp (~ i * i = n) s )
    then Ret (inc_var i s, inl tt)
    else Ret (s, inr tt).

  (*this may force me to come up with good wf_from conditions*)

  Ltac eqbdestruct a b := destruct (a =? b) eqn :?Heq;
                          match type of Heq with
                            | _ = true => apply Nat.eqb_eq in Heq
                            | _ = false => apply Nat.eqb_neq in Heq end.

  Lemma diverge_if_not_square_nat_sqrt_aux : forall (s : env),
      ~ is_square (lookup_default n 0 s) ->
      not_wf_from (fun s0 s1 => Ret (s1, inl tt) ≈ body_arrow s0 ) s.
  Proof.
    intros s Hn.
    set (lookup_default n 0 s) as n0.
    assert (forall m, m * m <> n0 ).
    {
      intros m Hcontra. unfold n0 in Hcontra. apply Hn. exists m. auto.
    }
    eapply intro_not_wf with (P := fun s => lookup_default n 0 s = n0) (f := fun s => inc_var i s); auto.
    - intros s0 s1 Hinv Heval. unfold body_arrow in Heval. simpl in Heval.
      rewrite Hinv in Heval. eqbdestruct (lookup_default i 0 s0 * lookup_default i 0 s0) n0.
      + simpl in *. basic_solve. pinversion Heval; discriminate.
      + simpl in Heval. basic_solve. pinversion Heval. injection REL; intros; subst. unfold inc_var. rewrite lookup_neq; auto.
    - intros s' Hinv. unfold body_arrow. simpl. rewrite Hinv.
      eqbdestruct (lookup_default i 0 s' * lookup_default i 0 s') n0; simpl.
      + exfalso. eapply H; apply Heq.
      + reflexivity.
  Qed.

  Lemma converge_if_square_nat_sqrt_aux : forall (s : env),
      lookup_default i 0 s = 0 ->
      is_square (lookup_default n 0 s) ->
      wf_from (fun s0 s1 => Ret (s1, inl tt) ≈ body_arrow s0 ) s.
  Proof.
    intros s Hi H. intros. unfold is_square in H. destruct H as [sqrt Hsqrt].
    set (fun s' : env => lookup_default i 0 s' <= sqrt /\
                         lookup_default n 0 s = lookup_default n 0 s') as inv.
    set (fun s : env => sqrt - lookup_default i 0 s)  as f.
    apply wf_intro_gt with (f := f) (P := inv); unfold inv; unfold f.
    - intros s1 s2 Hs1 Heutt.
      unfold body_arrow in Heutt. simpl in Heutt.
      destruct Hs1 as [Hsqrt1 Hconst].
      eqbdestruct (lookup_default i 0 s1 * lookup_default i 0 s1) (lookup_default n 0 s1);
        simpl in *; basic_solve; pinversion Heutt; try discriminate; injection REL; intros; subst.
      split.
      + unfold inc_var. rewrite lookup_eq.
        nia.
      + unfold inc_var. rewrite lookup_neq; auto.
    - intros s1 s2 Hs1 Heutt. unfold body_arrow in Heutt. simpl in *.
      eqbdestruct (lookup_default i 0 s1 * lookup_default i 0 s1) (lookup_default n 0 s1); simpl in *;
        pinversion Heutt; try discriminate; injection REL; intros; subst.
        unfold inc_var. rewrite lookup_eq. nia.
    - split; nia.
 Qed.

      (*Global Instance state_eq_eutt_eutt : Proper (state_eq_eutt ==> (pointwise_relation _ (eutt eq) ) ) (pointwise_relation _ (eutt eq) ). *)

  Lemma diverge_if_not_square_nat_sqrt : forall (s : env),
      ~ is_square (lookup_default n 0 s) ->
      any_infinite ( (denote_imp (WHILE (~ i * i  = n) DO i ::= i + 1 END)%imp) s).
    Proof.
      intros.
      enough (denote_imp (WHILE ~ i * i = n DO i ::= i + 1 END)%imp s ≈ ITree.spin).
      {
         rewrite H0. apply spin_infinite.
      }
      match goal with |- ?m s ≈ ITree.spin => fold (run_state_itree s m) end.
      rewrite compile_nat_sqrt_body. unfold run_state_itree.
      apply iter_inl_spin_state.
      apply ( diverge_if_not_square_nat_sqrt_aux) in H. unfold state_iter_arrow_rel.
      simpl. unfold body_arrow in H. simpl in *. generalize dependent s. pcofix CIH. intros.
      pinversion H0; try apply not_wf_F_mono'.
      pfold. eapply not_wf with (a' := (a',tt)).
      - symmetry. auto.
      - right. auto.
    Qed.

    (*maybe there is a better way to do it, prove that if the body can't prove a a spin,
      and it is wf then
      start working on that
     *)

  Lemma converge_if_square_nat_sqrt : forall (s : env),
        lookup_default i 0 s = 0 ->
        is_square (lookup_default n 0 s) ->
        exists s', (denote_imp (WHILE ~ i * i = n DO i ::= i + 1 END)%imp s ≈ Ret (s',tt) ).
  Proof.
    intros s Hi0 Hn. specialize (converge_if_square_nat_sqrt_aux s Hi0 Hn) as Hwf.
    eenough (exists s', _ ≈ Ret (s',tt) ).
    {
      destruct H as [s' H] . exists s'.
      match goal with |- (?m s ≈ _)%monad => fold (run_state_itree s m) end.
      rewrite compile_nat_sqrt_body. unfold run_state_itree. apply H.
    }
    specialize (iter_wf_converge_state unit unit env (fun _ : unit => body_arrow) ) as Hconv.
    specialize (Hconv tt s).
    enough ( exists p : env * unit,
            MonadIter_stateT0 unit unit (fun _ : unit => body_arrow) tt s
            ≈ Ret p).
    { destruct H as [ [s' [] ] H ]. eauto. }
    apply Hconv.
    - intros. unfold body_arrow. simpl.
      eqbdestruct (lookup_default i 0 s0 * lookup_default i 0 s0) (lookup_default n 0 s0); simpl.
      + exists (s0, inr tt). reflexivity.
      + exists (inc_var i s0, inl tt). reflexivity.
    - clear Hconv. clear Hi0. clear Hn. induction Hwf.
      + apply base. intros [s' [] ] ? . apply (H s').
        unfold state_iter_arrow_rel in H0. symmetry. auto.
      + apply step. intros [ s' [] ] ?. eapply H0. unfold state_iter_arrow_rel in H1. symmetry. auto.
  Qed.

  Lemma prepost1_holds_nat_sqrt_loop :
    verify_cond env (encode_dyn env ((pre1 /1\ fun s => lookup_default i 0 s = 0), post1) )
                (denote_imp (WHILE (~ i * i  = n) DO i ::= i + 1 END)%imp ).
  Proof.
    rewrite compile_nat_sqrt_body.
    repeat red. simpl. intros. destruct H. apply H0. clear H0. destruct H as [Hpre Hi0].
    assert (Hpost1 : forall s, resp_eutt (post1 s)).
    {
      unfold post1. repeat intro. split; basic_solve.
      - exists s1. split; auto. rewrite <- H. auto.
      - exists s1. rewrite H. split; auto.
    }
    unfold pre1 in Hpre.

    clear p.
    set (lookup_default n 0 s) as n0.
    set (fun x s => lookup_default x 0 s)  as get.
    set (fun (t : Delay ((env * unit) + (env * unit)) ) => exists s0,
    ((t ≈ ret (inl (s0,tt)) /\ get i s0 * get i s0 <= n0  ) \/ (t ≈ ret (inr (s0,tt)) /\ get i s0 * get i s0 = n0)) /\ get n s0 = n0 ) as q .
    set (fun (t : Delay (env * unit)) => exists s0, t ≈ ret (s0,tt) /\ get i s0 * get i s0 = n0 ) as p.
    match goal with |- post1 s ?t => enough (p t); auto end.
    assert (Hq : resp_eutt q).
    {
      + unfold q. repeat intro. split; intros; basic_solve; auto.
        * exists s0. split; auto. left. rewrite <- H. auto.
        * exists s0. split; auto. right. rewrite <- H. auto.
        * exists s0. split; auto. left. rewrite H. auto.
        * exists s0. split; auto. right. rewrite H. auto.
    }
    match goal with |- p ?t => enough ((p \1/ any_infinite) t)  end.
    - destruct H; auto. exfalso.
      specialize (converge_if_square_nat_sqrt s Hi0 Hpre) as Hconv.
      basic_solve.
      match type of Hconv with ?m s ≈ _ => fold (run_state_itree s m) in Hconv end.
      rewrite compile_nat_sqrt_body in Hconv. unfold run_state_itree in Hconv. rewrite Hconv in H.
      pinversion H.
    - eapply loop_invar_state with (q := q); eauto.
      (*Establishment*)
      + unfold reassoc. simpl. rewrite Hi0. simpl.
        destruct (lookup_default n 0 s) eqn : Heq; simpl.
        * eapply Hq.
          -- rewrite bind_ret_l. reflexivity.
          -- red. exists s. split; auto. right. unfold get. split; try reflexivity. unfold n0.
             (*wierd, so it seems to have something to do with different type aliasing for env*)
             unfold env in Hi0. rewrite Hi0. auto.
        * eapply Hq.
          -- rewrite bind_ret_l. reflexivity.
          -- red. exists (inc_var i s). split; auto.
             ++ left. split; try reflexivity. unfold get, inc_var.
                rewrite lookup_eq. unfold is_square in Hpre. basic_solve. nia.
             ++ unfold get, inc_var. rewrite lookup_neq; auto.
      (*Post Condition*)
      + red. cbn. intros. red. red in H. basic_solve.
        * exists s0. destruct (eutt_reta_or_div t); basic_solve.
          -- destruct a as [ s' [] ]. rewrite <- H2 in H. simpl in *. rewrite bind_ret_l in H.
             basic_solve.
          -- apply div_spin_eutt in H2. rewrite H2 in H.
             rewrite <- spin_bind in H. exfalso. symmetry in H. eapply not_ret_eutt_spin; try apply H.
        * exists s0. destruct (eutt_reta_or_div t); basic_solve.
          -- destruct a as [ s' []  ]. symmetry in H2. rewrite H2 in H.
             simpl in *. rewrite H1. rewrite bind_ret_l in H. basic_solve. auto.
          -- apply div_spin_eutt in H2. rewrite H2 in H. rewrite <- spin_bind in H.
             exfalso. symmetry in H. eapply not_ret_eutt_spin; try apply H.
       (*Preservation*)
      + intros. simpl. red in H. basic_solve.
        * eapply Hq.
          -- rewrite H. simpl. rewrite bind_ret_l. unfold DelaySpecMonad.iter_lift, iso_destatify_arrow, reassoc.
             simpl. reflexivity.
          -- eqbdestruct (lookup_default i 0 s0 * lookup_default i 0 s0) (lookup_default n 0 s0).
             ++ simpl. red. exists s0. setoid_rewrite Heq.
                rewrite Nat.eqb_refl.
                cbn. rewrite bind_ret_l. split; auto. right. unfold get, n0.
                split; try reflexivity.
                unfold env in Heq.  rewrite Heq. auto.
             ++ simpl. red. exists (inc_var i s0).  apply Nat.eqb_neq in Heq as Heq'. setoid_rewrite Heq'. simpl. rewrite bind_ret_l. split; auto.
                ** left. split; try reflexivity. unfold get, inc_var. rewrite lookup_eq.
                   unfold get in H1. red in Hpre. basic_solve. unfold get in H0. unfold n0 in *.
                   rewrite <- Hpre. rewrite <- H0 in H1. rewrite <- Hpre in H0. unfold env in *.  rewrite H0 in Heq.
                   assert (lookup_default i 0 s0 < m); nia.
                ** unfold get, inc_var. rewrite lookup_neq; auto.
         * eapply Hq.
           -- rewrite H. simpl. rewrite bind_ret_l. cbn. reflexivity.
           -- red. exists s0. split; auto. right. split; auto. reflexivity.
  Qed.

  Lemma prepost1_holds_nat_sqrt : verify_cond env (encode_dyn env (pre1,post1) ) (denote_imp nat_sqrt).
  Proof.
    unfold nat_sqrt.  rewrite denote_imp_bind.
    setoid_rewrite compile_nat_sqrt_body.
    setoid_rewrite compute_assign_sc. repeat red. intros s [p Hp]. intros. simpl in H.
    destruct H as [Hpre H]. apply H. clear H.
    assert (Hpost: forall s, resp_eutt (post1 s)).
    {
      repeat intro. unfold post1. split; intros; basic_solve.
      - exists s1. split; auto. rewrite <- H. auto.
      - exists s1. rewrite H. split; auto.
    }
    eapply Hpost.
    - Opaque Maps.add. simpl. rewrite bind_ret_l. simpl. reflexivity.
    - match goal with |- post1 s ?m => enough (post1 (Maps.add i 0 s) m) end.
      { unfold post1. unfold post1 in H. rewrite lookup_neq in H; auto. }
      specialize prepost1_holds_nat_sqrt_loop as Hloop.
      rewrite compile_nat_sqrt_body in Hloop. repeat red in Hloop.
      match goal with |- post1 ?s _ => set s as s1 end.
      simpl in Hloop. specialize (Hloop s1 (exist _ (post1 s1) (Hpost s1)) ).
      simpl in *. eapply Hloop. split; try split; intros.
      + unfold pre1, s1. rewrite lookup_neq; auto.
      + unfold s1. rewrite lookup_eq. auto.
      + red. red in H. basic_solve. unfold s1 in H0. exists s0. split; auto.
   Qed.

  Lemma prepost2_holds_nat_sqrt : verify_cond env (encode_dyn env (pre2,post2) ) (denote_imp nat_sqrt).
  Proof.
    unfold nat_sqrt. rewrite denote_imp_bind.
    setoid_rewrite compile_nat_sqrt_body.
    setoid_rewrite compute_assign_sc. repeat red. intros s [p Hp]. intros. simpl in H.
    destruct H as [Hpre H]. apply H. clear H. red in Hpre.
    simpl. red. rewrite bind_ret_l. simpl.
    assert (Hs' : ~ is_square (lookup_default n 0 (Maps.add i 0 s)) ).
    { rewrite lookup_neq; auto. } clear Hpre.
    apply diverge_if_not_square_nat_sqrt in Hs' as Hdivs.
    specialize compile_nat_sqrt_body as Hcomp. red in Hcomp. rewrite <- Hcomp.
    auto.
  Qed.

  Lemma both_hold_nat_sqrt : verify_cond env
                      (encode_list_dyn env (  (pre1, post1) :: (pre2,post2) :: nil ) ) (denote_imp nat_sqrt).
  Proof.
     repeat red. cbn. intros. inversion H; subst.
     - apply prepost1_holds_nat_sqrt. auto.
     - inversion H1; subst; try inversion H2.
       apply prepost2_holds_nat_sqrt. auto.
  Qed.

End SQRTEx.


(* Set Typeclasses Unique Instances *)
(** This lets typeclass search assume that instance heads are unique,
    so if one matches no other need to be tried,
    avoiding backtracking (even in unique solutions mode)
    This is on a class-by-class basis.
 *)

(* Non unique *)
Class B.
Class A.
Set Typeclasses Unique Instances.
(* Unique *)
Class D.
Class C (A : Type) := c : A.

Hint Mode C +.
Fail Definition test := c.

Unset Typeclasses Unique Instances.
Instance : B -> D -> C nat := fun _ _ => 0.
Instance : A -> D -> C nat := fun _ _ => 0.
Instance : B -> C bool := fun _ => true.

Instance : forall A, C A -> C (option A) := fun A _ => None.

Set Typeclasses Debug.

Set Typeclasses Unique Solutions.
(** This forces typeclass resolution to fail if at least two solutions
   exist to a given set of constraints. This is a global setting.
   For constraints involving assumed unique instances, it will not fail
   if two such instances could apply, however it will fail if two different
   instances of a unique class could apply.
 *)
Fail Definition foo (d d' : D) (b b' : B) (a' a'' : A) := c : nat.
Definition foo (d d' : D) (b b' : B) (a' : A) := c : nat.

Fail Definition foo' (b b' : B) := _ : B.
Unset Typeclasses Unique Solutions.
Definition foo' (b b' : B) := _ : B.

Set Typeclasses Unique Solutions.
Definition foo'' (d d' : D) := _ : D.

(** Cut backtracking *)
Module BacktrackGreenCut.
  Unset Typeclasses Unique Solutions.
  Class C (A : Type) := c : A.

  Class D (A : Type) : Type := { c_of_d :> C A }.

  Instance D1 : D unit.
  Admitted.

  Instance D2 : D unit.
  Admitted.

  (** Two instances of D unit, but when searching for [C unit], no
      backtracking on the second instance should be needed except
      in dependent cases. Check by adding an unresolvable constraint.
   *)

  Variable f : D unit -> C bool -> True.
  Fail Definition foo := f _ _.

  Fail Definition foo' := let y := _ : D unit in let x := _ : C bool in f _ x.

  Unset Typeclasses Strict Resolution.
  Class Transitive (A : Type) := { trans : True }.
  Class PreOrder (A : Type) := { preorder_trans :> Transitive A }.
  Class PartialOrder (A : Type) := { partialorder_trans :> Transitive A }.
  Class PartialOrder' (A : Type) := { partialorder_trans' :> Transitive A }.

  Instance: PreOrder nat. Admitted.
  Instance: PartialOrder nat. Admitted.

  Class NoInst (A : Type) := {}.

  Variable foo : forall `{ T : Transitive nat } `{ NoInst (let x:=@trans _ T in nat) }, nat.

  Fail Definition bar := foo.

End BacktrackGreenCut.


(*===========================================================================
    Some useful instances of Monad
  ===========================================================================*)
Require Import ssreflect seq.
Require Import monad.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import FunctionalExtensionality.

(*---------------------------------------------------------------------------
    Option monad
  ---------------------------------------------------------------------------*)
Instance optionMonadOps : MonadOps option :=
{ retn := Some
; bind := fun X Y (c: option X) f => if c is Some y then f y else None }.

Instance optionMonad : Monad option.
Proof. apply Build_Monad. done. move => X; by case. move => X Y Z; by case. Qed.

(*---------------------------------------------------------------------------
    Error monad
  ---------------------------------------------------------------------------*)
Section Error.

  Variable F: Type.

  Inductive Result X :=
  | Error (f:F)
  | Success (x:X).

  Global Instance errorMonadOps : MonadOps Result :=
  { retn := Success
  ; bind := fun X Y (c: Result X) f =>
    match c with Success x => f x | Error e => Error _ e end }.

  Global Instance errorMonad : Monad Result.
  Proof. apply Build_Monad. done. move => X; by case. move => X Y Z; by case. Qed.

  Definition raiseError {X} e : Result X := Error _ e.

End Error.

(*---------------------------------------------------------------------------
    List monad
    @todo akenn: fix this so we don't get a universe inconsistency later!
  ---------------------------------------------------------------------------*)
(*
Lemma flatten_map_cat {A B} (f:A->seq B) x y :
  flatten (map f (x ++ y)) = flatten (map f x) ++ flatten (map f y).
Proof. induction x => //. by rewrite /= IHx catA. Qed.

Instance seqMonadOps : MonadOps seq :=
{ retn := fun X (x:X) => x::nil
; bind := fun X Y (x: seq X) f => flatten (map f x) }.

Instance seqMonad : Monad seq.
Proof. apply Build_Monad.
+ move => X Y x f. by rewrite /= cats0.
+ move => X c. rewrite /=. induction c => //. by rewrite /=IHc.
+ induction c => //. move => f g. rewrite/=flatten_map_cat. rewrite/= in IHc. by rewrite IHc.
Qed.
*)
(*---------------------------------------------------------------------------
    I/O monad. D is the type of the input/output data
  ---------------------------------------------------------------------------*)
Section IO.

  Variable Chan: Type.
  Variable D: Type.

  Inductive IOM X :=
  | retnIO (x:X)
  | Out (ch:Chan) (d:D) (rest:IOM X)
  | In (ch:Chan) (f:D -> IOM X).

  Fixpoint bindIO X Y (c: IOM X) (f: X -> IOM Y) :=
   match c with
   | retnIO y => f y
   | Out ch d rest => Out ch d (bindIO rest f)
   | In ch g => In ch (fun d => bindIO (g d) f)
   end.

  Global Instance IOMonadOps : MonadOps IOM :=
  { retn := retnIO; bind := bindIO }.

  Global Instance IOMonad : Monad IOM.
  Proof. apply Build_Monad.
  (* assoc *) done.
  (* id_l *) induction c => //.
  + rewrite /= in IHc. by rewrite /=IHc.
  + rewrite /=. rewrite /= in H. by rewrite (functional_extensionality _ _ H).
  (* id_r *) induction c => //.
  + move => f g. rewrite /= in IHc. by rewrite /=IHc.
  + move => f0 g. rewrite /= in H.
    rewrite /=. apply f_equal. apply functional_extensionality. move => d. by rewrite H.
  Qed.

  Definition IO_write ch d : IOM unit := Out ch d (retn tt).
  Definition IO_read ch : IOM D := In ch retn.

  Require Import Streams.
  Fixpoint IO_run X (s:Stream D) (m: IOM X) : seq D * X :=
  match m with
  | retnIO x => (nil,x)
  | In ch g => let: Cons h t := s in IO_run t (g h)
  | Out ch d m => let: (output, result) := IO_run s m in (cons d output, result)
  end.

  Definition OutputM X := (seq D * X)%type.

  Global Instance OutputMonadOps : MonadOps OutputM :=
  { retn := fun {X} (x:X) => (nil, x);
    bind := fun {X Y} (c: OutputM X) (f: X -> OutputM Y) =>
            let (s, x) := c in
            let (s', y) := f x in (s++s', y) }.

  Global Instance OutputMonad : Monad OutputM.
  Proof. apply Build_Monad.
  (* assoc *) move => X Y x f. rewrite /bind/retn/=. by case (f x).
  (* id_l *) move => X c. rewrite /bind/retn/=. case c => s x. by rewrite cats0.
  (* id_r *) move => X Y Z c f g. case c => s x.
    rewrite /bind/=. case (f x) => s' y. case (g y) => s'' z. by rewrite catA.
  Qed.

  Definition Output_write d : OutputM unit := ([::d], tt).
End IO.

Existing Instance IOMonadOps.
Existing Instance IOMonad.
Existing Instance OutputMonadOps.
Existing Instance OutputMonad.

(*---------------------------------------------------------------------------
    State monad. S is the type of states
  ---------------------------------------------------------------------------*)
Section State.

  Context {S: Type}.

  Definition SM X := S -> (S * X)%type.

  (* Of course, this is a monad *)
  Global Instance SMonadOps : MonadOps SM :=
  { retn := fun X (x: X) (s:S) => (s, x)
  ; bind := fun X Y (c: SM X) (f: X -> SM Y) =>
            fun s => let (st1, a1) := c s in f a1 st1 }.

  Global Instance SMonad : Monad SM.
  Proof.
  apply Build_Monad.
  (* assoc *) move => X Y x f. by apply functional_extensionality => s.
  (* id_l *) move => X c. apply functional_extensionality => s. simpl. by elim (c s).
  (* id_r *) move => X Y Z c f g. apply functional_extensionality => s. simpl. by elim (c s).
  Qed.

  Definition SM_get : SM S := fun s => (s,s).
  Definition SM_set (s':S) : SM unit := fun s => (s',tt).

  Lemma bindGet {Y} (s: S) (f: S -> SM Y):
    bind SM_get f s = f s s.
  Proof. done. Qed.

End State.

(*---------------------------------------------------------------------------
    Stateful I/O. S is the type of states, D the type of input/output data
  ---------------------------------------------------------------------------*)
(*
Require Import Streams.
Section StateIO.

  Variable S: Type.
  Variable D: Type.

  Inductive Act := In (d:D) | Out (d:D).

  Definition SO X := S -> seq Act -> S -> X -> Prop.
  Inductive SOtrans X : SO X :=
  | unitSO (x: X) : forall s, SOtrans s nil s x
  | bindSO Y (c: SO Y) (f: Y -> SO X) :
    forall s s' s'' t t' x y, c s t s' y -> f y s' t' s'' x -> SOtrans s (t++t') s'' x.

Check unitSO. SOtrans.
Check unitSO.
  (* Of course, this is a monad *)
  Global Instance SOMonadOps : MonadOps SO :=
  { retn := unitSO
  ; bind := bindSO }. fun X Y (c: SO X) (f: X -> SO Y) =>
            fun str s => let: (st1, xs1, a1) := c str s in
                     let: (st2, xs2, a2) := f a1 str st1 in
                     (st2, xs1++xs2, a2) }.

  Global Instance SOMonad : Monad SO.
  Proof.
  apply Build_Monad.
  (* assoc *) move => X Y x f. apply functional_extensionality => s.
              simpl. by case E: (f x s) => [[st2 xs2] a2].
  (* id_l *) move => X c. apply functional_extensionality => s.
             simpl. case E: c => [[st xs] a]. by rewrite cats0.
  (* id_r *) move => X Y Z c f g. apply functional_extensionality => s.
             simpl. case E1: (c s) => [[st1 xs1] a1].
                    case E2: (f a1 st1) => [[st2 xs2] a2].
                    case E3: (g a2 st2) => [[st3 xs3] a3]. by rewrite catA.
  Qed.

  Definition SO_get : SO S := fun s => (s,nil,s).
  Definition SO_set (s':S) : SO unit := fun s => (s',nil,tt).
  Definition SO_output (d:D) : SO unit := fun s => (s,d::nil,tt).
End StateO.
*)

(*===========================================================================
    Monad transformers
  ===========================================================================*)

Section MonadTransformers.

(* Base monad *)
Variable M: Type -> Type.
Variable ops: MonadOps M.
Variable laws: Monad M.

(*---------------------------------------------------------------------------
    Option monad transformer
  ---------------------------------------------------------------------------*)
(* Base monad *)
Section OptionMT.

  Definition optionMT X := M (option X).

  Global Instance optionMT_ops : MonadOps optionMT :=
  { retn := fun X (x:X) => retn (Some x)
  ; bind := fun X Y (c: optionMT X) (f: X -> optionMT Y) =>
      bind (MonadOps:=ops) c (fun x:option X => if x is Some x' then f x' else retn None) }.

  Global Instance optionMT_laws : Monad optionMT.
  Proof. apply Build_Monad.
  (* assoc *) move => X Y x f. by rewrite /=id_l.
  (* id_l *)  move => X c. rewrite /= -{2}(id_r (option X) c).
    apply: f_equal. apply functional_extensionality => x. by elim x.
  (* id_r *) move => X Y Z c f g. rewrite /=assoc. apply: f_equal.
    apply functional_extensionality => x. elim x => //. by rewrite id_l.
  Qed.

  Global Coercion OMT_lift {X} (c: M X) : optionMT X :=
  let! x = c; retn (Some x).
End OptionMT.

(*---------------------------------------------------------------------------
    Error monad transformer
  ---------------------------------------------------------------------------*)
Section ErrorMT.

  Variable F: Type.

  Definition errorMT X := M (Result F X).

  Global Instance errorMT_ops : MonadOps errorMT :=
  { retn := fun X (x:X) => retn (Success _ x)
  ; bind := fun X Y (c: errorMT X) (f: X -> errorMT Y) =>
            bind (MonadOps:=ops) c (fun x =>
            match x with Success x => f x | Error e => retn (Error _ e) end) }.

  Global Instance errorMT_laws : Monad errorMT.
  Proof. apply Build_Monad.
  (* assoc *) move => X Y x f. by rewrite/= id_l.
  (* id_l *)  move => X c. simpl. rewrite -{2}(id_r (Result _ _) c).
  apply f_equal. apply functional_extensionality => x. by elim x.
  (* id_r *) move => X Y Z c f g. simpl. rewrite assoc.
  apply f_equal. apply functional_extensionality => x.
  elim x => //. move => f'. by rewrite id_l.
  Qed.

  Definition EMT_raise {X} e : errorMT X :=
    retn (Error _ e).

  Global Coercion EMT_lift {X} (c: M X) : errorMT X :=
    let! x = c; retn (Success _ x).

End ErrorMT.

(*---------------------------------------------------------------------------
    State monad transformer. S is the type of states, M is underlying monad

    This causes a universe inconsistency with procstatemonad.v!
  ---------------------------------------------------------------------------*)
Section StateMT.

  Variable S: Type.

  Definition SMT X := S -> M (S * X)%type.

  (* Of course, this is a monad *)
  Global Instance SMT_ops : MonadOps SMT :=
  { retn := fun X (x: X) (s:S) => retn (s, x)
  ; bind := fun X Y (c: SMT X) (f: X -> SMT Y) =>
            fun s => let! (st1, a1) = c s; f a1 st1 }.

  Global Instance SMT_laws : Monad SMT.
  Proof.
  assert (H1:forall Z, (fun z:S*Z => let (st,x) := z in retn (T:=M)(st, x)) = fun z => retn z).
  move => Z. apply functional_extensionality. by elim.

  assert(H2: forall Z, (fun z:S*Z => retn z) = retn).
  move => Z. by apply functional_extensionality.

  apply Build_Monad.
  (* assoc *) move => X Y x f. apply functional_extensionality => s. by rewrite /=id_l.
  (* id_l *) move => X c. apply functional_extensionality => s. by rewrite /= H1/= id_r.
  (* id_r *) move => X Y Z c f g. apply functional_extensionality => s.
  rewrite /= assoc/=. apply f_equal. apply functional_extensionality. by elim.
  Qed.

  Definition SMT_get : SMT S := fun s => retn (s,s).
  Definition SMT_set (s':S) : SMT unit := fun s => retn (s',tt).

  Global Coercion SMT_lift {X} (c: M X) : SMT X :=
  fun s => let! r = c; retn (s,r).

  Lemma SMT_bindGet {Y} (s: S) (f: S -> SMT Y):
    bind SMT_get f s = f s s.
  Proof. by rewrite /bind/SMT_get/= id_l. Qed.

  Lemma SMT_doSet {Y} (s s': S) (c: SMT Y):
    (do! SMT_set s'; c) s = c s'.
  Proof. by rewrite /bind/SMT_set/= id_l. Qed.

End StateMT.

End MonadTransformers.


(** * Testcases for [write_as.v]
Authors:
    - Lulof Pirée (1363638)
Creation date: 16 June 2021

--------------------------------------------------------------------------------

This file is part of Waterproof-lib.

Waterproof-lib 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.

Waterproof-lib 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 Waterproof-lib.  If not, see <https://www.gnu.org/licenses/>.
*)
From Ltac2 Require Import Ltac2.
From Ltac2 Require Option.

Require Import Waterproof.message.
Require Import Waterproof.load_database.DisableWildcard.

Load write_as.
Require Import Waterproof.test_auxiliary.

Open Scope nat_scope.
Require Import Arith.
Require Import Bool.

(** * Test 1
    Base case: perform a valid rewrite.
*)
Lemma test_write_as_1: forall x, x = 1 + 1 + 1 -> x = 3.
Proof.
    intros x h.
    Write h as (x = 3).
    assert_hyp_has_type @h constr:(x = 3).
    assumption.
Qed.

(** * Test 1
    Error case: invalid rewrite.
*)
Lemma test_write_as_2: forall x, x = 1 + 1 + 1 -> x = 3.
Proof.
    intros x h.
    let result () := Write h as (x = 4) in
    assert_raises_error result.
Abort.