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


Require Import Ascii.
Require Import String.

Require Import MetaCoq.Template.All.
Require Import Coquedille.DenoteCoq.
Require Import Coquedille.PrettyPrinter.

Require Coq.extraction.Extraction.
Extraction Language Haskell.

(* Controlling extraction of specific types *)
Extract Inductive bool => "GHC.Base.Bool" ["GHC.Base.True" "GHC.Base.False"]. (* enumeration types *)
Extract Inductive sumbool => "GHC.Base.Bool" ["GHC.Base.True" "GHC.Base.False"]
.
(* types that require parameters on their constructors *)
(* type, [constructors], recursor *)
Extract Inductive nat => "GHC.Base.Int" ["0" "(\ x -> x Prelude.+ 1)"]
  "(\ zero succ n -> if n GHC.Base.== 0 then zero () else succ (n Prelude.- 1))".

Extract Constant plus             => "(Prelude.+)".
Extract Constant mult             => "(Prelude.*)".
Extract Constant PeanoNat.Nat.eqb => "( Prelude.== )".

(* Properly extract the unicode tokens *)
Extract Constant TkStar    => "['★']".
Extract Constant TkArrow   => "['➔']".
Extract Constant TkPi      => "['Π']".
Extract Constant TkAll     => "['∀']".
Extract Constant TkTDot    => "['·']".
Extract Constant TkULam    => "['Λ']".
Extract Constant TkLam     => "['λ']".
Extract Constant TkMu      => "['μ']".
Extract Constant TkDelta   => "['δ']".
Extract Constant TkBeta    => "['β']".
Extract Constant TkEq      => "['≃']".
Extract Constant TkSigma   => "['σ']".

Extract Inductive ascii => "Prelude.Char"
  [ "(\b0 b1 b2 b3 b4 b5 b6 b7 -> Data.Char.chr ( (if b0 then Data.Bits.shiftL 1 0 else 0) Prelude.+ (if b1 then Data.Bits.shiftL 1 1 else 0) Prelude.+ (if b2 then Data.Bits.shiftL 1 2 else 0) Prelude.+ (if b3 then Data.Bits.shiftL 1 3 else 0) Prelude.+ (if b4 then Data.Bits.shiftL 1 4 else 0) Prelude.+ (if b5 then Data.Bits.shiftL 1 5 else 0) Prelude.+ (if b6 then Data.Bits.shiftL 1 6 else 0) Prelude.+ (if b7 then Data.Bits.shiftL 1 7 else 0)))" ]
  "(\f a -> f (Data.Bits.testBit (Data.Char.ord a) 0) (Data.Bits.testBit (Data.Char.ord a) 1) (Data.Bits.testBit (Data.Char.ord a) 2) (Data.Bits.testBit (Data.Char.ord a) 3) (Data.Bits.testBit (Data.Char.ord a) 4) (Data.Bits.testBit (Data.Char.ord a) 5) (Data.Bits.testBit (Data.Char.ord a) 6) (Data.Bits.testBit (Data.Char.ord a) 7))".
Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)".
Extract Inductive string => "Prelude.String" [ "([])" "(:)" ].
Extract Inlined Constant String.string_dec => "(Prelude.==)".
Extract Inlined Constant String.eqb => "(Prelude.==)".

(* Adds Everything we will test here *)
Quote Recursively Definition nat_syntax := nat.
Quote Recursively Definition list_syntax := list.
Quote Recursively Definition option_syntax := option.
Quote Recursively Definition vector_syntax := Vectors.Vector.t.
Quote Recursively Definition le_syntax := le.
Definition asgn := nat.
Quote Recursively Definition asgn_syntax := asgn.
Quote Recursively Definition mul_syntax := Nat.mul.

Lemma refl1 : 1 = 1.
Proof.
  exact eq_refl.
Qed.
Quote Recursively Definition refl1_syntax := refl1.

Definition L : Type -> Type :=
fun (A: Type) => forall (X: Type), (A -> X -> X) -> X -> X.

Definition lnil : forall A, L A := fun A X _ n => n.

Definition lcons : forall A, A -> L A -> L A :=
fun A h t X c n => c h (t X c n).

Quote Recursively Definition lnil_syntax := lnil.
Quote Recursively Definition lcons_syntax := lcons.

Lemma nileqnil : cons 1 nil = cons 1 nil.
Proof.
  exact eq_refl.
Qed.

Quote Recursively Definition nileqnil_syntax := nileqnil.
Quote Recursively Definition zeroneqS_syntax := O_S.
Quote Recursively Definition iff_syntax := iff.

Set Extraction TypeExpand.
(* We are finally ready to extract the programs we want *)
Extraction "main.hs" PrettySum PrettyProgram denoteCoq
           nat_syntax list_syntax option_syntax vector_syntax le_syntax iff_syntax
           asgn_syntax refl1_syntax lnil_syntax lcons_syntax nileqnil_syntax zeroneqS_syntax mul_syntax.


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.