From Hammer Require Import Hammer.

Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.

Module Type ZQuotProp
(Import A : ZAxiomsSig')
(Import B : ZMulOrderProp A)
(Import C : ZSgnAbsProp A B).

Module Import Private_Div.
Module Quot2Div <: NZDiv A.
Definition div := quot.
Definition modulo := A.rem.
Definition div_wd := quot_wd.
Definition mod_wd := rem_wd.
Definition div_mod := quot_rem.
Definition mod_bound_pos := rem_bound_pos.
End Quot2Div.
Module NZQuot := Nop <+ NZDivProp A Quot2Div B.
End Private_Div.

Ltac pos_or_neg a :=
let LT := fresh "LT" in
let LE := fresh "LE" in
destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT].

Lemma rem_eq :
forall a b, b~=0 -> a rem b == a - b*(a÷b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_eq".
intros.
rewrite <- add_move_l.
symmetry. now apply quot_rem.
Qed.

Lemma rem_opp_opp : forall a b, b ~= 0 -> (-a) rem (-b) == - (a rem b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_opp_opp".   intros. now rewrite rem_opp_r, rem_opp_l. Qed.

Lemma quot_opp_l : forall a b, b ~= 0 -> (-a)÷b == -(a÷b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_opp_l".
intros.
rewrite <- (mul_cancel_l _ _ b) by trivial.
rewrite <- (add_cancel_r _ _ ((-a) rem b)).
now rewrite <- quot_rem, rem_opp_l, mul_opp_r, <- opp_add_distr, <- quot_rem.
Qed.

Lemma quot_opp_r : forall a b, b ~= 0 -> a÷(-b) == -(a÷b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_opp_r".
intros.
assert (-b ~= 0) by (now rewrite eq_opp_l, opp_0).
rewrite <- (mul_cancel_l _ _ (-b)) by trivial.
rewrite <- (add_cancel_r _ _ (a rem (-b))).
now rewrite <- quot_rem, rem_opp_r, mul_opp_opp, <- quot_rem.
Qed.

Lemma quot_opp_opp : forall a b, b ~= 0 -> (-a)÷(-b) == a÷b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_opp_opp".   intros. now rewrite quot_opp_r, quot_opp_l, opp_involutive. Qed.

Theorem quot_rem_unique : forall b q1 q2 r1 r2 : t,
(0<=r1<b \/ b<r1<=0) -> (0<=r2<b \/ b<r2<=0) ->
b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_rem_unique".
intros b q1 q2 r1 r2 Hr1 Hr2 EQ.
destruct Hr1; destruct Hr2; try (intuition; order).
apply NZQuot.div_mod_unique with b; trivial.
rewrite <- (opp_inj_wd r1 r2).
apply NZQuot.div_mod_unique with (-b); trivial.
rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd.
Qed.

Theorem quot_unique:
forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> q == a÷b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_unique".   intros; now apply NZQuot.div_unique with r. Qed.

Theorem rem_unique:
forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> r == a rem b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_unique".   intros; now apply NZQuot.mod_unique with q. Qed.

Lemma quot_same : forall a, a~=0 -> a÷a == 1.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_same".
intros. pos_or_neg a. apply NZQuot.div_same; order.
rewrite <- quot_opp_opp by trivial. now apply NZQuot.div_same.
Qed.

Lemma rem_same : forall a, a~=0 -> a rem a == 0.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_same".
intros. rewrite rem_eq, quot_same by trivial. nzsimpl. apply sub_diag.
Qed.

Theorem quot_small: forall a b, 0<=a<b -> a÷b == 0.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_small".   exact NZQuot.div_small. Qed.

Theorem rem_small: forall a b, 0<=a<b -> a rem b == a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_small".   exact NZQuot.mod_small. Qed.

Lemma quot_0_l: forall a, a~=0 -> 0÷a == 0.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_0_l".
intros. pos_or_neg a. apply NZQuot.div_0_l; order.
rewrite <- quot_opp_opp, opp_0 by trivial. now apply NZQuot.div_0_l.
Qed.

Lemma rem_0_l: forall a, a~=0 -> 0 rem a == 0.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_0_l".
intros; rewrite rem_eq, quot_0_l; now nzsimpl.
Qed.

Lemma quot_1_r: forall a, a÷1 == a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_1_r".
intros. pos_or_neg a. now apply NZQuot.div_1_r.
apply opp_inj. rewrite <- quot_opp_l. apply NZQuot.div_1_r; order.
intro EQ; symmetry in EQ; revert EQ; apply lt_neq, lt_0_1.
Qed.

Lemma rem_1_r: forall a, a rem 1 == 0.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_1_r".
intros. rewrite rem_eq, quot_1_r; nzsimpl; auto using sub_diag.
intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1.
Qed.

Lemma quot_1_l: forall a, 1<a -> 1÷a == 0.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_1_l".   exact NZQuot.div_1_l. Qed.

Lemma rem_1_l: forall a, 1<a -> 1 rem a == 1.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_1_l".   exact NZQuot.mod_1_l. Qed.

Lemma quot_mul : forall a b, b~=0 -> (a*b)÷b == a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_mul".
intros. pos_or_neg a; pos_or_neg b. apply NZQuot.div_mul; order.
rewrite <- quot_opp_opp, <- mul_opp_r by order. apply NZQuot.div_mul; order.
rewrite <- opp_inj_wd, <- quot_opp_l, <- mul_opp_l by order.
apply NZQuot.div_mul; order.
rewrite <- opp_inj_wd, <- quot_opp_r, <- mul_opp_opp by order.
apply NZQuot.div_mul; order.
Qed.

Lemma rem_mul : forall a b, b~=0 -> (a*b) rem b == 0.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_mul".
intros. rewrite rem_eq, quot_mul by trivial. rewrite mul_comm; apply sub_diag.
Qed.

Theorem quot_unique_exact a b q: b~=0 -> a == b*q -> q == a÷b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_unique_exact".
intros Hb H. rewrite H, mul_comm. symmetry. now apply quot_mul.
Qed.

Lemma rem_nonneg : forall a b, b~=0 -> 0 <= a -> 0 <= a rem b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_nonneg".
intros. pos_or_neg b. destruct (rem_bound_pos a b); order.
rewrite <- rem_opp_r; trivial.
destruct (rem_bound_pos a (-b)); trivial.
Qed.

Lemma rem_nonpos : forall a b, b~=0 -> a <= 0 -> a rem b <= 0.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_nonpos".
intros a b Hb Ha.
apply opp_nonneg_nonpos. apply opp_nonneg_nonpos in Ha.
rewrite <- rem_opp_l by trivial. now apply rem_nonneg.
Qed.

Lemma rem_sign_mul : forall a b, b~=0 -> 0 <= (a rem b) * a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_sign_mul".
intros a b Hb. destruct (le_ge_cases 0 a).
apply mul_nonneg_nonneg; trivial. now apply rem_nonneg.
apply mul_nonpos_nonpos; trivial. now apply rem_nonpos.
Qed.

Lemma rem_sign_nz : forall a b, b~=0 -> a rem b ~= 0 ->
sgn (a rem b) == sgn a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_sign_nz".
intros a b Hb H. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]].
rewrite 2 sgn_pos; try easy.
generalize (rem_nonneg a b Hb (lt_le_incl _ _ LT)). order.
now rewrite <- EQ, rem_0_l, sgn_0.
rewrite 2 sgn_neg; try easy.
generalize (rem_nonpos a b Hb (lt_le_incl _ _ LT)). order.
Qed.

Lemma rem_sign : forall a b, a~=0 -> b~=0 -> sgn (a rem b) ~= -sgn a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_sign".
intros a b Ha Hb H.
destruct (eq_decidable (a rem b) 0) as [EQ|NEQ].
apply Ha, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0.
apply Ha, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'.
apply add_move_0_l. rewrite <- H. symmetry. now apply rem_sign_nz.
Qed.

Lemma rem_abs_l : forall a b, b ~= 0 -> (abs a) rem b == abs (a rem b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_abs_l".
intros a b Hb. destruct (le_ge_cases 0 a) as [LE|LE].
rewrite 2 abs_eq; try easy. now apply rem_nonneg.
rewrite 2 abs_neq, rem_opp_l; try easy. now apply rem_nonpos.
Qed.

Lemma rem_abs_r : forall a b, b ~= 0 -> a rem (abs b) == a rem b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_abs_r".
intros a b Hb. destruct (le_ge_cases 0 b).
now rewrite abs_eq. now rewrite abs_neq, ?rem_opp_r.
Qed.

Lemma rem_abs : forall a b,  b ~= 0 -> (abs a) rem (abs b) == abs (a rem b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_abs".
intros. now rewrite rem_abs_r, rem_abs_l.
Qed.

Lemma quot_abs_l : forall a b, b ~= 0 -> (abs a)÷b == (sgn a)*(a÷b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_abs_l".
intros a b Hb. destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]].
rewrite abs_eq, sgn_pos by order. now nzsimpl.
rewrite <- EQ, abs_0, quot_0_l; trivial. now nzsimpl.
rewrite abs_neq, quot_opp_l, sgn_neg by order.
rewrite mul_opp_l. now nzsimpl.
Qed.

Lemma quot_abs_r : forall a b, b ~= 0 -> a÷(abs b) == (sgn b)*(a÷b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_abs_r".
intros a b Hb. destruct (lt_trichotomy 0 b) as [LT|[EQ|LT]].
rewrite abs_eq, sgn_pos by order. now nzsimpl.
order.
rewrite abs_neq, quot_opp_r, sgn_neg by order.
rewrite mul_opp_l. now nzsimpl.
Qed.

Lemma quot_abs : forall a b, b ~= 0 -> (abs a)÷(abs b) == abs (a÷b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_abs".
intros a b Hb.
pos_or_neg a; [rewrite (abs_eq a)|rewrite (abs_neq a)];
try apply opp_nonneg_nonpos; try order.
pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)];
try apply opp_nonneg_nonpos; try order.
rewrite abs_eq; try easy. apply NZQuot.div_pos; order.
rewrite <- abs_opp, <- quot_opp_r, abs_eq; try easy.
apply NZQuot.div_pos; order.
pos_or_neg b; [rewrite (abs_eq b)|rewrite (abs_neq b)];
try apply opp_nonneg_nonpos; try order.
rewrite <- (abs_opp (_÷_)), <- quot_opp_l, abs_eq; try easy.
apply NZQuot.div_pos; order.
rewrite <- (quot_opp_opp a b), abs_eq; try easy.
apply NZQuot.div_pos; order.
Qed.

Lemma rem_bound_abs :
forall a b, b~=0 -> abs (a rem b) < abs b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_bound_abs".
intros. rewrite <- rem_abs; trivial.
apply rem_bound_pos. apply abs_nonneg. now apply abs_pos.
Qed.

Theorem rem_le: forall a b, 0<=a -> 0<b -> a rem b <= a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_le".   exact NZQuot.mod_le. Qed.

Theorem quot_pos : forall a b, 0<=a -> 0<b -> 0<= a÷b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_pos".   exact NZQuot.div_pos. Qed.

Lemma quot_str_pos : forall a b, 0<b<=a -> 0 < a÷b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_str_pos".   exact NZQuot.div_str_pos. Qed.

Lemma quot_small_iff : forall a b, b~=0 -> (a÷b==0 <-> abs a < abs b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_small_iff".
intros. pos_or_neg a; pos_or_neg b.
rewrite NZQuot.div_small_iff; try order. rewrite 2 abs_eq; intuition; order.
rewrite <- opp_inj_wd, opp_0, <- quot_opp_r, NZQuot.div_small_iff by order.
rewrite (abs_eq a), (abs_neq' b); intuition; order.
rewrite <- opp_inj_wd, opp_0, <- quot_opp_l, NZQuot.div_small_iff by order.
rewrite (abs_neq' a), (abs_eq b); intuition; order.
rewrite <- quot_opp_opp, NZQuot.div_small_iff by order.
rewrite (abs_neq' a), (abs_neq' b); intuition; order.
Qed.

Lemma rem_small_iff : forall a b, b~=0 -> (a rem b == a <-> abs a < abs b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_small_iff".
intros. rewrite rem_eq, <- quot_small_iff by order.
rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l.
rewrite eq_sym_iff, eq_mul_0. tauto.
Qed.

Lemma quot_lt : forall a b, 0<a -> 1<b -> a÷b < a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_lt".   exact NZQuot.div_lt. Qed.

Lemma quot_le_mono : forall a b c, 0<c -> a<=b -> a÷c <= b÷c.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_le_mono".
intros. pos_or_neg a. apply NZQuot.div_le_mono; auto.
pos_or_neg b. apply le_trans with 0.
rewrite <- opp_nonneg_nonpos, <- quot_opp_l by order.
apply quot_pos; order.
apply quot_pos; order.
rewrite opp_le_mono in *. rewrite <- 2 quot_opp_l by order.
apply NZQuot.div_le_mono; intuition; order.
Qed.

Lemma mul_quot_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a÷b) <= a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_quot_le".
intros. pos_or_neg b.
split.
apply mul_nonneg_nonneg; [|apply quot_pos]; order.
apply NZQuot.mul_div_le; order.
rewrite <- mul_opp_opp, <- quot_opp_r by order.
split.
apply mul_nonneg_nonneg; [|apply quot_pos]; order.
apply NZQuot.mul_div_le; order.
Qed.

Lemma mul_quot_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a÷b) <= 0.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_quot_ge".
intros.
rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-quot_opp_l by order.
rewrite <- opp_nonneg_nonpos in *.
destruct (mul_quot_le (-a) b); tauto.
Qed.

Lemma mul_succ_quot_gt: forall a b, 0<=a -> 0<b -> a < b*(S (a÷b)).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_succ_quot_gt".   exact NZQuot.mul_succ_div_gt. Qed.

Lemma mul_pred_quot_lt: forall a b, a<=0 -> 0<b -> b*(P (a÷b)) < a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_pred_quot_lt".
intros.
rewrite opp_lt_mono, <- mul_opp_r, opp_pred, <- quot_opp_l by order.
rewrite <- opp_nonneg_nonpos in *.
now apply mul_succ_quot_gt.
Qed.

Lemma mul_pred_quot_gt: forall a b, 0<=a -> b<0 -> a < b*(P (a÷b)).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_pred_quot_gt".
intros.
rewrite <- mul_opp_opp, opp_pred, <- quot_opp_r by order.
rewrite <- opp_pos_neg in *.
now apply mul_succ_quot_gt.
Qed.

Lemma mul_succ_quot_lt: forall a b, a<=0 -> b<0 -> b*(S (a÷b)) < a.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_succ_quot_lt".
intros.
rewrite opp_lt_mono, <- mul_opp_l, <- quot_opp_opp by order.
rewrite <- opp_nonneg_nonpos, <- opp_pos_neg in *.
now apply mul_succ_quot_gt.
Qed.

Lemma quot_exact : forall a b, b~=0 -> (a == b*(a÷b) <-> a rem b == 0).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_exact".
intros. rewrite rem_eq by order. rewrite sub_move_r; nzsimpl; tauto.
Qed.

Theorem quot_lt_upper_bound:
forall a b q, 0<=a -> 0<b -> a < b*q -> a÷b < q.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_lt_upper_bound".   exact NZQuot.div_lt_upper_bound. Qed.

Theorem quot_le_upper_bound:
forall a b q, 0<b -> a <= b*q -> a÷b <= q.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_le_upper_bound".
intros.
rewrite <- (quot_mul q b) by order.
apply quot_le_mono; trivial. now rewrite mul_comm.
Qed.

Theorem quot_le_lower_bound:
forall a b q, 0<b -> b*q <= a -> q <= a÷b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_le_lower_bound".
intros.
rewrite <- (quot_mul q b) by order.
apply quot_le_mono; trivial. now rewrite mul_comm.
Qed.

Lemma quot_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p÷r <= p÷q.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_le_compat_l".   exact NZQuot.div_le_compat_l. Qed.

Lemma rem_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a ->
(a + b * c) rem c == a rem c.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_add".
assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) rem c == a rem c).
intros. pos_or_neg c. apply NZQuot.mod_add; order.
rewrite <- (rem_opp_r a), <- (rem_opp_r (a+b*c)) by order.
rewrite <- mul_opp_opp in *.
apply NZQuot.mod_add; order.
intros a b c Hc Habc.
destruct (le_0_mul _ _ Habc) as [(Habc',Ha)|(Habc',Ha)]. auto.
apply opp_inj. revert Ha Habc'.
rewrite <- 2 opp_nonneg_nonpos.
rewrite <- 2 rem_opp_l, opp_add_distr, <- mul_opp_l by order. auto.
Qed.

Lemma quot_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a ->
(a + b * c) ÷ c == a ÷ c + b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_add".
intros.
rewrite <- (mul_cancel_l _ _ c) by trivial.
rewrite <- (add_cancel_r _ _ ((a+b*c) rem c)).
rewrite <- quot_rem, rem_add by trivial.
now rewrite mul_add_distr_l, add_shuffle0, <-quot_rem, mul_comm.
Qed.

Lemma quot_add_l: forall a b c, b~=0 -> 0 <= (a*b+c)*c ->
(a * b + c) ÷ b == a + c ÷ b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_add_l".
intros a b c. rewrite add_comm, (add_comm a). now apply quot_add.
Qed.

Lemma quot_mul_cancel_r : forall a b c, b~=0 -> c~=0 ->
(a*c)÷(b*c) == a÷b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_mul_cancel_r".
assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a*c)÷(b*c) == a÷b).
intros. pos_or_neg c. apply NZQuot.div_mul_cancel_r; order.
rewrite <- quot_opp_opp, <- 2 mul_opp_r. apply NZQuot.div_mul_cancel_r; order.
rewrite <- neq_mul_0; intuition order.
assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a*c)÷(b*c) == a÷b).
intros. pos_or_neg b. apply Aux1; order.
apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_l; try order. apply Aux1; order.
rewrite <- neq_mul_0; intuition order.
intros. pos_or_neg a. apply Aux2; order.
apply opp_inj. rewrite <- 2 quot_opp_l, <- mul_opp_l; try order. apply Aux2; order.
rewrite <- neq_mul_0; intuition order.
Qed.

Lemma quot_mul_cancel_l : forall a b c, b~=0 -> c~=0 ->
(c*a)÷(c*b) == a÷b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_mul_cancel_l".
intros. rewrite !(mul_comm c); now apply quot_mul_cancel_r.
Qed.

Lemma mul_rem_distr_r: forall a b c, b~=0 -> c~=0 ->
(a*c) rem (b*c) == (a rem b) * c.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_rem_distr_r".
intros.
assert (b*c ~= 0) by (rewrite <- neq_mul_0; tauto).
rewrite ! rem_eq by trivial.
rewrite quot_mul_cancel_r by order.
now rewrite mul_sub_distr_r, <- !mul_assoc, (mul_comm (a÷b) c).
Qed.

Lemma mul_rem_distr_l: forall a b c, b~=0 -> c~=0 ->
(c*a) rem (c*b) == c * (a rem b).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_rem_distr_l".
intros; rewrite !(mul_comm c); now apply mul_rem_distr_r.
Qed.

Theorem rem_rem: forall a n, n~=0 ->
(a rem n) rem n == a rem n.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.rem_rem".
intros. pos_or_neg a; pos_or_neg n. apply NZQuot.mod_mod; order.
rewrite <- ! (rem_opp_r _ n) by trivial. apply NZQuot.mod_mod; order.
apply opp_inj. rewrite <- !rem_opp_l by order. apply NZQuot.mod_mod; order.
apply opp_inj. rewrite <- !rem_opp_opp by order. apply NZQuot.mod_mod; order.
Qed.

Lemma mul_rem_idemp_l : forall a b n, n~=0 ->
((a rem n)*b) rem n == (a*b) rem n.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_rem_idemp_l".
assert (Aux1 : forall a b n, 0<=a -> 0<=b -> n~=0 ->
((a rem n)*b) rem n == (a*b) rem n).
intros. pos_or_neg n. apply NZQuot.mul_mod_idemp_l; order.
rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.mul_mod_idemp_l; order.
assert (Aux2 : forall a b n, 0<=a -> n~=0 ->
((a rem n)*b) rem n == (a*b) rem n).
intros. pos_or_neg b. now apply Aux1.
apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_r by order.
apply Aux1; order.
intros a b n Hn. pos_or_neg a. now apply Aux2.
apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_l, <-rem_opp_l by order.
apply Aux2; order.
Qed.

Lemma mul_rem_idemp_r : forall a b n, n~=0 ->
(a*(b rem n)) rem n == (a*b) rem n.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_rem_idemp_r".
intros. rewrite !(mul_comm a). now apply mul_rem_idemp_l.
Qed.

Theorem mul_rem: forall a b n, n~=0 ->
(a * b) rem n == ((a rem n) * (b rem n)) rem n.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mul_rem".
intros. now rewrite mul_rem_idemp_l, mul_rem_idemp_r.
Qed.

Lemma add_rem_idemp_l : forall a b n, n~=0 -> 0 <= a*b ->
((a rem n)+b) rem n == (a+b) rem n.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.add_rem_idemp_l".
assert (Aux : forall a b n, 0<=a -> 0<=b -> n~=0 ->
((a rem n)+b) rem n == (a+b) rem n).
intros. pos_or_neg n. apply NZQuot.add_mod_idemp_l; order.
rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.add_mod_idemp_l; order.
intros a b n Hn Hab. destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)].
now apply Aux.
apply opp_inj. rewrite <-2 rem_opp_l, 2 opp_add_distr, <-rem_opp_l by order.
rewrite <- opp_nonneg_nonpos in *.
now apply Aux.
Qed.

Lemma add_rem_idemp_r : forall a b n, n~=0 -> 0 <= a*b ->
(a+(b rem n)) rem n == (a+b) rem n.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.add_rem_idemp_r".
intros. rewrite !(add_comm a). apply add_rem_idemp_l; trivial.
now rewrite mul_comm.
Qed.

Theorem add_rem: forall a b n, n~=0 -> 0 <= a*b ->
(a+b) rem n == (a rem n + b rem n) rem n.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.add_rem".
intros a b n Hn Hab. rewrite add_rem_idemp_l, add_rem_idemp_r; trivial.
reflexivity.
destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)];
destruct (le_0_mul _ _ (rem_sign_mul b n Hn)) as [(Hb',Hm)|(Hb',Hm)];
auto using mul_nonneg_nonneg, mul_nonpos_nonpos.
setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order.
setoid_replace b with 0 by order. rewrite rem_0_l by order. nzsimpl; order.
Qed.

Lemma quot_quot : forall a b c, b~=0 -> c~=0 ->
(a÷b)÷c == a÷(b*c).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_quot".
assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a÷b)÷c == a÷(b*c)).
intros. pos_or_neg c. apply NZQuot.div_div; order.
apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_r; trivial.
apply NZQuot.div_div; order.
rewrite <- neq_mul_0; intuition order.
assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a÷b)÷c == a÷(b*c)).
intros. pos_or_neg b. apply Aux1; order.
apply opp_inj. rewrite <- quot_opp_l, <- 2 quot_opp_r, <- mul_opp_l; trivial.
apply Aux1; trivial.
rewrite <- neq_mul_0; intuition order.
intros. pos_or_neg a. apply Aux2; order.
apply opp_inj. rewrite <- 3 quot_opp_l; try order. apply Aux2; order.
rewrite <- neq_mul_0. tauto.
Qed.

Lemma mod_mul_r : forall a b c, b~=0 -> c~=0 ->
a rem (b*c) == a rem b + b*((a÷b) rem c).
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.mod_mul_r".
intros a b c Hb Hc.
apply add_cancel_l with (b*c*(a÷(b*c))).
rewrite <- quot_rem by (apply neq_mul_0; split; order).
rewrite <- quot_quot by trivial.
rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
rewrite <- quot_rem by order.
apply quot_rem; order.
Qed.

Theorem quot_mul_le:
forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a÷b) <= (c*a)÷b.
Proof. hammer_hook "ZDivTrunc" "ZDivTrunc.ZQuotProp.quot_mul_le".   exact NZQuot.div_mul_le. Qed.

End ZQuotProp.


Require Export Sorted.
Require Export CommonDefinitions Point.NatPointCore2D Printers.Nat2D.
(** Is the point in the strip about a given median?  We use an informative type so that we don't care about the implementation. *)
Definition point_in_strip (median_below median_above : nat)
           (median_correct : {median_below = median_above} + {S median_below = median_above})
           (dist : nat)
           (pt : point)
           (x := pt.(x))
           (y := pt.(y))
: {if (x < median_above)%dec then median_above - x <= dist else x - median_below <= dist}
  + {if (x < median_above)%dec then median_above - x > dist else x - median_below > dist}.
Proof.
  destruct (x < median_above)%dec;
  destruct median_correct; subst;
  apply le_gt_dec.
Defined.

(** Given a list of points, a new point, and a distance, add the new point to the list, and remove any points whose y-coordinate is further from the given point than the distance. *)
Definition update_holding_points (holding_points : list point) (new_point : point) (distance : nat) : list point
  := new_point::(filter (fun pt => if (max (pt.(y) - new_point.(y)) (new_point.(y) - pt.(y)) <= distance)%dec
                                   then true
                                   else false)
                        holding_points).

Check (eq_refl : (update_holding_points ((1,2)::(3,4)::(5,6)::nil) (7,8) 6)
                 = (7, 8) :: (1, 2) :: (3, 4) :: (5, 6) :: nil).

(** f takes in the accumulator, the current point, and a list of holding points *)
(** Note: the list of holding points should probably be backed with a doubly-linked list.  But there will be at most a constant number of points in it, so we don't actually care. *)
Definition cmp_y : relation point := (fun pt1 pt2 => pt1.(y) <= pt2.(y)).
Fixpoint fold_points_in_strip {T} (acc : T) (f : point -> list point -> T -> T)
        (strip : list point)
        (strip_sorted : Sorted cmp_y strip)
        (median_below median_above : nat)
        (median_correct : {median_below = median_above} + {S median_below = median_above})
        (dist : nat)
        (holding_points : list point)
: T.
Proof.
  refine (match strip as strip return Sorted cmp_y strip -> T with
            | nil => fun _ => acc
            | pt::pts =>
              fun is_sorted =>
                let pts_is_sorted := match is_sorted return Sorted cmp_y pts with
                                       | _ => _
                                     end in
                if point_in_strip median_correct dist pt
                then let new_acc := f pt holding_points acc in
                     let new_holding_points := update_holding_points holding_points pt dist in
                     @fold_points_in_strip _ new_acc f pts pts_is_sorted _ _ median_correct dist new_holding_points
                else fold_points_in_strip _ acc f pts pts_is_sorted _ _ median_correct dist holding_points
          end strip_sorted).
  revert is_sorted; clear; intro; abstract (inversion_clear is_sorted; assumption).
Defined.

(** Now we find the minimum distance between points in a strip *)
Definition find_min_square_dist_in_strip
           (median_below median_above : nat)
           (median_correct : {median_below = median_above} + {S median_below = median_above})
           (strip : list point) (strip_sorted : Sorted cmp_y strip)
           (half_width : nat)
: option nat
  := fold_points_in_strip
       None
       (fun pt pts cur_min => option_min
                                (fold_left option_min
                                           (map (fun pt' => Some ∥ pt' -- pt ∥²) pts)
                                           None)
                                cur_min)
       strip_sorted
       median_correct
       half_width
       nil.

Goal True.
  pose (fun H => @find_min_square_dist_in_strip 2 3 (right eq_refl) ((1,2)::(3,4)::(5,6)::(7,8)::(9,10)::(11,12)::nil) H 2).
  cbv beta delta [find_min_square_dist_in_strip] in o.
  cbv beta delta [fold_points_in_strip] in o.

Goal True.
  print_list ((1,1)::(2,3)::(4,5)::nil).
  print_list_with_lines ((1,1)::(2,3)::(4,5)::nil) (3::nil).
  print_list_with_lines ((1,1)::(2,3)::(4,5)::nil) (1::3::nil).

  print_grid (.
  match eval hnf in grid with
    | nil => idtac "a"
    | ?r::?rs => idtac r; idtac "a"; print_grid rs
  end.


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

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

Import WfExtensionality.

Lemma subtype_sel_low_sel_equ_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_equ x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (subtype T1 T2').
Proof.
  intros.

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

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


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Monoid.
Require Import ExtLib.Structures.Reducible.
Require Import ExtLib.Structures.Maps.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.PPair.
Require Import ExtLib.Data.Monads.WriterMonad.
Require Import ExtLib.Data.Monads.IdentityMonad.
Require Import ExtLib.Data.Graph.Graph.
Require Import ExtLib.Data.Graph.BuildGraph.

Set Implicit Arguments.
Set Strict Implicit.

Section GraphImpl.
  Variable V : Type.
  Variable map : Type.
  Variable Map : Map V (list V) map.
  Variable FMap : Foldable map (V * (list V)).
  Variable RelDec_V : RelDec (@eq V).

  Definition adj_graph : Type := map.

  Definition verts (g : adj_graph) : list V :=
    let c := foldM (m := writerT (Monoid_list_app) ident)
      (fun k_v _ => let k := fst k_v in tell (k :: nil)) (ret tt) g
    in
    psnd (unIdent (runWriterT c)).

  Definition succs (g : adj_graph) (v : V) : list V :=
    match lookup v g with
      | None => nil
      | Some vs => vs
    end.

  Global Instance Graph_adj_graph : Graph V adj_graph :=
  { verticies := verts
  ; successors := succs
  }.

  Definition add_vertex (v : V) (g : adj_graph) : adj_graph :=
    if contains v g then g else add v nil g.

  (** TODO: Move this **)
  Fixpoint list_in_dec v (ls : list V) : bool :=
    match ls with
    | nil => false
    | l :: ls =>
      if eq_dec l v then true
      else list_in_dec v ls
    end.

  Definition add_edge (f t : V) (g : adj_graph) : adj_graph :=
    match lookup f g with
      | None =>
        add f (t :: nil) g
      | Some vs =>
        if list_in_dec t vs then g
        else add f (t :: vs) g
    end.

  Global Instance GraphBuilder_adj_graph : BuildGraph V adj_graph :=
  { emptyGraph := empty
  ; addVertex := add_vertex
  ; addEdge   := add_edge
  }.

End GraphImpl.


Require Import Coq.Strings.String Coq.omega.Omega Coq.Lists.List Coq.Logic.FunctionalExtensionality Coq.Sets.Ensembles
        Computation ADT ADTRefinement ADTNotation BuildADTRefinements
        KVEnsembles.

Open Scope string_scope.

Section CacheADT.

  Variable Key : Type.
  Variable Value : Type.

  Definition CacheSig : ADTSig :=
    ADTsignature {
        "EmptyCache"  : unit → rep,
        "AddKey" : rep × (Key * Value) → rep × bool,
        "UpdateKey" : rep × (Key * (Value -> Value)) → rep × bool,
        "LookupKey"   : rep × Key → rep × (option Value)
  }.

  Definition CacheSpec : ADT CacheSig :=
    ADTRep (Ensemble (Key * Value)) {
        const "EmptyCache" (_ : unit) : rep :=
          ret (fun _ => False),
        meth "AddKey" (r : rep, kv : Key * Value) : bool :=
            { r' | (SubEnsembleInsert kv r (fst r')) /\
                   ((usedKey r (fst kv) /\ snd r' = false) \/
                    (~ usedKey r (fst kv) /\ snd r' = true))},
        meth "UpdateKey" (r : rep, kv : Key * (Value -> Value)) : bool :=
              { r' |
                (Same_set _ (fst r') (EnsembleUpdate (fst kv) r (snd kv)))
                 /\ ((usedKey r (fst kv) /\ snd r' = true) \/
                     (~ usedKey r (fst kv) -> snd r' = false))},
        meth "LookupKey" (r : rep, k : Key) : option Value :=
                v <- {v | ValidLookup r k v};
        ret (r, v)
      }.

End CacheADT.

Section AddDuplicateKeyStrategies.

  Variable Key : Type.
  Variable Value : Type.

  (* Two strategies : replace the key*)

  Lemma refine_ReplaceUsedKeyAdd
  : forall (kv : Key * Value)
           (r : Ensemble (Key * Value)),
      refine { r' | (SubEnsembleInsert kv r (fst r')) /\
                    ((usedKey r (fst kv) /\ snd r' = false) \/
                     (~ usedKey r (fst kv) /\ snd r' = true))}
             (b <- {b | decides b (usedKey r (fst kv))};
              r' <- If b
                 Then (ret (EnsembleReplace kv r))
                 Else { r' | SubEnsembleInsert kv r r' };
              ret (r', negb b)).
  Proof.
    etransitivity.
    apply refine_pick_decides with
            (P := usedKey r (fst kv));
      intros; refine pick pair;
    (apply refine_bind;
     [reflexivity |
      unfold pointwise_relation; intros;
      refine pick val _;
      [simplify with monad laws; higher_order_1_reflexivity
      | intuition ]]).
    f_equiv; unfold pointwise_relation; intros.
    destruct a; simpl.
    - refine pick val _; try reflexivity.
      apply SubEnsembleInsertReplace.
    - reflexivity.
  Qed.

  Lemma refine_IgnoreUsedKeyAdd
  : forall (kv : Key * Value)
           (r : Ensemble (Key * Value)),
      refine { r' | (SubEnsembleInsert kv r (fst r')) /\
                    ((usedKey r (fst kv) /\ snd r' = false) \/
                     (~ usedKey r (fst kv) /\ snd r' = true))}
             (b <- {b | decides b (usedKey r (fst kv))};
              r' <- If b
                 Then (ret r)
                 Else { r' | SubEnsembleInsert kv r r' };
              ret (r', negb b)).
  Proof.
    etransitivity.
    apply refine_pick_decides with
            (P := usedKey r (fst kv));
      intros; refine pick pair;
    (apply refine_bind;
     [reflexivity |
      unfold pointwise_relation; intros;
      refine pick val _;
      [simplify with monad laws; higher_order_1_reflexivity
      | intuition ]]).
    f_equiv; unfold pointwise_relation; intros.
    destruct a; simpl.
    - refine pick val _; try reflexivity.
      apply SubEnsembleInsertRefl.
    - reflexivity.
  Qed.

End AddDuplicateKeyStrategies.

Section UpdateMissingKeyStrategies.

  Variable Key : Type.
  Variable Value : Type.

  (* Best Practice : Update the key, if its there. *)

  Lemma refine_IgnoreUnusedKeyUpdate
  : forall (kv : Key * (Value -> Value))
           (r : Ensemble (Key * Value)),
      refine { r' |
                (Same_set _ (fst r') (EnsembleUpdate (fst kv) r (snd kv)))
                 /\ ((usedKey r (fst kv) /\ snd r' = true) \/
                     (~ usedKey r (fst kv) -> snd r' = false))}
             (b <- {b | decides b (usedKey r (fst kv))};
              r' <- ret (EnsembleUpdate (fst kv) r (snd kv));
              ret (r', b)).
  Proof.
    etransitivity.
    apply refine_pick_decides with
            (P := usedKey r (fst kv));
      intros; refine pick pair;
    (apply refine_bind;
     [reflexivity |
      unfold pointwise_relation; intros;
      refine pick val _;
      [simplify with monad laws; higher_order_1_reflexivity
      | intuition ]]).
    apply refine_under_bind.
    destruct a; simpl; intros.
    - refine pick val _; [reflexivity | intuition ].
    - inversion_by computes_to_inv; simpl in H.
      f_equiv.
      apply refine_pick_val.
      unfold Same_set, Included; intuition; unfold In in *.
  Qed.

End UpdateMissingKeyStrategies.

Section CacheEvictionStrategies.

  Variable Key : Type.
  Variable Value : Type.

  (* First refinement- determine if there is a key to be replaced. *)

  Lemma refine_SubEnsembleInsert
  : forall (kv : Key * Value)
           (r : Ensemble (Key * Value)),
      refine { r' | (SubEnsembleInsert kv r r')}
             (k_opt <- {k_opt | forall k',
                                    k_opt = Some k' ->
                                    exists v', r (k', v')};
              Ifopt k_opt as k' Then
                                  ret (EnsembleInsert kv
                                                      (EnsembleRemove k' r))
                                  Else
                                  ret (EnsembleInsert kv r)).
  Proof.
    intros; rewrite refine_Pick_If_Then_Opt with
            (P := fun k' => exists v', r (k', v')).
    f_equiv; unfold pointwise_relation; intros; simpl.
    destruct a;
      [ higher_order_1_reflexivity
      | reflexivity ].
    simpl; intros; apply refine_pick_val;
    unfold Same_set, Included, In, SubEnsembleInsert, EnsembleInsert,
    EnsembleRemove in *; simpl; intros; intuition.
    simpl; intros; apply refine_pick_val;
    unfold Same_set, Included, In, SubEnsembleInsert, EnsembleInsert,
    EnsembleRemove in *; simpl; intros; intuition.
  Qed.

  (* Never tab a key for replacement *)
  Lemma refine_pick_KeyToBeReplaced_never
  : forall (r : Ensemble (Key * Value)),
      refine {k_opt | forall k',
                         k_opt = Some k' ->
                         exists v', r (k', v')}
             (ret None).
  Proof.
    intros; rewrite refine_pick_val;
    [ reflexivity
      | discriminate ].
  Qed.

  Section LogicalIndex.

    (* To define various replacement strategies, we're going to
       add a logical index to the pairs of keys and values. *)

    Definition KVEnsemble_EquivalentKeys {A B}
               (ens : Ensemble (Key * A))
               (ens' : Ensemble (Key * B)) :=
      (forall k a, ens (k, a) -> (exists b, ens' (k, b)))
      /\ (forall k b, ens' (k, b) -> (exists a, ens (k, a))).

    Definition CacheADTwLogIndex_AbsR
             (or : Ensemble (Key * Value))
             (nr : Ensemble (Key * Value) *
                   Ensemble (Key * nat))
      := or = (fst nr)
         /\ (KVEnsemble_EquivalentKeys (fst nr) (snd nr)).

    Definition DropLogIndex
               (nr : Ensemble (Key * Value) *
                     Ensemble (Key * nat))
    : Ensemble (Key * Value) :=
      fst nr.

  (* Pick the key with the lowest index for replacement *)
  Lemma refine_pick_KeyToBeReplaced_min
  : forall (r : Ensemble (Key * Value) *
                Ensemble (Key * nat)),
      refine {k_opt | forall k',
                         k_opt = Some k' ->
                         exists v', fst r (k', v')}
             {k_opt | forall k',
                         k_opt = Some k' ->
                         ((exists v', fst r (k', v'))
                          /\ (forall idx ki,
                                snd r (k', idx) ->
                                snd r ki ->
                                idx <= snd ki))
                             }.
  Proof.
    intros; apply refine_pick_pick; intros.
    eapply H; eauto.
  Qed.

  (* Pick the key with the highest index for replacement *)
  Lemma refine_pick_KeyToBeReplaced_max
  : forall (r : Ensemble (Key * Value) *
                Ensemble (Key * nat)),
      refine {k_opt | forall k',
                         k_opt = Some k' ->
                         exists v', fst r (k', v')}
             {k_opt | forall k',
                         k_opt = Some k' ->
                         ((exists v', fst r (k', v'))
                          /\ (forall idx ki,
                                snd r (k', idx) ->
                                snd r ki ->
                                snd ki <= idx))
                             }.
  Proof.
    intros; apply refine_pick_pick; intros.
    eapply H; eauto.
  Qed.

    Lemma refine_LogIndexEmpty
    : refine {nr' |
              CacheADTwLogIndex_AbsR (fun _ : Key * Value => False) nr'}
             (ret (fun _  => False, fun _ => False)).
    Proof.
      apply refine_pick_val;
      unfold CacheADTwLogIndex_AbsR, KVEnsemble_EquivalentKeys; intuition;
      destruct_ex; eauto.
    Qed.

    Lemma refine_LogIndexUsedKey
    : forall n or nr,
        CacheADTwLogIndex_AbsR or nr
        -> refine {b | decides b (usedKey or n)}
               {b | decides b (usedKey (fst nr) n)}.
    Proof.
      unfold CacheADTwLogIndex_AbsR, KVEnsemble_EquivalentKeys;
      intros; apply refine_pick_pick;
      unfold usedKey; simpl; intros; unfold decides;
      find_if_inside; simpl in * ; destruct_ex;
      unfold Same_set, Included, In in *; intuition; subst; eauto.
    Qed.

    Lemma refine_pick_CacheADTwLogIndex_AbsR or' :
          refine
            {nr' | CacheADTwLogIndex_AbsR or' nr'}
            (nr' <- {nr' | KVEnsemble_EquivalentKeys or' nr'};
             ret (or', nr')).
    Proof.
      unfold CacheADTwLogIndex_AbsR; intros.
      setoid_rewrite refineEquiv_pick_pair_snd_dep; simpl.
      refine pick val or'.
      simplify with monad laws; f_equiv.
      unfold Same_set, Included; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Remove {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (a : Key),
             KVEnsemble_EquivalentKeys (EnsembleRemove a ens)
                                       (EnsembleRemove a ens').
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleRemove in *;
        simpl in *; intuition.
      apply H in H3; destruct_ex; eauto.
      apply H0 in H3; destruct_ex; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Replace {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             kb c,
             KVEnsemble_EquivalentKeys (EnsembleReplace kb ens)
                                       (EnsembleReplace (fst kb, c) ens').
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleReplace,
        EnsembleRemove in *;
        simpl in *; intuition; injections; eauto.
      apply H in H3; destruct_ex; eauto.
      apply H0 in H3; destruct_ex; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Update {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             k f g,
             KVEnsemble_EquivalentKeys (EnsembleUpdate k ens f)
                                       (EnsembleUpdate k ens' g).
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleUpdate,
        EnsembleReplace, EnsembleRemove in *;
        simpl in *; intuition; injections; eauto; subst.
      destruct_ex; intuition; eauto; subst.
      apply H in H3; destruct_ex; eauto.
      exists (g x0); left; intuition; eauto.
      apply H in H3; destruct_ex; eauto.
      destruct_ex; intuition; subst.
      apply H0 in H3; destruct_ex;
      eexists; left; intuition; eauto.
      apply H0 in H3; destruct_ex;  eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Refl {B} :
      forall (ens : Ensemble (Key * B)),
        KVEnsemble_EquivalentKeys ens ens.
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleRemove in *;
      simpl in *; intuition; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Insert {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (ab : Key * B) (c : C),
             KVEnsemble_EquivalentKeys (EnsembleInsert ab ens)
                                       (EnsembleInsert (fst ab, c) ens').
    Proof.
      unfold refine; intros.
      unfold KVEnsemble_EquivalentKeys, EnsembleInsert in *;
        simpl in *; intuition; injections; eauto.
      apply H in H2; destruct_ex; eauto.
      apply H0 in H2; destruct_ex; eauto.
    Qed.

    Definition PickID {A} (_ : A) := True.

    Lemma refine_pick_KVEnsembleInsert {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (ab : Key * B),
             refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleInsert ab ens) ens''}
             (b <- {b | @PickID C b};
              ret (EnsembleInsert (fst ab, b) ens')).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Insert,
      KVEnsemble_EquivalentKeys_Remove.
    Qed.

    Lemma refine_pick_KVEnsembleInsertRemove {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (ab : Key * B) k,
        refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleInsert
                           ab
                           (EnsembleRemove k ens)) ens''}
             (b <- {b | @PickID C b};
              ret (EnsembleInsert (fst ab, b)
                                  (EnsembleRemove k ens'))).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Insert,
      KVEnsemble_EquivalentKeys_Remove.
    Qed.

    Lemma refine_pick_KVEnsembleRemove {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             k,
             refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleRemove k ens) ens''}
             (ret (EnsembleRemove k ens')).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Remove.
    Qed.

    Lemma refine_pick_KVEnsembleReplace {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             k,
             refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleReplace k ens) ens''}
             (b <- {b | @PickID C b};
              ret (EnsembleReplace (fst k, b) ens')).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Replace.
    Qed.

    Lemma refine_pick_KVEnsembleUpdate {B C}
    : forall (ens : Ensemble (Key * B))
                (ens' : Ensemble (Key * C))
                (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
                k f,
             refine
               {ens'' | KVEnsemble_EquivalentKeys
                          (EnsembleUpdate k ens f) ens''}
               (b <- {b | @PickID C b};
                ret (EnsembleUpdate k ens' (fun _ => b))).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Update.
    Qed.

    Lemma refine_pick_KVEnsemble {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens'),
             refine
          {ens'' | KVEnsemble_EquivalentKeys ens ens''}
          (ret ens').
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto.
    Qed.
  End LogicalIndex.

End CacheEvictionStrategies.

Require Import String_as_OT.
Require Import FMapAVL.
Module StringIndexedMap := FMapAVL.Make String_as_OT.
Definition MapStringNat := StringIndexedMap.t nat.

Section BoundedStringCacheADT.

(* This is a cache which ignores updates to missing values
   and uses an LRU strategy to pick any elements to remove.
 *)

  Variable Value : Type.
  Variable Bound : nat.

  Definition EnsembleFMapEquivalence {A}
             (ens : Ensemble (string * A))
             (fmap : StringIndexedMap.t A) :=
    forall k,
      (forall a, StringIndexedMap.find k fmap = Some a ->
                 ens (k, a))
      /\ (forall a, ens (k, a) ->
                    StringIndexedMap.find k fmap = Some a).

  Definition FMapCommonKeys {A B}
             (values : StringIndexedMap.t A)
             (indices : StringIndexedMap.t B)
    := forall k,
         (forall a, StringIndexedMap.MapsTo k a values ->
                    exists b, StringIndexedMap.MapsTo k b indices)
         /\ (forall b, StringIndexedMap.MapsTo k b indices ->
                    exists a, StringIndexedMap.MapsTo k a values).

  Definition indexBound
             (indices : StringIndexedMap.t nat)
             (indicesBound : nat)
    := forall k idx,
         StringIndexedMap.find k indices = Some idx ->
         idx <= indicesBound.

  Definition BoundedStringCacheADT_AbsR
             (spec : Ensemble (string * Value)
                     * Ensemble (string * nat))
             (impl : StringIndexedMap.t Value
                     * StringIndexedMap.t nat
                     * nat) :=
    EnsembleFMapEquivalence (fst spec) (fst (fst impl)) /\
    EnsembleFMapEquivalence (snd spec) (snd (fst impl)) /\
    FMapCommonKeys (fst (fst impl)) (snd (fst impl)) /\
    indexBound (snd (fst impl)) (snd impl).

  Lemma decides_usedKey
  : forall (or : Ensemble (string * Value))
           (nr : StringIndexedMap.t Value)
           (k : string),
      EnsembleFMapEquivalence or nr ->
      decides (if StringIndexedMap.find k nr then
                 true else
                 false)
              (usedKey or k).
  Proof.
    unfold EnsembleFMapEquivalence, usedKey; intros;
    pose proof (H k); intuition.
    find_if_inside; simpl; eauto.
    intuition; destruct_ex.
    apply H2 in H0; discriminate.
  Qed.

  Lemma AbsR_add_EnsembleReplace {A}
  : forall nr kv or v,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) (fst kv) nr = Some v
      -> EnsembleFMapEquivalence
           (EnsembleReplace kv or)
           (StringIndexedMap.add (fst kv) (snd kv) nr).
  Proof.
    unfold EnsembleReplace, EnsembleRemove,
    EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k (fst kv)); subst.
    left.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 nr (snd kv) (refl_equal (fst kv))))
      in *; destruct kv; simpl in *; f_equal; congruence.
    right; split; eauto.
    eapply H.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_3,
    StringIndexedMap.find_2.
    subst; simpl in *.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_1.
    destruct (string_dec k (fst kv)); subst.
    simpl in H1; congruence.
    destruct (H k).
    generalize (H4 _ H3).
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_2,
    StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_add_EnsembleUpdate {A}
  : forall nr k f or v,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) k nr = Some v
      -> EnsembleFMapEquivalence
           (EnsembleUpdate k or f)
           (StringIndexedMap.add k (f v) nr).
  Proof.
    unfold EnsembleUpdate, EnsembleRemove,
    EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k0 k); subst.
    left.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 nr (f v) (refl_equal k)))
      in *; simpl in *; f_equal; injections; intuition.
    eexists; split; eauto.
    eapply H; eauto.
    right; split; eauto.
    eapply H.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_3,
    StringIndexedMap.find_2.
    subst; simpl in *.
    destruct_ex; intuition; subst.
    apply H in H3; rewrite H0 in H3; injections.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_1.
    apply H in H3.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_2,
    StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_add_EnsembleUpdate' {A}
  : forall nr k f or,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) k nr = None
      -> EnsembleFMapEquivalence (EnsembleUpdate k or f) nr.
  Proof.
    unfold EnsembleUpdate, EnsembleRemove,
    EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k0 k); subst.
    rewrite H0 in H1; discriminate.
    right; intuition; eapply H; eauto.
    subst; simpl in *.
    destruct_ex; intuition; eapply H in H3; subst.
    destruct_ex; rewrite H0 in *; discriminate.
    eapply H; eauto.
  Qed.

  Lemma AbsR_add_EnsembleInsert {A}
  : forall nr kv or,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) (fst kv) nr = None
      -> EnsembleFMapEquivalence
           (fun kv' => kv' = kv \/ or kv')
           (StringIndexedMap.add (fst kv) (snd kv) nr).
  Proof.
    unfold SubEnsembleInsert, EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k (fst kv)); subst.
    left.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 nr (snd kv) (refl_equal (fst kv))))
      in *; destruct kv; simpl in *; f_equal; congruence.
    right.
    pose proof (H k); intuition.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_3,
    StringIndexedMap.find_2.
    subst; simpl in *.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_1.
    destruct (string_dec k (fst kv)); subst.
    apply H in H2.
    rewrite H0 in H2; discriminate.
    apply H in H2.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_2,
    StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_remove_EnsembleRemove {A}
  : forall nr or k,
      EnsembleFMapEquivalence (A := A) or nr
      -> EnsembleFMapEquivalence
           (EnsembleRemove k or)
           (StringIndexedMap.remove k nr).
  Proof.
    unfold EnsembleRemove, EnsembleFMapEquivalence;
    intros; intuition; simpl in *; subst.
    eapply StringIndexedMap.remove_1; try reflexivity;
    unfold StringIndexedMap.In, StringIndexedMap.Raw.In0;
    simpl; apply StringIndexedMap.find_2 in H0;
    unfold StringIndexedMap.MapsTo, StringIndexedMap.remove in H0;
    simpl in H0; eauto.
    destruct (string_dec k0 k); subst; simpl in *.
    elimtype False.
    eapply StringIndexedMap.remove_1; try reflexivity;
    unfold StringIndexedMap.In, StringIndexedMap.Raw.In0;
    simpl; apply StringIndexedMap.find_2 in H0;
    unfold StringIndexedMap.MapsTo, StringIndexedMap.remove in H0;
    simpl in H0; eauto.
    apply StringIndexedMap.find_2 in H0.
    apply StringIndexedMap.remove_3 in H0; eapply H;
    eauto using StringIndexedMap.find_1.
    apply StringIndexedMap.find_1.
    apply StringIndexedMap.remove_2; eauto.
    eapply H in H2.
    eauto using StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_add_EnsembleInsertRemove {A}
  : forall nr or kv,
      EnsembleFMapEquivalence (A := A) or nr
      -> EnsembleFMapEquivalence
           (EnsembleInsert kv (EnsembleRemove (fst kv) or))
           (StringIndexedMap.add (fst kv) (snd kv) nr).
  Proof.
    unfold SubEnsembleInsert, EnsembleRemove,
    EnsembleInsert, EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k a); subst; simpl in *.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 _ b (refl_equal a)))
      in H0; left; f_equal; congruence.
    right; intuition;
    apply StringIndexedMap.find_2 in H0;
      apply StringIndexedMap.add_3 in H0; eauto.
    eapply H; eauto using StringIndexedMap.find_1.
    unfold StringIndexedMap.In, StringIndexedMap.Raw.In0,
    StringIndexedMap.MapsTo in *; simpl in *; eauto.
    injections.
    eauto using StringIndexedMap.find_1,
    StringIndexedMap.add_1.
    apply H in H2; simpl in *.
    apply StringIndexedMap.find_1;
      apply StringIndexedMap.add_2; eauto.
    eauto using StringIndexedMap.find_1,
      StringIndexedMap.add_2, StringIndexedMap.remove_2,
      StringIndexedMap.find_2.
  Qed.

  Lemma FMapCommonKeys_add {A B}
  : forall k a b
           (ens : StringIndexedMap.t A)
           (ens' : StringIndexedMap.t B),
      FMapCommonKeys ens ens'
      -> FMapCommonKeys
           (StringIndexedMap.add k a ens)
           (StringIndexedMap.add k b ens').
  Proof.
    unfold FMapCommonKeys; intuition;
    (destruct (string_dec k0 k);
     [eexists; eapply StringIndexedMap.add_1; eauto
     |
     eapply StringIndexedMap.add_3 in H0; eauto;
     apply H in H0; destruct_ex;
     eexists; eapply StringIndexedMap.add_2; eauto]).
  Qed.

  Lemma FMapCommonKeys_remove {A B}
  : forall k
           (ens : StringIndexedMap.t A)
           (ens' : StringIndexedMap.t B),
      FMapCommonKeys ens ens'
      -> FMapCommonKeys
           (StringIndexedMap.remove k ens)
           (StringIndexedMap.remove k ens').
  Proof.
    unfold FMapCommonKeys; intuition;
    (destruct (string_dec k0 k);
     [subst; elimtype False;
      eapply (StringIndexedMap.remove_1); eauto;
      unfold StringIndexedMap.In, StringIndexedMap.Raw.In0,
      StringIndexedMap.MapsTo in *; simpl in *; eauto
     |
     eapply StringIndexedMap.remove_3 in H0;
       apply H in H0; destruct_ex;
       eauto using StringIndexedMap.remove_2 ]).
  Qed.

  Lemma indexBound_add
  : forall indices k n,
      indexBound indices n
      -> indexBound (StringIndexedMap.add k n indices) (S n).
  Proof.
    unfold indexBound; intros.
    destruct (string_dec k k0).
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 _ _ e)) in H0.
    injections; omega.
    apply StringIndexedMap.find_2 in H0.
    eapply StringIndexedMap.add_3 in H0; eauto.
    apply StringIndexedMap.find_1 in H0; eauto.
  Qed.

  Lemma indexBound_add_remove
  : forall indices k k' n,
      indexBound indices n
      -> indexBound (StringIndexedMap.add k n
                                          (StringIndexedMap.remove k' indices)) (S n).
  Proof.
    unfold indexBound; intros.
    destruct (string_dec k k0).
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 _ _ e)) in H0.
    injections; omega.
    apply StringIndexedMap.find_2 in H0.
    eapply StringIndexedMap.add_3 in H0; eauto.
    destruct (string_dec k' k0).
    elimtype False;
      eapply (StringIndexedMap.remove_1); eauto;
      unfold StringIndexedMap.In, StringIndexedMap.Raw.In0,
      StringIndexedMap.MapsTo in *; simpl in *; eauto.
    apply StringIndexedMap.remove_3 in H0; eauto.
    apply StringIndexedMap.find_1 in H0; eauto.
  Qed.

  Definition find_minimum_Key
             (indices : StringIndexedMap.t nat)
  : option (string * nat) :=
    StringIndexedMap.fold
      (fun k idx sv =>
         Ifopt sv as sv'
                       Then
                         if (lt_dec idx (snd sv') )
                         then Some (k, idx)
                         else Some sv'
                       Else
                         Some (k, idx))
      indices None.

  Lemma fold_left_In :
    forall l kv p',
   fold_left
     (fun (a : option (StringIndexedMap.key * nat))
        (p : StringIndexedMap.key * nat) =>
      Ifopt a as sv'
      Then if lt_dec (snd p) (snd sv') then Some (fst p, snd p) else Some sv'
      Else Some p) l p' =
   Some kv ->
   (Some kv = p') \/
   SetoidList.InA
     (fun p p' : string * nat => fst p = fst p' /\ snd p = snd p')
     kv l.
  Proof.
    clear; induction l; simpl; intros; subst; eauto.
    destruct p'; simpl in H.
    destruct (lt_dec (snd a) (snd p)).
    destruct (IHl _ _ H).
    right; constructor; injections; simpl; eauto.
    right; constructor 2; eauto.
    destruct (IHl _ _ H).
    injections; eauto.
    eauto.
    right; destruct (IHl _ _ H); injections; eauto.
  Qed.

  Lemma fold_left_min_opt :
    forall l kv p',
   fold_left
     (fun (a : option (StringIndexedMap.key * nat))
        (p : StringIndexedMap.key * nat) =>
      Ifopt a as sv'
      Then if lt_dec (snd p) (snd sv') then Some (fst p, snd p) else Some sv'
      Else Some p) l (Some p') =
   Some kv ->
   snd kv <= snd p'.
  Proof.
    clear; induction l; simpl; intros; subst; eauto.
    injections; eauto.
    destruct (lt_dec (snd a) (snd p')).
    apply le_trans with (m := snd a); eauto with arith.
    eauto.
  Qed.

  Lemma find_minimum_Key_In :
    forall indices kv,
      find_minimum_Key indices = Some kv ->
      StringIndexedMap.MapsTo (elt:=nat) (fst kv) (snd kv) indices.
  Proof.
    intros.
    unfold find_minimum_Key in H.
    rewrite StringIndexedMap.fold_1 in H.
    eapply StringIndexedMap.elements_2.
    destruct (@fold_left_In (StringIndexedMap.elements (elt:=nat) indices) kv None); intuition.
    unfold StringIndexedMap.key in *.
    rewrite <- H; f_equal.
    repeat (apply functional_extensionality; intros); f_equal;
    intuition.
    discriminate.
    destruct kv.
    unfold StringIndexedMap.eq_key_elt, StringIndexedMap.Raw.Proofs.PX.eqke; eauto.
  Qed.

  Lemma find_minimum_Key_correct :
    forall indices kv,
      find_minimum_Key indices = Some kv ->
      forall k v, StringIndexedMap.find k indices = Some v ->
                  snd kv <= v.
  Proof.
    intros.
    unfold find_minimum_Key in H.
    rewrite StringIndexedMap.fold_1 in H.
    apply StringIndexedMap.find_2 in H0.
    apply StringIndexedMap.elements_1 in H0.
    unfold StringIndexedMap.eq_key_elt in H0.
    unfold StringIndexedMap.Raw.Proofs.PX.eqke in H0.
    assert (   forall (k0 : StringIndexedMap.key) (v0 : nat) p',
   fold_left
     (fun (a : option (StringIndexedMap.key * nat))
        (p : StringIndexedMap.key * nat) =>
      Ifopt a as sv'
      Then if lt_dec (snd p) (snd sv') then Some (fst p, snd p) else Some sv'
      Else Some p)
     (StringIndexedMap.elements (elt:=nat) indices) (Some p') =
   Some kv ->

   SetoidList.InA
     (fun p p' : string * nat => fst p = fst p' /\ snd p = snd p')
     (k0, v0) (StringIndexedMap.elements (elt:=nat) indices)
   -> ((snd kv <= snd p') /\( snd kv <= v0 ))).
    { clear; induction (StringIndexedMap.elements (elt:=nat) indices);
      simpl; intros; subst; eauto.
      destruct p'; simpl in H.
      inversion H0; subst; intuition; simpl in *; subst; eauto.
      destruct (lt_dec (snd a) (snd p')).
      inversion H0; subst.
      intuition; simpl in *; intros; subst.
      destruct (fold_left_In _ _ H); injections; simpl;
      auto with arith.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *.
      eauto with arith.
      destruct (fold_left_In _ _ H); injections; simpl;
      auto with arith.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *; eauto with arith.
      intuition.
      destruct (IHl _ _ _ H H2); simpl in *.
      omega.
      destruct (IHl _ _ _ H H2); simpl in *; eauto.
      inversion H0; subst.
      destruct (fold_left_In _ _ H); injections; simpl;
      intuition; simpl in *; subst.
      apply not_gt.
      auto with arith.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *; eauto.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *; eauto.
      eapply le_trans.
      eapply H2.
      apply not_gt; auto with arith.
      destruct (IHl _ _ _ H H2); eauto.
    }
    destruct ((StringIndexedMap.elements (elt:=nat) indices)).
    simpl in H; discriminate.
    simpl in H.
    eapply H1 with (p' := p); eauto.
    simpl.
    destruct (lt_dec (snd p) (snd p)); eauto.
    elimtype False.
    omega.
    rewrite <- H; f_equal.
    repeat (apply functional_extensionality; intros); f_equal.
    destruct x0; reflexivity.
    destruct p; eauto.
  Qed.

  Lemma refine_pick_oldest {V} :
    forall spec_indices impl_indices
           spec_values impl_values,
    EnsembleFMapEquivalence spec_indices impl_indices /\
    EnsembleFMapEquivalence spec_values impl_values /\
    FMapCommonKeys impl_values impl_indices
    ->  refine {k_opt | forall k' : string,
                          k_opt = Some k' ->
                          ((exists v' : V, spec_values (k', v'))
                           /\ (forall (idx : nat) (ki : string * nat),
                                 spec_indices (k', idx) -> spec_indices ki -> idx <= snd ki))}
               (ret (option_map fst (find_minimum_Key impl_indices))).
  Proof.
    unfold refine; intros; inversion_by computes_to_inv; subst.
    econstructor; intros.
    caseEq (find_minimum_Key impl_indices); rewrite H2 in *;
    simpl in *; try discriminate; injections.
    unfold EnsembleFMapEquivalence in *.
    pose proof (find_minimum_Key_correct _ H2).
    pose proof (find_minimum_Key_In _ H2).
    split; intros.
    unfold FMapCommonKeys in H3.
    destruct (H3 (fst p)).
    destruct (H6 (snd p)); eauto.
    destruct (H (fst p)); eexists; eauto.
    eapply H8.
    eauto using StringIndexedMap.find_1.
    apply H1 in H5; destruct ki; eapply H1 in H6. destruct_ex;
    simpl in *.
    eapply StringIndexedMap.find_1 in H4; rewrite H5 in H4.
    injection H4; intros; subst; eauto.
  Qed.

  Lemma refine_If_Then_Else'
  : forall (A : Type) (c : bool) (x x0 y y0 : Comp A),
      (c = true -> refine x y)
      -> (c = false -> refine x0 y0)
      -> refine (If c Then x Else x0) (If c Then y Else y0).
  Proof.
    unfold refine; intros; destruct c; auto.
  Qed.

  Lemma FMapCommonKeys_find_None {A B}
  : forall m m' k,
      FMapCommonKeys m m'
      -> StringIndexedMap.find (elt:=A) k m = None
      -> StringIndexedMap.find (elt:=B) k m' = None .
  Proof.
    intros.
    caseEq (StringIndexedMap.find (elt:=B) k m'); eauto.
    apply StringIndexedMap.find_2 in H1.
    apply H in H1.
    destruct_ex.
    apply StringIndexedMap.find_1 in H1.
    rewrite H1 in H0; discriminate.
  Qed.

  Lemma StringIndexedMap_find_None_remove {V}
  : forall k k' m,
      StringIndexedMap.find (elt:=V) k m = None
      -> StringIndexedMap.find
           (elt:=V) k
           (StringIndexedMap.remove k' m) = None.
  Proof.
    intros.
    caseEq (StringIndexedMap.find (elt:=V) k (StringIndexedMap.remove (elt:=V) k' m)); eauto.
    apply StringIndexedMap.find_2 in H0.
    apply StringIndexedMap.remove_3 in H0;
      apply StringIndexedMap.find_1 in H0;
      congruence.
  Qed.

Tactic Notation "rewrite" "with" "monad" "laws" :=
  repeat first [ setoid_rewrite refineEquiv_bind_bind
               | setoid_rewrite refineEquiv_bind_unit
               | setoid_rewrite refineEquiv_unit_bind].

(* To keep the presentation clean for the paper, we'll
 split and rename the premise holding the abstraction. *)
Ltac split_CacheADTwLogIndex_AbsR :=
  match goal with
      H : CacheADTwLogIndex_AbsR _ _ |- _ =>
      let H' := fresh "Eq_or_nr" in
      let H'' := fresh "EquivKeys_H" in
      destruct H as [H' H'']; rewrite H' in *
  end.

Definition BoundedStringCacheADT
: Sharpened (@CacheSpec string Value).
    Proof.
      unfold CacheSpec.
      hone representation using (@CacheADTwLogIndex_AbsR string Value).
      hone constructor "EmptyCache".
      {
        simplify with monad laws.
        rewrite refine_LogIndexEmpty.
        finish honing.
      }
      hone method "AddKey".
      {
        split_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_pick_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_ReplaceUsedKeyAdd.
        setoid_rewrite refine_SubEnsembleInsert.
        rewrite with monad laws.
        setoid_rewrite refine_pick_KeyToBeReplaced_min.
        setoid_rewrite refine_If_Then_Else_Bind.
        rewrite with monad laws.
        setoid_rewrite refine_If_Opt_Then_Else_Bind.
        rewrite with monad laws.
        pose proof refine_pick_KVEnsembleInsertRemove.
        setoid_rewrite refine_pick_KVEnsembleInsertRemove
                       with (1 := EquivKeys_H).
        setoid_rewrite refine_pick_KVEnsembleInsert
                       with (1 := EquivKeys_H).
        rewrite with monad laws; simpl.
        finish honing.
      }
      hone method "UpdateKey".
      {
        split_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_pick_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_IgnoreUnusedKeyUpdate.
        rewrite with monad laws.
        setoid_rewrite refine_pick_KVEnsembleUpdate
                       with (1 := EquivKeys_H).
        rewrite with monad laws; simpl.
        finish honing.
      }
      hone method "LookupKey".
      {
        split_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_pick_CacheADTwLogIndex_AbsR.
        rewrite with monad laws.
        setoid_rewrite (refine_pick_KVEnsemble EquivKeys_H).
        rewrite with monad laws;  simpl.
        finish honing.
      }

      hone representation using BoundedStringCacheADT_AbsR.

      hone constructor "EmptyCache".
      { simplify with monad laws.
        refine pick val
        (StringIndexedMap.empty Value,
         StringIndexedMap.empty nat,
         0).
        finish honing.
        repeat split; intuition; simpl in *;
        try (eapply (StringIndexedMap.empty_1); eauto;
             eapply (StringIndexedMap.find_2); eauto).
        - elimtype False;
          eapply StringIndexedMap.empty_1; eauto.
        - elimtype False;
          eapply StringIndexedMap.empty_1; eauto.
        - unfold indexBound; intros;
          elimtype False;
          eapply (StringIndexedMap.empty_1);
          eapply (StringIndexedMap.find_2); eauto.
      }

    hone method "LookupKey".
    {
      simplify with monad laws.
      refine pick val (StringIndexedMap.find n (fst (fst r_n))).
      simplify with monad laws; simpl.
      rewrite refine_pick_val by eauto.
      simplify with monad laws.
      finish honing.
      unfold BoundedStringCacheADT_AbsR, ValidLookup in *;
        eapply H0.
    }

    hone method "UpdateKey".
    {
      unfold BoundedStringCacheADT_AbsR in *; split_and.
      simplify with monad laws.
      rewrite refine_pick_val by eauto using decides_usedKey.
      simplify with monad laws; simpl.
      refine pick val (snd r_n); unfold PickID; eauto;
      simplify with monad laws.
      etransitivity.
      apply refine_Pick_Some_dec with
      (P := fun b => StringIndexedMap.find (elt:=Value) (fst n) (fst (fst r_n)) = Some b); intros.
      {
        refine pick val
               (StringIndexedMap.add (fst n) ((snd n) b) (fst (fst r_n)),
                StringIndexedMap.add (fst n) (snd r_n) (snd (fst r_n)),
                S (snd r_n)).
        simplify with monad laws.
        rewrite H3.
        higher_order_1_reflexivity.
        simpl; intuition.
        eauto using AbsR_add_EnsembleUpdate.
        apply StringIndexedMap.find_2 in H3.
        apply H2 in H3; destruct_ex.
        eapply AbsR_add_EnsembleUpdate with (f := fun _ => snd r_n);
          eauto using StringIndexedMap.find_1.
        eauto using FMapCommonKeys_add.
        eauto using indexBound_add.
      }
      {
        refine pick val _; eauto.
        simplify with monad laws; simpl.
        reflexivity.
        caseEq (StringIndexedMap.find (elt:=Value) (fst n) (fst (fst r_n)));
          try solve [elimtype False; eapply H3; eauto];
          intuition; eauto using AbsR_add_EnsembleUpdate'.
        eapply AbsR_add_EnsembleUpdate'; eauto using FMapCommonKeys_find_None.
      }
      refine pick val (StringIndexedMap.find (elt:=Value) (fst n) (fst (fst r_n)));
        try (split; congruence).
      simplify with monad laws.
      finish honing.
    }

    hone method "AddKey".
    {
      unfold BoundedStringCacheADT_AbsR in *; split_and.
      simplify with monad laws.
      rewrite refine_pick_val by eauto using decides_usedKey.
      simplify with monad laws.
      setoid_rewrite refine_If_Then_Else_Bind.
      etransitivity.
      apply refine_If_Then_Else';
        caseEq (StringIndexedMap.find (elt:=Value) (fst n) (fst (fst r_n))); simpl; try discriminate.
      (* If the key is used, do this. *)
      + simplify with monad laws.
        refine pick val (snd r_n); unfold PickID; eauto.
        simplify with monad laws; simpl.
        refine pick val ((_, _), _);
          [ |
            simpl; intuition;
            simpl; eauto using
                         AbsR_add_EnsembleReplace,
                   FMapCommonKeys_remove,
                   FMapCommonKeys_add,
                   AbsR_add_EnsembleInsertRemove,
                   indexBound_add].
        simplify with monad laws.
        reflexivity.
        eapply (AbsR_add_EnsembleInsertRemove (fst n, snd r_n) H0).
      + (* If the key is not used, do this. *)
        simplify with monad laws.
        (* Check to see if we've hit the bound. *)
        apply (refine_if (b := if (gt_dec (snd r_n) Bound)
                               then true
                               else false)); intros.
        (* If we have, then pick a key to remove. *)
        rewrite refine_pick_oldest; eauto.
        simplify with monad laws.
        rewrite refine_If_Opt_Then_Else_Bind.
        (* Should add a constaint that Bound is greater
             than zero- then we can do away with this check. *)
        apply refine_If_Opt_Then_Else.
        * unfold pointwise_relation; intros.
          refine pick val (snd r_n); unfold PickID; eauto.
          simplify with monad laws; simpl.
          refine pick val ((StringIndexedMap.add (elt:=Value) (fst n) (snd n) (StringIndexedMap.remove a (fst (fst r_n))), _), S (snd r_n));
            [ |
              simpl; split; [ | split; [ | split ] ];
              simpl; eauto using
                           AbsR_add_EnsembleInsertRemove,
                     FMapCommonKeys_remove,
                     AbsR_add_EnsembleInsert,
                     AbsR_remove_EnsembleRemove,
                     StringIndexedMap_find_None_remove,
                     FMapCommonKeys_add,
                     indexBound_add_remove].
          simplify with monad laws; simpl.
          higher_order_1_reflexivity.
          apply (@AbsR_add_EnsembleInsert nat);
            eauto using
                AbsR_add_EnsembleInsert, AbsR_remove_EnsembleRemove,
          StringIndexedMap_find_None_remove.
          apply StringIndexedMap_find_None_remove.
          eapply FMapCommonKeys_find_None; eauto.
        * refine pick val (snd r_n); unfold PickID; eauto.
          simplify with monad laws; simpl.
          refine pick val ((_, _), S (snd r_n));
            [ |
              simpl; intuition
                       simpl; eauto using
                                    AbsR_add_EnsembleInsert,
                              FMapCommonKeys_add,
                              indexBound_add;
              eapply (AbsR_add_EnsembleInsert (_, _));
              simpl; eauto using FMapCommonKeys_find_None].
          simplify with monad laws.
          reflexivity.
        * refine pick val None; try discriminate.
          simplify with monad laws.
          refine pick val (snd r_n); unfold PickID; eauto.
          simplify with monad laws; simpl.
          refine pick val ((_, _), S (snd r_n));
            [ |
              simpl; intuition
                       simpl; eauto using
                                    AbsR_add_EnsembleInsert,
                              FMapCommonKeys_add,
                              indexBound_add;
              eapply (AbsR_add_EnsembleInsert (_, _));
              simpl; eauto using FMapCommonKeys_find_None].
          simplify with monad laws.
          reflexivity.
      + finish honing.
    }

    finish sharpening.
    Defined.
F
End BoundedStringCacheADT.


(** * Preface *)

(* $Date: 2011-06-19 12:51:02 -0400 (Sun, 19 Jun 2011) $ *)

(** This electronic book is a one-semester course on _Software
    Foundations_ -- the mathematical theory of programming and
    programming languages -- suitable for graduate or upper-level
    undergraduate students.  It develop basic concepts of functional
    programming, logic, operational semantics, lambda-calculus, and
    static type systems, using the Coq proof assistant.

    The main novelty of the course is that the development is
    formalized and machine-checked: the text is literally a script for
    the Coq proof assistant.  It is intended to be read hand-in-hand
    with the accompanying Coq source file in an interactive session
    with Coq.  All the details of the lectures are fully developed in
    Coq, and the exercises are designed to be worked using Coq.

    The files are organized into a sequence of core chapters, covering
    about one semester's worth of material and organized into a
    coherent linear narrative, plus several "appendices" covering
    additional topics. *)

(* ###################################################################### *)
(** * Overview *)

(** The course weaves together several fundamental themes:
  - _Logic_ as the mathematical basis for software engineering:
<<
                logic                        calculus
         --------------------   =   ----------------------------
         software engineering       mechanical/civil engineering
>>
         In particular, inductively defined sets and relations and
         inductive proofs about them are ubiquitous in all of computer
         science.  The course examines them from many angles.

  - _Functional programming_, an increasingly important part of
    the software developer's bag of tricks:

       - Advanced programming idioms in mainstream software
         development methodologies are increasingly incorporating
         ideas from functional programming.

       - In particular, using persistent data structures and avoiding
         mutable state enormously simplifies many concurrent
         programming tasks.

  - _Foundations of programming languages_ (the second part of the
    course):

        - Notations and techniques for rigorously describing and
          stress-testing new programming languages and language
          features.  (This is a surprisingly common activity!  Most
          large software systems include subsystems that are basically
          programming languages -- think of regular expressions,
          command-line formats, preference and configuration files,
          SQL, Flash, PDF, etc., etc.)

        - A more sophisticated understanding of the everyday tools
          used to build software... what's going on under the hood of
          <your favorite programming language>.

  - _Coq_, an industrial-strength proof assistant:

       - Proof assistants are becoming more and more popular in both
         software and hardware industries.  Coq is not the only one
         out there, but learning one thoroughly will give you a big
         advantage in coming to grips with another.
*)

(* ###################################################################### *)
(** * Practicalities *)

(* ###################################################################### *)
(** ** Chapter Dependencies *)

(** A diagram of the dependencies between chapters and some suggested
    paths through the material can be found in [deps.html]. *)

(* ###################################################################### *)
(** ** Required Background *)

(** These notes are intended to be accessible to a broad range of
    readers, from advanced undergraduates to PhD students and
    researchers.  They assume little specific background in
    programming languages or logic.  However, a degree of mathematical
    maturity will be helpful. *)

(* ###################################################################### *)
(** * Coq *)

(** Our laboratory for this course is the Coq proof assistant.
    Coq can be seen as a combination of two things:
      - a simple and slightly idiosyncratic (but, in its way,
        extremely expressive) _programming language_, together with
      - a set of tools for stating _logical assertions_ (including
        assertions about the behavior of programs) and marshalling
        evidence of their truth.
    We will be investigating both aspects in tandem.
*)

(* ###################################################################### *)
(** ** System Requirements *)

(** Coq runs on Windows and pretty much all flavors of Unix (including
    Linux and OS X).  You will need:
       - A current installation of Coq, available from the Coq home
         page.  (Everything is known to compile with 8.3; version 8.2
         should also work.)
       - An IDE for interacting with Coq.  Currently, there are two choices:
           - Proof General is an Emacs-based IDE.  It tends to be
             preferred by users who are already comfortable with
             Emacs.  It requires a separate installation (google
             "Proof General").
           - CoqIDE is a simpler stand-alone IDE.  It is distributed
             with Coq, but on some platforms compiling it involves
             installing additional packages for GUI libraries and
             such. *)

(* ###################################################################### *)
(** ** Access to the Coq files *)

(** A tar file containing the full sources for the "release version"
    of these notes (as a collection of Coq scripts and HTML files) is
    available here:
<<
        http://www.cis.upenn.edu/~bcpierce/sf
>>
    If you are using the notes as part of a class, you may be given
    access to a locally extended version of the files, which you
    should use instead of the release version.
*)

(* ###################################################################### *)
(** * Exercises *)

(** Each chapter of the notes includes numerous exercises.  Some are
    marked "optional", some "recommended."  Doing just the
    non-optional exercises should provide good coverage of the
    material in approximately six or eight hours of study time (for
    the longer chapters).

    The "star ratings" for the exercises can be interpreted as follows:

       - One star: easy exercises that most readers should take only a
         minute or two.  None of these are explicitly marked
         "Recommended"; rather, _all_ of them should be considered as
         recommended: readers should be in the habit of working them
         as they reach them.

       - Two stars: straightforward exercises (five or ten minutes).

       - Three stars: exercises requiring a bit of thought (fifteen
         minutes to half an hour).

       - Four stars: more difficult exercises (an hour or two).
*)

(* ###################################################################### *)
(** * Recommended Reading *)

(** Some suggestions for supplemental texts can be found in the
    [Postscript] chapter. *)

(* ###################################################################### *)
(** * For Instructors *)

(** If you intend to use these materials in your own course, you will
    undoubtedly find things you'd like to change, improve, or add.
    Your contributions are welcome!

    Please send an email to Benjamin Pierce, and we'll set you up with
    read/write access to our subversion repository and developers'
    mailing list; in the repository you'll find a [README] with further
    instructions. *)


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__equalitysymmetric.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export logic.
Require Export proposition__23B.
Definition proposition__23C : forall A B C D E P, (euclidean__axioms.neq A B) -> ((euclidean__axioms.nCol D C E) -> ((euclidean__axioms.nCol A B P) -> (exists X Y, (euclidean__defs.Out A B Y) /\ ((euclidean__defs.CongA X A Y D C E) /\ (euclidean__defs.OS X P A B))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro P.
intro H.
intro H0.
intro H1.
assert (* Cut *) (~(P = A)) as H2.
- intro H2.
assert (* Cut *) (A = P) as H3.
-- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric A P H2).
-- assert (* Cut *) (euclidean__axioms.Col A B P) as H4.
--- right.
left.
exact H3.
--- apply (@euclidean__tactics.Col__nCol__False A B P H1 H4).
- assert (* Cut *) (exists Q, (euclidean__axioms.BetS P A Q) /\ (euclidean__axioms.Cong A Q P A)) as H3.
-- apply (@lemma__extension.lemma__extension P A P A H2 H2).
-- destruct H3 as [Q H4].
destruct H4 as [H5 H6].
assert (* Cut *) (A = A) as H7.
--- apply (@logic.eq__refl Point A).
--- assert (* Cut *) (euclidean__axioms.Col A B A) as H8.
---- right.
left.
exact H7.
---- assert (* Cut *) (~(euclidean__axioms.Col A B Q)) as H9.
----- intro H9.
assert (* Cut *) (euclidean__axioms.Col P A Q) as H10.
------ right.
right.
right.
right.
left.
exact H5.
------ assert (* Cut *) (euclidean__axioms.Col Q A B) as H11.
------- assert (* Cut *) ((euclidean__axioms.Col B A Q) /\ ((euclidean__axioms.Col B Q A) /\ ((euclidean__axioms.Col Q A B) /\ ((euclidean__axioms.Col A Q B) /\ (euclidean__axioms.Col Q B A))))) as H11.
-------- apply (@lemma__collinearorder.lemma__collinearorder A B Q H9).
-------- destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H16.
------- assert (* Cut *) (euclidean__axioms.Col Q A P) as H12.
-------- assert (* Cut *) ((euclidean__axioms.Col A P Q) /\ ((euclidean__axioms.Col A Q P) /\ ((euclidean__axioms.Col Q P A) /\ ((euclidean__axioms.Col P Q A) /\ (euclidean__axioms.Col Q A P))))) as H12.
--------- apply (@lemma__collinearorder.lemma__collinearorder P A Q H10).
--------- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H20.
-------- assert (* Cut *) (euclidean__axioms.neq A Q) as H13.
--------- assert (* Cut *) ((euclidean__axioms.neq A Q) /\ ((euclidean__axioms.neq P A) /\ (euclidean__axioms.neq P Q))) as H13.
---------- apply (@lemma__betweennotequal.lemma__betweennotequal P A Q H5).
---------- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H14.
--------- assert (* Cut *) (euclidean__axioms.neq Q A) as H14.
---------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A Q H13).
---------- assert (* Cut *) (euclidean__axioms.Col A B P) as H15.
----------- apply (@euclidean__tactics.not__nCol__Col A B P).
------------intro H15.
apply (@euclidean__tactics.Col__nCol__False A B P H15).
-------------apply (@lemma__collinear4.lemma__collinear4 Q A B P H11 H12 H14).

----------- apply (@euclidean__tactics.Col__nCol__False A B P H1 H15).
----- assert (* Cut *) (exists F G, (euclidean__defs.Out A B G) /\ ((euclidean__defs.CongA F A G D C E) /\ (euclidean__axioms.TS F A B Q))) as H10.
------ apply (@proposition__23B.proposition__23B A B C D E Q H H0).
-------apply (@euclidean__tactics.nCol__notCol A B Q H9).

------ destruct H10 as [F H11].
destruct H11 as [G H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
assert (exists J, (euclidean__axioms.BetS F J Q) /\ ((euclidean__axioms.Col A B J) /\ (euclidean__axioms.nCol A B F))) as H17 by exact H16.
destruct H17 as [J H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
assert (* Cut *) (euclidean__defs.OS F P A B) as H23.
------- exists Q.
exists J.
exists A.
split.
-------- exact H21.
-------- split.
--------- exact H8.
--------- split.
---------- exact H19.
---------- split.
----------- exact H5.
----------- split.
------------ exact H22.
------------ exact H1.
------- exists F.
exists G.
split.
-------- exact H13.
-------- split.
--------- exact H15.
--------- exact H23.
Qed.


From Undecidability.L Require Import Computability.MuRec.
From Undecidability.L.Datatypes Require Import LNat LOptions LProd Lists.
From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.

Require Import Datatypes.

Inductive is_computable {A} {t : TT A} (a : A) : Prop :=
  C : computable a -> is_computable a.

Notation enumerates f p := (forall x, p x <-> exists n : nat, f n = Some x).

Definition L_decidable {X} `{encodable X} (P : X -> Prop) :=
  exists f : X -> bool, is_computable f /\ forall x, P x <-> f x = true.

Definition L_enumerable {X} `{encodable X} (p : X -> Prop) :=
  exists f : nat -> option X, is_computable f /\ (enumerates f p).

Definition L_recognisable {X} `{encodable X} (p : X -> Prop) :=
  exists f : X -> nat -> bool, is_computable f /\ forall x, p x <-> exists n, f x n = true.

Definition L_recognisable' {X} `{encodable X} (p : X -> Prop) :=
  exists s : term, forall x, p x <-> converges (L.app s (enc x)).

Section L_enum_rec.

  Variable X : Type.
  Context `{encodable X}.
  Variable (p : X -> Prop).

  Hypotheses (f : nat -> option X) (c_f : computable f) (H_f : enumerates f p).
  Hypotheses (d : X -> X -> bool) (c_d : computable d) (H_d : forall x y, reflect (x = y) (d x y)).

  Definition test := (fun x n => match f n with Some y => d x y | None => false end).

  Instance term_test : computable test.
  Proof using c_f c_d.
    extract.
  Qed.

  Import HOAS_Notations.

  Lemma proc_test (x : X) :
    proc [L_HOAS λ y, !!(ext test) !!(enc x) y].
  Proof.
    cbn. Lproc.
  Qed.

  Lemma L_enumerable_recognisable :
    L_recognisable' p.
  Proof using c_f c_d H_f H_d.
    exists [L_HOAS λ x, !!mu (λ y, !!(ext test) x y)].
    intros. split; intros.
    - eapply H_f in H0 as [n H0].
      edestruct (mu_complete (proc_test x)) with (n := n).
      + intros. exists (test x n0). cbn. now Lsimpl.
      + cbn. Lsimpl. unfold test. rewrite H0. destruct (H_d x x); intuition.
      + exists (ext x0). split; try Lproc.
        cbn. Lsimpl. now rewrite H1.
    - destruct H0 as (v & ? & ?).
      edestruct (mu_sound (proc_test x)) with (v := v) as (n & ? & ? & _).
      + intros. exists (test x n). cbn. now Lsimpl.
      + Lproc.
      + rewrite <- H0. symmetry. cbn. now Lsimpl.
      + subst. eapply H_f. exists n.
        assert ([L_HOAS (λ y, !! (ext test) !! (enc x) y) !!(ext n)] == ext (test x n)).
        cbn. now Lsimpl. cbn in *. rewrite H2 in *.
        eapply unique_normal_forms in H3;[|Lproc..].
        eapply inj_enc in H3.
        unfold test in H3. destruct (f n); inv H3.
        destruct (H_d x x0); firstorder congruence.
  Qed.

End L_enum_rec.

Definition opt_to_list n := match nat_enum n with Some x => [x] | None => [] end.

#[global]
Instance term_opt_to_list : computable opt_to_list.
Proof.
  extract.
Qed.

Definition L_nat := cumul (opt_to_list).

#[global]
Instance term_L_nat : computable L_nat.
Proof.
  unfold L_nat. unfold cumul.
  extract.
Qed.

(* Definition T_nat_nat := Eval cbn in L_T (X := nat * nat). *)

(* Definition pair' : nat * nat -> nat * nat := fun '(x,y) => (x,y). *)

(* Instance term_pair' : computable pair'. *)
(* Proof. *)
(*   extract. *)
(* Qed. *)

From Coq Require Cantor.

(* Instance term_nat_rec {X : Set} `{encodable X} : computable (@nat_rec (fun _ => X)). *)
(* Proof. *)
(*   unfold nat_rec, nat_rect. extract. *)
(* Qed. *)

Definition F' := (fix F (n : nat) : nat := match n with
                                                           | 0 => 0
                                                           | S n0 => S n0 + F n0
                                                           end).

#[global]
Instance term_F' : computable F'.
Proof.
  extract.
Qed.

Definition F'' := (fix F (n0 : nat) : nat * nat := match n0 with
                                                     | 0 => (0, 0)
                                                     | S n1 => match F n1 with
                                                               | (0, y) => (S y, 0)
                                                               | (S x0, y) => (x0, S y)
                                                               end
                                             end).

#[global]
Instance term_F'' : computable F''.
Proof.
  extract.
Qed.

#[global]
Instance term_embed_nat : computable Cantor.to_nat.
Proof.
  change (computable (fun '(x, y) => y + F' (y + x))).
  extract.
Qed.

#[global]
Instance term_unembed_nat : computable Cantor.of_nat.
Proof.
  unfold Cantor.of_nat.
  change (computable F'').
  exact term_F''.
Qed.

(* Definition F''' := (prod_enum nat_enum nat_enum). *)

(* Instance term_prod_enum : computable F'''. *)
(* Proof. *)
(*   unfold F'''. *)
(*   extract. *)
(* Qed. *)

(* Instance term_nat_enum : computable nat_enum. *)
(* Proof. *)
(*   extract. *)
(* Qed. *)

(* Instance term_T_nat_nat : computable T_nat_nat. *)
(* Proof. *)
(*   change (computable *)
(*     (fix f (n : nat) : list (nat * nat) := match n with *)
(*                                            | 0 => [] *)
(*                                            | S n0 => f n0 ++ opt_to_list (F''' n0) *)
(*                                            end)). *)
(*   extract. *)
(* Qed. *)

(* Instance term_R_nat_nat : computable R_nat_nat. *)
(* Proof. *)
(*   change (computable (fun n : nat => nthe n (T_nat_nat n))). *)
(*   extract. *)
(* Qed. *)

(* Instance term_ofNat X `{encodable X} : *)
(*   computable (@ofNat X). *)
(* Proof. *)
(*   extract. *)
(* Qed. *)

Definition lenumerates {X} L (p : X -> Prop) :=
  cumulative L /\ (forall x : X, p x <-> (exists m : nat, x el L m)).

Definition L_enum {X} `{encodable X} (p : X -> Prop) :=
  exists L, is_computable L /\ lenumerates L p.

Lemma projection X Y {HX : encodable X} {HY : encodable Y} (p : X * Y -> Prop) :
  L_enumerable p -> L_enumerable (fun x => exists y, p (x,y)).
Proof.
  intros (f & [cf] & ?).
  exists (fun n => match f n with Some (x, y) => Some x | None => None end).
  split.
  - econstructor. extract.
  - intros; split.
    + intros [y ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
    + intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inv H0.
      exists y. eapply H. eauto.
Qed.

Lemma L_enumerable_ext X `{encodable X} p q : L_enumerable p -> (forall x : X, p x <-> q x) -> L_enumerable q.
Proof.
  intros (f & cf & Hf) He. exists f; split; eauto.
  intros ?. rewrite <- He. eapply Hf.
Qed.

Definition F1 {X} (T : nat -> list X) :=  (fun n => let (n, m) := Cantor.of_nat n in nth_error (T n) m).

#[global]
Instance term_F1 {X} {H : encodable X} :  @computable ((nat -> list X) -> nat -> option X) ((! nat ~> ! list X) ~> ! nat ~> ! option X) (@F1 X).
Proof.
  extract.
Qed.

Lemma L_enumerable_enum {X} `{encodable X} (p : X -> Prop) :
  L_enum p -> L_enumerable p.
Proof.
  intros (f & [cf] & Hf).
  exists (F1 f). split.
  - econstructor. extract.
  - destruct Hf as [CX HX].
    intros x. unfold F1.
    now rewrite list_enumerator_to_enumerator.
Qed.

Lemma L_enumerable_halt {X} `{encodable X} (p : X -> Prop) :
  L_decidable (X := X * X) (fun '(x,y) => x = y) ->
  L_enumerable p -> p ⪯ converges.
Proof.
  intros (d & [c_d] & H_d) (f & [c_f] & H_f).
  edestruct L_enumerable_recognisable with (p := p) (d := fun x y => d (x,y)) (f := f); eauto.
  - extract.
  - intros. specialize (H_d (x,y)). destruct (d (x,y)); intuition (auto with bool).
  - now exists (fun x0 => L.app x (enc x0)).
Qed.

Import L_Notations.

Lemma L_recognisable'_recognisable {X} `{encodable X} (p : X -> Prop) :
  L_recognisable p -> L_recognisable' p.
Proof.
  intros (f & [c_f] & H_f).
  exists (lam (mu (lam (ext f 1 0)))).
  intros.
  assert (((lam (mu (lam ((ext f 1) 0)))) (enc x)) >* mu (lam (ext f (enc x) 0))) by now Lsimpl.
  rewrite H0. rewrite mu_spec.
  - rewrite H_f. split; intros [n]; exists n.
    Lsimpl. now rewrite H1.
    eapply enc_extinj.
    now assert ((lam (((ext f) (enc x)) 0)) (ext n) == enc (f x n)) as <- by now Lsimpl.
  - Lproc.
  - intros. exists (f x n). now Lsimpl.
Qed.

Lemma L_recognisable_halt {X} `{encodable X} (p : X -> Prop) :
  L_recognisable p -> p ⪯ converges.
Proof.
  intros. eapply L_recognisable'_recognisable in H0 as  (f & H_f). now exists (fun x0 => f (enc x0)).
Qed.

Lemma L_recognisable_HaltL {X} {Hreg : encodable X} (p : X -> Prop) :
  L_recognisable p -> p ⪯ HaltL.
Proof.
  intros. eapply L_recognisable'_recognisable in H as  (f & H_f). exists (fun x0 => f (enc x0)).
  intros x. rewrite H_f. unfold converges, HaltL. setoid_rewrite eval_iff. firstorder.
  subst. eapply eproc_equiv in H. eauto.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Bool Utf8. (* → λ ∀ ∃ ↔ ∧ ∨ ≤ ¬ ≠ *)

Require Import unif_graph_def unif_fun.

Set Implicit Arguments.

(** Now proof-irrelevance and fixpoint equations *)

Fact unif_pirr u v (D1 D2 : 𝔻unif u v) : unif D1 = unif D2.
Proof. apply 𝔾unif_fun with u v; apply unif_spec. Qed.

Fact unif_fix_1 c m n : unif (𝔻unif_1 c m n) = None.
Proof. apply 𝔾unif_fun with (2 := in_gu_0 c m n), unif_spec. Qed.

Fact unif_fix_2 c m n : unif (𝔻unif_2 c m n) = None.
Proof. apply 𝔾unif_fun with (2 := in_gu_1 c m n), unif_spec. Qed.

Fact unif_fix_3 c x : unif (𝔻unif_3 c x) = Some ((x,φ c)::∅).
Proof. apply 𝔾unif_fun with (2 := in_gu_2 c x), unif_spec. Qed.

Fact unif_fix_4 m n x : x ≺ m⋄n → unif (𝔻unif_4 m n x) = None.
Proof. intros H; apply 𝔾unif_fun with (2 := in_gu_3 H), unif_spec. Qed.

Fact unif_fix_4' m n x : x ⊀ m⋄n → unif (𝔻unif_4 m n x) = Some ((x,m⋄n)::∅).
Proof. intros H; apply 𝔾unif_fun with (2 := in_gu_4 H), unif_spec. Qed.

Fact unif_fix_5 x m : x ≺ m → unif (𝔻unif_5 x m) = None.
Proof. intros H; apply 𝔾unif_fun with (2 := in_gu_5 _ _ H), unif_spec. Qed.

Fact unif_fix_5' x m : x ⊀ m → unif (𝔻unif_5 x m) = Some ((x,m)::∅).
Proof. intros H; apply 𝔾unif_fun with (2 := in_gu_6 _ _ H), unif_spec. Qed.

Fact unif_fix_6 c : unif (𝔻unif_6 c c) = Some ∅.
Proof. apply 𝔾unif_fun with (2 := in_gu_7 (eq_refl c)), unif_spec. Qed.

Fact unif_fix_6' c d : c ≠ d → unif (𝔻unif_6 c d) = None.
Proof. intros H; apply 𝔾unif_fun with (2 := in_gu_8 H), unif_spec. Qed.

Fact unif_fix_7 m n m' n' (D1 : 𝔻unif m m') (H1 : unif D1 = None) :
            unif (𝔻unif_7 n n' D1 H1) = None.
Proof.
  assert (m⋉m' ⟼u None) as H2.
  { rewrite <- H1; apply unif_spec. }
  apply 𝔾unif_fun with (2 := in_gu_9 n n' H2), unif_spec.
Qed.

Fact unif_fix_8 m n m' n' (D1 : 𝔻unif m m') σ (H1 : unif D1 = Some σ) (D2 : 𝔻unif  n⦃σ⦄ n'⦃σ⦄) :
            unif D2 = None → unif (𝔻unif_8 _ _ D1 H1 D2) = None.
Proof.
  intros H2.
  assert (m⋉m' ⟼u Some σ) as H3.
  { rewrite <- H1; apply unif_spec. }
  assert (n⦃σ⦄ ⋉ n'⦃σ⦄ ⟼u None) as H4.
  { rewrite <- H2; apply unif_spec. }
  apply 𝔾unif_fun with (2 := in_gu_a _ _ H3 H4), unif_spec.
Qed.

Fact unif_fix_8' m n m' n' (D1 : 𝔻unif m m') σ (H1 : unif D1 = Some σ)
                           (D2 : 𝔻unif n⦃σ⦄ n'⦃σ⦄) υ :
            unif D2 = Some υ → unif (𝔻unif_8 _ _ D1 H1 D2) = Some (σ o υ).
Proof.
  intros H2.
  assert (m⋉m' ⟼u Some σ) as H3.
  { rewrite <- H1; apply unif_spec. }
  assert (n⦃σ⦄ ⋉ n'⦃σ⦄ ⟼u Some υ) as H4.
  { rewrite <- H2; apply unif_spec. }
  apply 𝔾unif_fun with (2 := in_gu_b _ _ H3 H4), unif_spec.
Qed.

(** Now we have unif, d_unif and their constructors,
    the induction principle, fixpoint eqs and proof-irrelevance *)


Require Import Arith Extraction.
(** A word on extraction *)

Example nth :
  forall A (l : list A), {n : nat | n < length l} -> A.
Proof.
  intros A l n.
  induction l as [|l' Hl'].
  destruct n as [n Hn].
  - simpl in Hn.
    apply False_rect.
    red in Hn.
    Unset Printing Notations. Print le.
    inversion Hn.
    Set Printing Notations.
  - destruct n as [n Hn].
    destruct n as [|n'].
    + (* 0 *)
      exact l'.
    + (* S n' *)
      apply IHHl'.
      exists n'.
      simpl in Hn.
      apply lt_S_n. apply Hn.
Defined.

Extraction nth.


Require Export P01.

Lemma empty_tree_SearchTree: SearchTree empty_tree.
Proof.
  unfold empty_tree. apply ST_intro with (lo := 0) (hi := 1). constructor. nia.
Qed.