From Hammer Require Import Hammer.

Require Import ZArith.
Require Import Omega.
Require Import Zquot.

Section Zmissing.

Theorem Zopp_le_cancel :
forall x y : Z,
(-y <= -x)%Z -> Z.le x y.
Proof. hammer_hook "Zaux" "Zaux.Zopp_le_cancel".
intros x y Hxy.
apply Zplus_le_reg_r with (-x - y)%Z.
now ring_simplify.
Qed.

Theorem Zgt_not_eq :
forall x y : Z,
(y < x)%Z -> (x <> y)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zgt_not_eq".
intros x y H Hn.
apply Z.lt_irrefl with x.
now rewrite Hn at 1.
Qed.

End Zmissing.

Section Proof_Irrelevance.

Scheme eq_dep_elim := Induction for eq Sort Type.

Definition eqbool_dep P (h1 : P true) b :=
match b return P b -> Prop with
| true => fun (h2 : P true) => h1 = h2
| false => fun (h2 : P false) => False
end.

Lemma eqbool_irrelevance : forall (b : bool) (h1 h2 : b = true), h1 = h2.
Proof. hammer_hook "Zaux" "Zaux.eqbool_irrelevance".
assert (forall (h : true = true), refl_equal true = h).
apply (eq_dep_elim bool true (eqbool_dep _ _) (refl_equal _)).
intros b.
case b.
intros h1 h2.
now rewrite <- (H h1).
intros h.
discriminate h.
Qed.

End Proof_Irrelevance.

Section Even_Odd.

Theorem Zeven_ex :
forall x, exists p, x = (2 * p + if Z.even x then 0 else 1)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zeven_ex".
intros [|[n|n|]|[n|n|]].
now exists Z0.
now exists (Zpos n).
now exists (Zpos n).
now exists Z0.
exists (Zneg n - 1)%Z.
change (2 * Zneg n - 1 = 2 * (Zneg n - 1) + 1)%Z.
ring.
now exists (Zneg n).
now exists (-1)%Z.
Qed.

End Even_Odd.

Section Zpower.

Theorem Zpower_plus :
forall n k1 k2, (0 <= k1)%Z -> (0 <= k2)%Z ->
Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_plus".
intros n k1 k2 H1 H2.
now apply Zpower_exp ; apply Z.le_ge.
Qed.

Theorem Zpower_Zpower_nat :
forall b e, (0 <= e)%Z ->
Zpower b e = Zpower_nat b (Z.abs_nat e).
Proof. hammer_hook "Zaux" "Zaux.Zpower_Zpower_nat".
intros b [|e|e] He.
apply refl_equal.
apply Zpower_pos_nat.
elim He.
apply refl_equal.
Qed.

Theorem Zpower_nat_S :
forall b e,
Zpower_nat b (S e) = (b * Zpower_nat b e)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_nat_S".
intros b e.
rewrite (Zpower_nat_is_exp 1 e).
apply (f_equal (fun x => x * _)%Z).
apply Zmult_1_r.
Qed.

Theorem Zpower_pos_gt_0 :
forall b p, (0 < b)%Z ->
(0 < Zpower_pos b p)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_pos_gt_0".
intros b p Hb.
rewrite Zpower_pos_nat.
induction (nat_of_P p).
easy.
rewrite Zpower_nat_S.
now apply Zmult_lt_0_compat.
Qed.

Theorem Zeven_Zpower_odd :
forall b e, (0 <= e)%Z -> Z.even b = false ->
Z.even (Zpower b e) = false.
Proof. hammer_hook "Zaux" "Zaux.Zeven_Zpower_odd".
intros b e He Hb.
destruct (Z_le_lt_eq_dec _ _ He) as [He'|He'].
rewrite <- Hb.
now apply Z.even_pow.
now rewrite <- He'.
Qed.

Record radix := { radix_val :> Z ; radix_prop : Zle_bool 2 radix_val = true }.

Theorem radix_val_inj :
forall r1 r2, radix_val r1 = radix_val r2 -> r1 = r2.
Proof. hammer_hook "Zaux" "Zaux.radix_val_inj".
intros (r1, H1) (r2, H2) H.
simpl in H.
revert H1.
rewrite H.
intros H1.
apply f_equal.
apply eqbool_irrelevance.
Qed.

Definition radix2 := Build_radix 2 (refl_equal _).

Variable r : radix.

Theorem radix_gt_0 : (0 < r)%Z.
Proof. hammer_hook "Zaux" "Zaux.radix_gt_0".
apply Z.lt_le_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply r.
Qed.

Theorem radix_gt_1 : (1 < r)%Z.
Proof. hammer_hook "Zaux" "Zaux.radix_gt_1".
destruct r as (v, Hr). simpl.
apply Z.lt_le_trans with 2%Z.
easy.
now apply Zle_bool_imp_le.
Qed.

Theorem Zpower_gt_1 :
forall p,
(0 < p)%Z ->
(1 < Zpower r p)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_gt_1".
intros [|p|p] Hp ; try easy.
simpl.
rewrite Zpower_pos_nat.
generalize (lt_O_nat_of_P p).
induction (nat_of_P p).
easy.
intros _.
rewrite Zpower_nat_S.
assert (0 < Zpower_nat r n)%Z.
clear.
induction n.
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
apply Z.le_lt_trans with (1 * Zpower_nat r n)%Z.
rewrite Zmult_1_l.
now apply (Zlt_le_succ 0).
apply Zmult_lt_compat_r with (1 := H).
apply radix_gt_1.
Qed.

Theorem Zpower_gt_0 :
forall p,
(0 <= p)%Z ->
(0 < Zpower r p)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_gt_0".
intros p Hp.
rewrite Zpower_Zpower_nat with (1 := Hp).
induction (Z.abs_nat p).
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
Qed.

Theorem Zpower_ge_0 :
forall e,
(0 <= Zpower r e)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_ge_0".
intros [|e|e] ; try easy.
apply Zlt_le_weak.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_le :
forall e1 e2, (e1 <= e2)%Z ->
(Zpower r e1 <= Zpower r e2)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_le".
intros e1 e2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite <- (Zmult_1_l (r ^ e1)) at 1.
apply Zmult_le_compat_r.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zpower_ge_0.
now apply Zle_minus_le_0.
clear He.
destruct e1 as [|e1|e1] ; try easy.
apply Zpower_ge_0.
Qed.

Theorem Zpower_lt :
forall e1 e2, (0 <= e2)%Z -> (e1 < e2)%Z ->
(Zpower r e1 < Zpower r e2)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_lt".
intros e1 e2 He2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite Zmult_comm.
rewrite <- (Zmult_1_r (r ^ e1)) at 1.
apply Zmult_lt_compat2.
split.
now apply Zpower_gt_0.
apply Z.le_refl.
split.
easy.
apply Zpower_gt_1.
clear -He ; omega.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
revert H1.
clear -He2.
destruct e1 ; try easy.
intros _.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_lt_Zpower :
forall e1 e2,
(Zpower r (e1 - 1) < Zpower r e2)%Z ->
(e1 <= e2)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_lt_Zpower".
intros e1 e2 He.
apply Znot_gt_le.
intros H.
apply Zlt_not_le with (1 := He).
apply Zpower_le.
clear -H ; omega.
Qed.

Theorem Zpower_gt_id :
forall n, (n < Zpower r n)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zpower_gt_id".
intros [|n|n] ; try easy.
simpl.
rewrite Zpower_pos_nat.
rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
induction (nat_of_P n).
easy.
rewrite inj_S.
change (Zpower_nat r (S n0)) with (r * Zpower_nat r n0)%Z.
unfold Z.succ.
apply Z.lt_le_trans with (r * (Z_of_nat n0 + 1))%Z.
clear.
apply Zlt_0_minus_lt.
replace (r * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((r - 1) * (Z_of_nat n0 + 1))%Z by ring.
apply Zmult_lt_0_compat.
cut (2 <= r)%Z. omega.
apply Zle_bool_imp_le.
apply r.
apply (Zle_lt_succ 0).
apply Zle_0_nat.
apply Zmult_le_compat_l.
now apply Zlt_le_succ.
apply Z.le_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply r.
Qed.

End Zpower.

Section Div_Mod.

Theorem Zmod_mod_mult :
forall n a b, (0 < a)%Z -> (0 <= b)%Z ->
Zmod (Zmod n (a * b)) b = Zmod n b.
Proof. hammer_hook "Zaux" "Zaux.Zmod_mod_mult".
intros n a [|b|b] Ha Hb.
now rewrite 2!Zmod_0_r.
rewrite (Zmod_eq n (a * Zpos b)).
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
apply Z_mod_plus.
easy.
apply Zmult_gt_0_compat.
now apply Z.lt_gt.
easy.
now elim Hb.
Qed.

Theorem ZOmod_eq :
forall a b,
Z.rem a b = (a - Z.quot a b * b)%Z.
Proof. hammer_hook "Zaux" "Zaux.ZOmod_eq".
intros a b.
rewrite (Z.quot_rem' a b) at 2.
ring.
Qed.

Theorem ZOmod_mod_mult :
forall n a b,
Z.rem (Z.rem n (a * b)) b = Z.rem n b.
Proof. hammer_hook "Zaux" "Zaux.ZOmod_mod_mult".
intros n a b.
assert (Z.rem n (a * b) = n + - (Z.quot n (a * b) * a) * b)%Z.
rewrite <- Zopp_mult_distr_l.
rewrite <- Zmult_assoc.
apply ZOmod_eq.
rewrite H.
apply Z_rem_plus.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem Zdiv_mod_mult :
forall n a b, (0 <= a)%Z -> (0 <= b)%Z ->
(Z.div (Zmod n (a * b)) a) = Zmod (Z.div n a) b.
Proof. hammer_hook "Zaux" "Zaux.Zdiv_mod_mult".
intros n a b Ha Hb.
destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha'].
destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|Hb'].
rewrite (Zmod_eq n (a * b)).
rewrite (Zmult_comm a b) at 2.
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
rewrite Z_div_plus by now apply Z.lt_gt.
rewrite <- Zdiv_Zdiv by easy.
apply sym_eq.
apply Zmod_eq.
now apply Z.lt_gt.
now apply Zmult_gt_0_compat ; apply Z.lt_gt.
rewrite <- Hb'.
rewrite Zmult_0_r, 2!Zmod_0_r.
apply Zdiv_0_l.
rewrite <- Ha'.
now rewrite 2!Zdiv_0_r, Zmod_0_l.
Qed.

Theorem ZOdiv_mod_mult :
forall n a b,
(Z.quot (Z.rem n (a * b)) a) = Z.rem (Z.quot n a) b.
Proof. hammer_hook "Zaux" "Zaux.ZOdiv_mod_mult".
intros n a b.
destruct (Z.eq_dec a 0) as [Za|Za].
rewrite Za.
now rewrite 2!Zquot_0_r, Zrem_0_l.
assert (Z.rem n (a * b) = n + - (Z.quot (Z.quot n a) b * b) * a)%Z.
rewrite (ZOmod_eq n (a * b)) at 1.
rewrite Zquot_Zquot.
ring.
rewrite H.
rewrite Z_quot_plus with (2 := Za).
apply sym_eq.
apply ZOmod_eq.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem ZOdiv_small_abs :
forall a b,
(Z.abs a < b)%Z -> Z.quot a b = Z0.
Proof. hammer_hook "Zaux" "Zaux.ZOdiv_small_abs".
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Z.quot_small.
split.
exact H.
now rewrite Z.abs_eq in Ha.
apply Z.opp_inj.
rewrite <- Zquot_opp_l, Z.opp_0.
apply Z.quot_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOmod_small_abs :
forall a b,
(Z.abs a < b)%Z -> Z.rem a b = a.
Proof. hammer_hook "Zaux" "Zaux.ZOmod_small_abs".
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Z.rem_small.
split.
exact H.
now rewrite Z.abs_eq in Ha.
apply Z.opp_inj.
rewrite <- Zrem_opp_l.
apply Z.rem_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOdiv_plus :
forall a b c, (0 <= a * b)%Z ->
(Z.quot (a + b) c = Z.quot a c + Z.quot b c + Z.quot (Z.rem a c + Z.rem b c) c)%Z.
Proof. hammer_hook "Zaux" "Zaux.ZOdiv_plus".
intros a b c Hab.
destruct (Z.eq_dec c 0) as [Zc|Zc].
now rewrite Zc, 4!Zquot_0_r.
apply Zmult_reg_r with (1 := Zc).
rewrite 2!Zmult_plus_distr_l.
assert (forall d, Z.quot d c * c = d - Z.rem d c)%Z.
intros d.
rewrite ZOmod_eq.
ring.
rewrite 4!H.
rewrite <- Zplus_rem with (1 := Hab).
ring.
Qed.

End Div_Mod.

Section Same_sign.

Theorem Zsame_sign_trans :
forall v u w, v <> Z0 ->
(0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zsame_sign_trans".
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now elim Zv.
Qed.

Theorem Zsame_sign_trans_weak :
forall v u w, (v = Z0 -> w = Z0) ->
(0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zsame_sign_trans_weak".
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now discriminate Zv.
Qed.

Theorem Zsame_sign_imp :
forall u v,
(0 < u -> 0 <= v)%Z ->
(0 < -u -> 0 <= -v)%Z ->
(0 <= u * v)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zsame_sign_imp".
intros [|u|u] v Hp Hn.
easy.
apply Zmult_le_0_compat.
easy.
now apply Hp.
replace (Zneg u * v)%Z with (Zpos u * (-v))%Z.
apply Zmult_le_0_compat.
easy.
now apply Hn.
rewrite <- Zopp_mult_distr_r.
apply Zopp_mult_distr_l.
Qed.

Theorem Zsame_sign_odiv :
forall u v, (0 <= v)%Z ->
(0 <= u * Z.quot u v)%Z.
Proof. hammer_hook "Zaux" "Zaux.Zsame_sign_odiv".
intros u v Hv.
apply Zsame_sign_imp ; intros Hu.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
rewrite <- Zquot_opp_l.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
Qed.

End Same_sign.

Section Zeq_bool.

Inductive Zeq_bool_prop (x y : Z) : bool -> Prop :=
| Zeq_bool_true_ : x = y -> Zeq_bool_prop x y true
| Zeq_bool_false_ : x <> y -> Zeq_bool_prop x y false.

Theorem Zeq_bool_spec :
forall x y, Zeq_bool_prop x y (Zeq_bool x y).
Proof. hammer_hook "Zaux" "Zaux.Zeq_bool_spec".
intros x y.
generalize (Zeq_is_eq_bool x y).
case (Zeq_bool x y) ; intros (H1, H2) ; constructor.
now apply H2.
intros H.
specialize (H1 H).
discriminate H1.
Qed.

Theorem Zeq_bool_true :
forall x y, x = y -> Zeq_bool x y = true.
Proof. hammer_hook "Zaux" "Zaux.Zeq_bool_true".
intros x y.
apply -> Zeq_is_eq_bool.
Qed.

Theorem Zeq_bool_false :
forall x y, x <> y -> Zeq_bool x y = false.
Proof. hammer_hook "Zaux" "Zaux.Zeq_bool_false".
intros x y.
generalize (proj2 (Zeq_is_eq_bool x y)).
case Zeq_bool.
intros He Hn.
elim Hn.
now apply He.
now intros _ _.
Qed.

End Zeq_bool.

Section Zle_bool.

Inductive Zle_bool_prop (x y : Z) : bool -> Prop :=
| Zle_bool_true_ : (x <= y)%Z -> Zle_bool_prop x y true
| Zle_bool_false_ : (y < x)%Z -> Zle_bool_prop x y false.

Theorem Zle_bool_spec :
forall x y, Zle_bool_prop x y (Zle_bool x y).
Proof. hammer_hook "Zaux" "Zaux.Zle_bool_spec".
intros x y.
generalize (Zle_is_le_bool x y).
case Zle_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt x y) as [H|H].
now specialize (H1 H).
exact H.
Qed.

Theorem Zle_bool_true :
forall x y : Z,
(x <= y)%Z -> Zle_bool x y = true.
Proof. hammer_hook "Zaux" "Zaux.Zle_bool_true".
intros x y.
apply (proj1 (Zle_is_le_bool x y)).
Qed.

Theorem Zle_bool_false :
forall x y : Z,
(y < x)%Z -> Zle_bool x y = false.
Proof. hammer_hook "Zaux" "Zaux.Zle_bool_false".
intros x y Hxy.
generalize (Zle_cases x y).
case Zle_bool ; intros H.
elim (Z.lt_irrefl x).
now apply Z.le_lt_trans with y.
apply refl_equal.
Qed.

End Zle_bool.

Section Zlt_bool.

Inductive Zlt_bool_prop (x y : Z) : bool -> Prop :=
| Zlt_bool_true_ : (x < y)%Z -> Zlt_bool_prop x y true
| Zlt_bool_false_ : (y <= x)%Z -> Zlt_bool_prop x y false.

Theorem Zlt_bool_spec :
forall x y, Zlt_bool_prop x y (Zlt_bool x y).
Proof. hammer_hook "Zaux" "Zaux.Zlt_bool_spec".
intros x y.
generalize (Zlt_is_lt_bool x y).
case Zlt_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt y x) as [H|H].
exact H.
now specialize (H1 H).
Qed.

Theorem Zlt_bool_true :
forall x y : Z,
(x < y)%Z -> Zlt_bool x y = true.
Proof. hammer_hook "Zaux" "Zaux.Zlt_bool_true".
intros x y.
apply (proj1 (Zlt_is_lt_bool x y)).
Qed.

Theorem Zlt_bool_false :
forall x y : Z,
(y <= x)%Z -> Zlt_bool x y = false.
Proof. hammer_hook "Zaux" "Zaux.Zlt_bool_false".
intros x y Hxy.
generalize (Zlt_cases x y).
case Zlt_bool ; intros H.
elim (Z.lt_irrefl x).
now apply Z.lt_le_trans with y.
apply refl_equal.
Qed.

Theorem negb_Zle_bool :
forall x y : Z,
negb (Zle_bool x y) = Zlt_bool y x.
Proof. hammer_hook "Zaux" "Zaux.negb_Zle_bool".
intros x y.
case Zle_bool_spec ; intros H.
now rewrite Zlt_bool_false.
now rewrite Zlt_bool_true.
Qed.

Theorem negb_Zlt_bool :
forall x y : Z,
negb (Zlt_bool x y) = Zle_bool y x.
Proof. hammer_hook "Zaux" "Zaux.negb_Zlt_bool".
intros x y.
case Zlt_bool_spec ; intros H.
now rewrite Zle_bool_false.
now rewrite Zle_bool_true.
Qed.

End Zlt_bool.

Section Zcompare.

Inductive Zcompare_prop (x y : Z) : comparison -> Prop :=
| Zcompare_Lt_ : (x < y)%Z -> Zcompare_prop x y Lt
| Zcompare_Eq_ : x = y -> Zcompare_prop x y Eq
| Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt.

Theorem Zcompare_spec :
forall x y, Zcompare_prop x y (Z.compare x y).
Proof. hammer_hook "Zaux" "Zaux.Zcompare_spec".
intros x y.
destruct (Z_dec x y) as [[H|H]|H].
generalize (Zlt_compare _ _ H).
case (Z.compare x y) ; try easy.
now constructor.
generalize (Zgt_compare _ _ H).
case (Z.compare x y) ; try easy.
constructor.
now apply Z.gt_lt.
generalize (proj2 (Zcompare_Eq_iff_eq _ _) H).
case (Z.compare x y) ; try easy.
now constructor.
Qed.

Theorem Zcompare_Lt :
forall x y,
(x < y)%Z -> Z.compare x y = Lt.
Proof. hammer_hook "Zaux" "Zaux.Zcompare_Lt".
easy.
Qed.

Theorem Zcompare_Eq :
forall x y,
(x = y)%Z -> Z.compare x y = Eq.
Proof. hammer_hook "Zaux" "Zaux.Zcompare_Eq".
intros x y.
apply <- Zcompare_Eq_iff_eq.
Qed.

Theorem Zcompare_Gt :
forall x y,
(y < x)%Z -> Z.compare x y = Gt.
Proof. hammer_hook "Zaux" "Zaux.Zcompare_Gt".
intros x y.
apply Z.lt_gt.
Qed.

End Zcompare.

Section cond_Zopp.

Definition cond_Zopp (b : bool) m := if b then Z.opp m else m.

Theorem cond_Zopp_negb :
forall x y, cond_Zopp (negb x) y = Z.opp (cond_Zopp x y).
Proof. hammer_hook "Zaux" "Zaux.cond_Zopp_negb".
intros [|] y.
apply sym_eq, Z.opp_involutive.
easy.
Qed.

Theorem abs_cond_Zopp :
forall b m,
Z.abs (cond_Zopp b m) = Z.abs m.
Proof. hammer_hook "Zaux" "Zaux.abs_cond_Zopp".
intros [|] m.
apply Zabs_Zopp.
apply refl_equal.
Qed.

Theorem cond_Zopp_Zlt_bool :
forall m,
cond_Zopp (Zlt_bool m 0) m = Z.abs m.
Proof. hammer_hook "Zaux" "Zaux.cond_Zopp_Zlt_bool".
intros m.
apply sym_eq.
case Zlt_bool_spec ; intros Hm.
apply Zabs_non_eq.
now apply Zlt_le_weak.
now apply Z.abs_eq.
Qed.

End cond_Zopp.

Section fast_pow_pos.

Fixpoint Zfast_pow_pos (v : Z) (e : positive) : Z :=
match e with
| xH => v
| xO e' => Z.square (Zfast_pow_pos v e')
| xI e' => Zmult v (Z.square (Zfast_pow_pos v e'))
end.

Theorem Zfast_pow_pos_correct :
forall v e, Zfast_pow_pos v e = Zpower_pos v e.
Proof. hammer_hook "Zaux" "Zaux.Zfast_pow_pos_correct".
intros v e.
rewrite <- (Zmult_1_r (Zfast_pow_pos v e)).
unfold Z.pow_pos.
generalize 1%Z.
revert v.
induction e ; intros v f ; simpl.
- rewrite <- 2!IHe.
rewrite Z.square_spec.
ring.
- rewrite <- 2!IHe.
rewrite Z.square_spec.
apply eq_sym, Zmult_assoc.
- apply eq_refl.
Qed.

End fast_pow_pos.

Section faster_div.

Lemma Zdiv_eucl_unique :
forall a b,
Z.div_eucl a b = (Z.div a b, Zmod a b).
Proof. hammer_hook "Zaux" "Zaux.Zdiv_eucl_unique".
intros a b.
unfold Z.div, Zmod.
now case Z.div_eucl.
Qed.

Fixpoint Zpos_div_eucl_aux1 (a b : positive) {struct b} :=
match b with
| xO b' =>
match a with
| xO a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r)%Z
| xI a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r + 1)%Z
| xH => (Z0, Zpos a)
end
| xH => (Zpos a, Z0)
| xI _ => Z.pos_div_eucl a (Zpos b)
end.

Lemma Zpos_div_eucl_aux1_correct :
forall a b,
Zpos_div_eucl_aux1 a b = Z.pos_div_eucl a (Zpos b).
Proof. hammer_hook "Zaux" "Zaux.Zpos_div_eucl_aux1_correct".
intros a b.
revert a.
induction b ; intros a.
- easy.
- change (Z.pos_div_eucl a (Zpos b~0)) with (Z.div_eucl (Zpos a) (Zpos b~0)).
rewrite Zdiv_eucl_unique.
change (Zpos b~0) with (2 * Zpos b)%Z.
rewrite Z.rem_mul_r by easy.
rewrite <- Zdiv_Zdiv by easy.
destruct a as [a|a|].
+ change (Zpos_div_eucl_aux1 a~1 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r + 1)%Z).
rewrite IHb. clear IHb.
change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
rewrite Zdiv_eucl_unique.
change (Zpos a~1) with (1 + 2 * Zpos a)%Z.
rewrite (Zmult_comm 2 (Zpos a)).
rewrite Z_div_plus_full by easy.
apply f_equal.
rewrite Z_mod_plus_full.
apply Zplus_comm.
+ change (Zpos_div_eucl_aux1 a~0 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r)%Z).
rewrite IHb. clear IHb.
change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
rewrite Zdiv_eucl_unique.
change (Zpos a~0) with (2 * Zpos a)%Z.
rewrite (Zmult_comm 2 (Zpos a)).
rewrite Z_div_mult_full by easy.
apply f_equal.
now rewrite Z_mod_mult.
+ easy.
- change (Z.pos_div_eucl a 1) with (Z.div_eucl (Zpos a) 1).
rewrite Zdiv_eucl_unique.
now rewrite Zdiv_1_r, Zmod_1_r.
Qed.

Definition Zpos_div_eucl_aux (a b : positive) :=
match Pos.compare a b with
| Lt => (Z0, Zpos a)
| Eq => (1%Z, Z0)
| Gt => Zpos_div_eucl_aux1 a b
end.

Lemma Zpos_div_eucl_aux_correct :
forall a b,
Zpos_div_eucl_aux a b = Z.pos_div_eucl a (Zpos b).
Proof. hammer_hook "Zaux" "Zaux.Zpos_div_eucl_aux_correct".
intros a b.
unfold Zpos_div_eucl_aux.
change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
rewrite Zdiv_eucl_unique.
case Pos.compare_spec ; intros H.
now rewrite H, Z_div_same, Z_mod_same.
now rewrite Zdiv_small, Zmod_small by (split ; easy).
rewrite Zpos_div_eucl_aux1_correct.
change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
apply Zdiv_eucl_unique.
Qed.

Definition Zfast_div_eucl (a b : Z) :=
match a with
| Z0 => (0, 0)%Z
| Zpos a' =>
match b with
| Z0 => (0, 0)%Z
| Zpos b' => Zpos_div_eucl_aux a' b'
| Zneg b' =>
let (q, r) := Zpos_div_eucl_aux a' b' in
match r with
| Z0 => (-q, 0)%Z
| Zpos _ => (-(q + 1), (b + r))%Z
| Zneg _ => (-(q + 1), (b + r))%Z
end
end
| Zneg a' =>
match b with
| Z0 => (0, 0)%Z
| Zpos b' =>
let (q, r) := Zpos_div_eucl_aux a' b' in
match r with
| Z0 => (-q, 0)%Z
| Zpos _ => (-(q + 1), (b - r))%Z
| Zneg _ => (-(q + 1), (b - r))%Z
end
| Zneg b' => let (q, r) := Zpos_div_eucl_aux a' b' in (q, (-r)%Z)
end
end.

Theorem Zfast_div_eucl_correct :
forall a b : Z,
Zfast_div_eucl a b = Z.div_eucl a b.
Proof. hammer_hook "Zaux" "Zaux.Zfast_div_eucl_correct".
unfold Zfast_div_eucl.
intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy.
Qed.

End faster_div.

Section Iter.

Context {A : Type}.
Variable (f : A -> A).

Fixpoint iter_nat (n : nat) (x : A) {struct n} : A :=
match n with
| S n' => iter_nat n' (f x)
| O => x
end.

Lemma iter_nat_plus :
forall (p q : nat) (x : A),
iter_nat (p + q) x = iter_nat p (iter_nat q x).
Proof. hammer_hook "Zaux" "Zaux.iter_nat_plus".
induction q.
now rewrite plus_0_r.
intros x.
rewrite <- plus_n_Sm.
apply IHq.
Qed.

Lemma iter_nat_S :
forall (p : nat) (x : A),
iter_nat (S p) x = f (iter_nat p x).
Proof. hammer_hook "Zaux" "Zaux.iter_nat_S".
induction p.
easy.
simpl.
intros x.
apply IHp.
Qed.

Fixpoint iter_pos (n : positive) (x : A) {struct n} : A :=
match n with
| xI n' => iter_pos n' (iter_pos n' (f x))
| xO n' => iter_pos n' (iter_pos n' x)
| xH => f x
end.

Lemma iter_pos_nat :
forall (p : positive) (x : A),
iter_pos p x = iter_nat (Pos.to_nat p) x.
Proof. hammer_hook "Zaux" "Zaux.iter_pos_nat".
induction p ; intros x.
rewrite Pos2Nat.inj_xI.
simpl.
rewrite plus_0_r.
rewrite iter_nat_plus.
rewrite (IHp (f x)).
apply IHp.
rewrite Pos2Nat.inj_xO.
simpl.
rewrite plus_0_r.
rewrite iter_nat_plus.
rewrite (IHp x).
apply IHp.
easy.
Qed.

End Iter.


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import HoTT.Basics.
Require Import Types.Universe Types.Arrow Types.Sigma.
Require Import HSet HProp UnivalenceImpliesFunext TruncType.
Require Import HIT.epi HIT.Truncations HIT.Connectedness.

Local Open Scope path_scope.

(* My modified version on quotient.v. I only remove that R should be a mere relation -K *)

(** * Quotient of a Type by an hprop-valued relation

We aim to model:
<<
Inductive quotient : Type :=
   | class_of : A -> quotient
   | related_classes_eq : forall x y, (R x y), class_of x = class_of y
   | quotient_set : IsHSet quotient
>>
*)

(** This development should be further connected with the sections in the book; see below.*)

Module Export Set_Quotient.

  Section Domain.

    Context {A : Type}.

    (** We choose to let the definition of quotient depend on the proof that [R] is a set-relations.  Alternatively, we could have defined it for all relations and only develop the theory for set-relations.  The former seems more natural.

NOTE: I AM CHANGING THIS TO THE LATTER

We do not require [R] to be an equivalence relation, but implicitly consider its transitive-reflexive closure. *)

    (** Note: If we wanted to be really accurate, we'd need to put [@quotient A R sr] in the max [U_{sup(i, j)}] of the universes of [A : U_i] and [R : A -> A -> U_j].  But this requires some hacky code, at the moment, and the only thing we gain is avoiding making use of an implicit hpropositional resizing "axiom". *)

    (** This definition has a parameter [sR] that shadows the ambient one in the Context in order to ensure that it actually ends up depending on everything in the Context when the section is closed, since its definition doesn't actually refer to any of them.  *)
    Private Inductive set_quotient (R : relation A): Type :=
    | class_of : A -> set_quotient R.

    (** The path constructors. *)
    Axiom related_classes_eq
    : forall {R : relation A} {x y : A}, R x y ->
                        class_of R x = class_of R y.

    Context (R : relation A).

    Axiom set_quotient_set : IsHSet (set_quotient R).
    Global Existing Instance set_quotient_set.

    Definition set_quotient_ind (P : (set_quotient R) -> Type) {sP : forall x, IsHSet (P x)}
               (dclass : forall x, P (class_of R x))
               (dequiv : (forall x y (H : R x y), (related_classes_eq H) # (dclass x) = dclass y))
    : forall q, P q
      := fun q => match q with class_of a => fun _ _ => dclass a end sP dequiv.

    Definition set_quotient_ind_compute {P sP} dclass dequiv x
    : @set_quotient_ind P sP dclass dequiv (class_of R x) = dclass x.
    Proof.
      reflexivity.
    Defined.

    (** Again equality of paths needs to be postulated *)
    Axiom set_quotient_ind_compute_path
    : forall P sP dclass dequiv,
      forall x y (H : R x y),
        apD (@set_quotient_ind P sP dclass dequiv) (related_classes_eq H)
        = dequiv x y H.

  End Domain.

End Set_Quotient.

Section rec.
  Context `{Univalence}.

  Context {A : Type} (R : relation A) .
  Definition set_quotient_rec {B : Type} {sB : IsHSet B}
             (dclass : (forall x : A, B))
             (dequiv : (forall x y, R x y -> dclass x = dclass y))
  : set_quotient R -> B.
  Proof.
    apply (set_quotient_ind R (fun _ : set_quotient _ => B)) with dclass.
    intros ?? H'. destruct (related_classes_eq H'). by apply dequiv.
  Defined.

  Definition set_quotient_rec2 {B : hSet} {dclass : (A -> A -> B)} :
             (forall x x' y, R x x' -> dclass x y = dclass x' y) ->
             (forall x y y', R y y' -> dclass x y = dclass x y') ->
      set_quotient R -> set_quotient R -> B.
  Proof.
    intros dequiv1 dequiv0.
    (* assert (dequiv0 : forall x x0 y : A, R x0 y -> dclass x x0 = dclass x y) *)
    (*   by (intros ? ? ? Hx; apply dequiv;[apply Hrefl|done]). *)
    refine (set_quotient_rec
              (fun x => set_quotient_rec (dclass x) (dequiv0 x)) _).
    intros x x' Hx.
    assert (h : dclass x = dclass x').
    { exact (path_arrow (dclass x) (dclass x') (fun y => dequiv1 x x' y Hx)). }

    apply path_forall. red.
    (* assert (dequiv1 : forall y : A, *)
    (*                     set_quotient_rec (dclass x) (dequiv0 x) (class_of _ y) = *)
    (*                     set_quotient_rec (dclass x') (dequiv0 x') (class_of _ y)) *)
    (*   by (intros; by apply dequiv). *)
    srapply (set_quotient_ind R).
    - intro a. simpl. apply (dequiv1 _ _ _ Hx).
    - intros. apply path_ishprop.
  Defined.
End rec.

Section Equiv.

  Context `{Univalence}.

  Context {A : Type} (R : relation A)
          {Htrans : Transitive R} {Hsymm : Symmetric R}.

  Lemma set_quotient_path2 : forall {x y : set_quotient R} (p q : x=y), p=q.
  Proof.
    apply @set_path2. apply _.
  Defined.

  Definition in_class {sR: is_mere_relation _ R} : set_quotient R -> A -> hProp.
  Proof.
    refine (set_quotient_ind R (fun _ => A -> hProp) (fun a b => BuildhProp (R a b)) _).
    intros. eapply concat;[apply transport_const|].
    apply path_forall. intro z. apply path_hprop; simpl.
    apply @equiv_iff_hprop; eauto.
  Defined.

  Context {Hrefl : Reflexive R}.

  Lemma in_class_pr {sR: is_mere_relation _ R} : forall x y, (in_class (class_of R x) y : Type) = R x y.
  Proof.
    reflexivity.
  Defined.

  Lemma set_quotient_ind_prop (P : set_quotient R -> Type)
        `{forall x, IsHProp (P x)} :
    forall dclass : forall x, P (class_of R x),
    forall q, P q.
  Proof.
    intros. apply (set_quotient_ind R P dclass).
    intros. apply path_ishprop.
  Defined.

  Global Instance decidable_in_class `{forall x y, Decidable (R x y)} {sR: is_mere_relation _ R}
  : forall x a, Decidable (in_class x a).
  Proof.
    refine (set_quotient_ind_prop _ _).
    intros a b; exact (transport Decidable (in_class_pr a b) _).
  Defined.

  Lemma class_of_repr {sR: is_mere_relation _ R}: forall q x, in_class q x -> q = class_of R x.
  Proof.
    apply (set_quotient_ind R
                        (fun q : set_quotient R => forall x, in_class q x -> q = class_of _ x)
                        (fun x y H => related_classes_eq H)).
    intros.
    apply path_forall. intro z.
    apply path_forall;intro H'.
    apply set_quotient_path2.
  Defined.

  Lemma classes_eq_related {sR: is_mere_relation _ R} : forall x y,
                               class_of R x = class_of R y -> R x y.
  Proof.
    intros x y H'.
    pattern (R x y).
    eapply transport.
    - apply in_class_pr.
    - pattern (class_of R x). apply (transport _ (H'^)).
      apply Hrefl.
  Defined.

  (** Thm 10.1.8 *)
  Theorem sets_exact {sR: is_mere_relation _ R} : forall x y, (class_of R x = class_of R y) <~> R x y.
    intros ??. apply equiv_iff_hprop.
    - apply classes_eq_related.
    - apply related_classes_eq.
  Defined.

  Definition set_quotient_ind_prop' : forall P : set_quotient R -> Type,
                                  forall (Hprop' : forall x, IsHProp (P (class_of _ x))),
                                    (forall x, P (class_of _ x)) -> forall y, P y.
  Proof.
    intros ? ? dclass. apply set_quotient_ind with dclass.
    - simple refine (set_quotient_ind R (fun x => IsHSet (P x)) _ _); cbn beta; try exact _.
      intros; apply path_ishprop.
    - intros. apply Hprop'.
  Defined.

  (** From Ch6 *)
  Theorem set_quotient_surjective: IsSurjection (class_of R).
  Proof.
    apply BuildIsSurjection.
    apply (set_quotient_ind_prop (fun y => merely (hfiber (class_of R) y))); try exact _.
    intro x. apply tr. by exists x.
  Defined.

  (** From Ch10 *)
  Definition set_quotient_ump' (B:hSet): (set_quotient R -> B) ->
                                     (sigT (fun f : A-> B => (forall a a0:A, R a a0 -> f a =f a0))).
    intro f. exists (compose f (class_of R) ).
    intros. f_ap. by apply related_classes_eq.
  Defined.

  (* Definition set_quotient_ump'' (B:hSet): (sigT (fun f : A-> B => (forall a a0:A, R a a0 -> f a =f a0))) *)
  (*                                     -> set_quotient R -> B. *)
  (*   intros [f H']. *)
  (*   apply (set_quotient_rec _ H'). *)
  (* Defined. *)

  (* Theorem set_quotient_ump (B:hSet): (set_quotient R -> B) <~> *)
  (*                                                  (sigT (fun f : A-> B => (forall a a0:A, R a a0 -> f a =f a0))). *)
  (* Proof. *)
  (*   refine (equiv_adjointify (set_quotient_ump' B) (set_quotient_ump'' B) _ _). *)
  (*   intros [f Hf]. *)
  (*   - by apply equiv_path_sigma_hprop. *)
  (*   - intros f. *)
  (*     apply path_forall. *)
  (*     red. apply set_quotient_ind_prop';[apply _|reflexivity]. *)
  (* Defined. *)

  (** Missing

  The equivalence with VVset_quotient [A//R].

  This should lead to the unnamed theorem:

  10.1.10. Equivalence relations are effective and there is an equivalence [A/R<~>A//R]. *)

  (**
  The theory of canonical quotients is developed by C.Cohen:
  http://perso.crans.org/cohen/work/quotients/
 *)

End Equiv.

Section Functoriality.

  Definition set_quotient_functor
             {A : Type} (R : relation A) {sR: is_mere_relation _ R}
             {B : Type} (S : relation B) {sS: is_mere_relation _ S}
             (f : A -> B) (fresp : forall x y, R x y -> S (f x) (f y))
  : set_quotient R -> set_quotient S.
  Proof.
    refine (set_quotient_rec R (class_of S o f) _).
    intros x y r.
    apply related_classes_eq, fresp, r.
  Defined.

  Context {A : Type} (R : relation A) {sR: is_mere_relation _ R}
          {B : Type} (S : relation B) {sS: is_mere_relation _ S}.

  Global Instance set_quotient_functor_isequiv
             (f : A -> B) (fresp : forall x y, R x y <-> S (f x) (f y))
             `{IsEquiv _ _ f}
  : IsEquiv (set_quotient_functor R S f (fun x y => fst (fresp x y))).
  Proof.
    simple refine (isequiv_adjointify _ (set_quotient_functor S R f^-1 _)
                               _ _).
    - intros u v s.
      apply (snd (fresp _ _)).
      abstract (do 2 rewrite eisretr; apply s).
    - intros x; revert x; simple refine (set_quotient_ind S _ _ _).
      + intros b; simpl. apply ap, eisretr.
      + intros; apply path_ishprop.
    - intros x; revert x; simple refine (set_quotient_ind R _ _ _).
      + intros a; simpl. apply ap, eissect.
      + intros; apply path_ishprop.
  Defined.

  Definition set_quotient_functor_equiv
             (f : A -> B) (fresp : forall x y, R x y <-> S (f x) (f y))
             `{IsEquiv _ _ f}
  : set_quotient R <~> set_quotient S
    := BuildEquiv _ _
         (set_quotient_functor R S f (fun x y => fst (fresp x y))) _.

  Definition set_quotient_functor_equiv'
             (f : A <~> B) (fresp : forall x y, R x y <-> S (f x) (f y))
  : set_quotient R <~> set_quotient S
    := set_quotient_functor_equiv f fresp.

End Functoriality.

Section Kernel.

  (** ** Quotients of kernels of maps to sets give a surjection/mono factorization. *)

  Context {fs : Funext}.

  (** A function we want to factor. *)
  Context {A B : Type} `{IsHSet B} (f : A -> B).

  (** A mere relation equivalent to its kernel. *)
  Context (R : relation A) {sR : is_mere_relation _ R}.
  Context (is_ker : forall x y, f x = f y <~> R x y).

  Theorem set_quotient_kernel_factor
  : exists (C : Type) (e : A -> C) (m : C -> B),
      IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e).
  Proof.
    pose (C := set_quotient R).
    (* We put this explicitly in the context so that typeclass resolution will pick it up. *)
    assert (IsHSet C) by (unfold C; apply _).
    exists C.
    pose (e := class_of R).
    exists e.
    transparent assert (m : (C -> B)).
    { apply set_quotient_ind with f; try exact _.
      intros x y H. transitivity (f x).
      - apply transport_const.
      - exact ((is_ker x y) ^-1 H). }
    exists m.
    split.
    { split.
      { split.
        - assumption.
        - apply set_quotient_surjective. }
      intro u.
      apply hprop_allpath.
      assert (H : forall (x y : C) (p : m x = u) (p' : m y = u), x = y).
      { simple refine (set_quotient_ind R _ _ _).
        { intro a.
          simple refine (set_quotient_ind R _ _ _).
          { intros a' p p'; fold e in p, p'.
            apply related_classes_eq.
            refine (is_ker a a' _).
            change (m (e a) = m (e a')).
            exact (p @ p'^). }
          intros; apply path_ishprop. }
        intros; apply path_ishprop. }
      intros [x p] [y p'].
      apply path_sigma_hprop; simpl.
      exact (H x y p p'). }
    reflexivity.
  Defined.

End Kernel.


Require Import prosa.classic.util.all.

Require Import prosa.classic.model.suspension.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.arrival_sequence.
Require Import prosa.classic.model.schedule.uni.schedule.
Require Import prosa.classic.model.schedule.uni.susp.last_execution.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module SuspensionIntervals.

  Export Job UniprocessorSchedule Suspension LastExecution.

  (* In this section we define job suspension intervals in a schedule. *)
  Section DefiningSuspensionIntervals.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.

    (* Consider any job suspension times... *)
    Variable next_suspension: job_suspension Job.

    (* ...and any uniprocessor schedule. *)
    (*Context {arr_seq: arrival_sequence Job}.*)
    Variable sched: schedule Job.

    (* For simplicity, let's define some local names. *)
    Let job_scheduled_at := scheduled_at sched.
    Let job_completed_by := completed_by job_cost sched.

    (* Based on the time after the last execution of a job, we define next
       whether a job is suspended. *)
    Section JobSuspension.

      (* Let j be any job. *)
      Variable j: Job.

      Section DefiningSuspension.

        (* We are going to define whether job j is suspended at time t. *)
        Variable t: time.

        (* First, we define the beginning of the latest self suspension as the
           time following the last execution of job j in the interval [0, t).
           (Note that suspension_start can return time t itself.) *)
        Let suspension_start := time_after_last_execution job_arrival sched j t.

        (* Next, using the service received by j in the interval [0, suspension_start),...*)
        Let current_service := service sched j suspension_start.

        (* ... we recall the duration of the suspension expected for job j after having
           received that amount of service. *)
        Definition suspension_duration := next_suspension j current_service.

        (* Then, we say that job j is suspended at time t iff j has not completed
           by time t and t lies in the latest suspension interval.
           (Also note that the suspension interval can have duration 0, in which
            case suspended_at will be trivially false.)                         *)
        Definition suspended_at :=
          ~~ completed_by job_cost sched j t &&
          (suspension_start <= t < suspension_start + suspension_duration).

      End DefiningSuspension.

      (* Based on the notion of suspension, we also define the cumulative
         suspension time of job j in any interval [t1, t2)... *)
      Definition cumulative_suspension_during (t1 t2: time) :=
        \sum_(t1 <= t < t2) (suspended_at t).

      (* ...and the cumulative suspension time in any interval [0, t). *)
      Definition cumulative_suspension (t: time) := cumulative_suspension_during 0 t.

    End JobSuspension.

    (* Next, we define whether the schedule respects self-suspensions. *)
    Section SuspensionAwareSchedule.

      (* We say that the schedule respects self-suspensions iff suspended
         jobs are never scheduled. *)
      Definition respects_self_suspensions :=
        forall j t,
          job_scheduled_at j t -> ~ suspended_at j t.

    End SuspensionAwareSchedule.

    (* In this section, we prove several results related to job suspensions. *)
    Section Lemmas.

      (* First, we prove that at any time within any suspension interval,
         a job is always suspended. *)
      Section InsideSuspensionInterval.

        (* Assume that jobs do not execute before they arrive... *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute job_arrival sched.

        (* ...and nor after completion. *)
        Hypothesis H_completed_jobs_dont_execute:
          completed_jobs_dont_execute job_cost sched.

        (* Assume that the schedule respects self-suspensions. *)
        Hypothesis H_respects_self_suspensions: respects_self_suspensions.

        (* Let j be any job. *)
        Variable j: Job.

        (* Consider any time t after the arrival of j... *)
        Variable t: time.
        Hypothesis H_has_arrived: has_arrived job_arrival j t.

        (* ...and recall the latest suspension interval of job j relative to time t. *)
        Let suspension_start := time_after_last_execution job_arrival sched j t.
        Let duration := suspension_duration j t.

        (* First, we analyze the service received during a suspension interval. *)
        Section SameService.

          (* Let t_in be any time in the suspension interval relative to time t. *)
          Variable t_in: time.
          Hypothesis H_within_suspension_interval:
            suspension_start <= t_in <= suspension_start + duration.

          (* Then, we show that the service received before time t_in
             equals the service received before the beginning of the
             latest suspension interval (if exists). *)
          Lemma same_service_in_suspension_interval:
            service sched j t_in = service sched j suspension_start.
          Proof.
            rename H_within_suspension_interval into BETWEEN,
                   H_respects_self_suspensions into SUSP, t_in into i.
            generalize dependent i.
            suff SAME:
              forall delta,
                delta <= duration ->
                service sched j (suspension_start + delta) =
                service sched j suspension_start.
            {
              move => i /andP [GE LT].
              feed (SAME (i-suspension_start)); first by rewrite leq_subLR.
              by rewrite addnBA // addKn in SAME.
            }
            induction delta; first by rewrite addn0.
            intros LT.
            feed IHdelta; first by apply ltnW.
            rewrite addnS -[service _ _ suspension_start]addn0.
            rewrite /service /service_during big_nat_recr //=.
            f_equal; first by done.
            apply/eqP; rewrite eqb0; apply/negP; intro SCHED.
            move: (SCHED) => SCHED'.
            apply SUSP in SCHED; apply SCHED; clear SCHED.
            rewrite /suspended_at /suspension_duration.
            case: (boolP (completed_by _ _ _ _)) => [COMP | NOTCOMP];
              first by apply completed_implies_not_scheduled in COMP;
                first by rewrite SCHED' in COMP.
            rewrite andTb (same_service_implies_same_last_execution _ _ _ _
                                                                    suspension_start) //.
            rewrite /suspension_start last_execution_idempotent //.
            apply/andP; split; first by apply leq_addr.
            by rewrite ltn_add2l.
          Qed.

        End SameService.

        (* Next, we infer that the job is suspended at all times during
           the suspension interval. *)
        Section JobSuspendedAtAllTimes.

          (* Let t_in be any time before the completion of job j. *)
          Variable t_in: time.
          Hypothesis H_not_completed: ~~ job_completed_by j t_in.

          (* If t_in lies in the suspension interval relative to time t, ...*)
          Hypothesis H_within_suspension_interval:
            suspension_start <= t_in < suspension_start + duration.

          (* ...then job j is suspended at time t_in. More precisely, the suspension
             interval relative to time t_in is included in the suspension interval
             relative to time t. *)
          Lemma suspended_in_suspension_interval:
            suspended_at j t_in.
          Proof.
            rename H_within_suspension_interval into BETWEEN.
            move: BETWEEN => /andP [GE LT].
            have ARR: has_arrived job_arrival j t_in.
            {
              apply leq_trans with (n := suspension_start); last by done.
              rewrite -/(has_arrived job_arrival j suspension_start).
              by apply last_execution_after_arrival.
            }
            apply/andP; split; first by done.
            apply/andP; split;
              first by apply last_execution_bounded_by_identity.
            apply (leq_trans LT).
            have SAME: time_after_last_execution job_arrival sched j t =
                       time_after_last_execution job_arrival sched j t_in.
            {
              set b := _ _ t.
              rewrite [_ _ t_in](same_service_implies_same_last_execution _ _ _ _ b);
                first by rewrite last_execution_idempotent.
              apply same_service_in_suspension_interval.
              by apply/andP; split; last by apply ltnW.
            }
            rewrite /suspension_start SAME leq_add2l.
            by rewrite /duration /suspension_duration SAME.
          Qed.

        End JobSuspendedAtAllTimes.

      End InsideSuspensionInterval.

      (* Next, we prove lemmas about the state of a suspended job. *)
      Section StateOfSuspendedJob.

        (* Assume that jobs do not execute before they arrived. *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute job_arrival sched.

        (* Let j be any job. *)
        Variable j: Job.

        (* Assume that j is suspended at time t. *)
        Variable t: time.
        Hypothesis H_j_is_suspended: suspended_at j t.

        (* First, we show that j must have arrived by time t. *)
        Lemma suspended_implies_arrived: has_arrived job_arrival j t.
        Proof.
          rename H_j_is_suspended into SUSP.
          move: SUSP => /andP [_ SUSP].
          rewrite -[_ && _]negbK in SUSP; move: SUSP => /negP SUSP.
          rewrite /has_arrived leqNgt; apply/negP; intro LT.
          apply SUSP; clear SUSP.
          rewrite negb_and; apply/orP; left.
          rewrite -ltnNge.
          apply: (leq_trans LT); clear LT.
          rewrite /time_after_last_execution.
          case EX: [exists _, _]; last by apply leqnn.
          set t' := \max_(_ < _ | _)_.
          move: EX => /existsP [t0 EX].
          apply bigmax_pred in EX; rewrite -/t' /job_scheduled_at in EX.
          apply leq_trans with (n := t'); last by apply leq_addr.
          rewrite leqNgt; apply/negP; intro LT.
          have NOTSCHED: ~~ scheduled_at sched j t'.
          {
            rewrite -eqb0; apply/eqP.
            by eapply service_before_job_arrival_zero; first by eauto.
          }
          by rewrite EX in NOTSCHED.
        Qed.

        (* By the definition of suspension, it also follows that j cannot
           have completed by time t. *)
        Corollary suspended_implies_not_completed:
          ~~ completed_by job_cost sched j t.
        Proof.
          by move: H_j_is_suspended => /andP [NOTCOMP _].
        Qed.

      End StateOfSuspendedJob.

      (* Next, we establish a bound on the cumulative suspension time of any job. *)
      Section BoundOnCumulativeSuspension.

        (* Assume that jobs do not execute before they arrive... *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute job_arrival sched.

        (* ...and nor after completion. *)
        Hypothesis H_completed_jobs_dont_execute:
          completed_jobs_dont_execute job_cost sched.

        (* Assume that the schedule respects self-suspensions. *)
        Hypothesis H_respects_self_suspensions: respects_self_suspensions.

        (* Let j be any job. *)
        Variable j: Job.

        (* Recall the total suspension of job j as given by the dynamic suspension model. *)
        Let cumulative_suspension_of_j :=
          cumulative_suspension_during j.
        Let total_suspension_of_j :=
          total_suspension job_cost next_suspension j.

        (* We prove that the cumulative suspension time of job j in any
           interval is upper-bounded by the total suspension time. *)
        Lemma cumulative_suspension_le_total_suspension:
          forall t1 t2,
            cumulative_suspension_of_j t1 t2 <= total_suspension_of_j.
        Proof.
          unfold cumulative_suspension_of_j, cumulative_suspension_during,
                 total_suspension_of_j, total_suspension.
          intros t1 t2.
          apply leq_trans with (n := \sum_(0 <= s < job_cost j)
                            \sum_(t1 <= t < t2 | service sched j t == s) suspended_at j t).
          { rewrite (exchange_big_dep_nat (fun x => true)) //=.
            apply leq_sum; intros s _.
            destruct (boolP (suspended_at j s)) as [SUSP | NOTSUSP]; last by done.
            rewrite (big_rem (service sched j s)); first by rewrite eq_refl.
            rewrite mem_index_iota; apply/andP; split; first by done.
            rewrite ltn_neqAle; apply/andP; split;
              last by apply cumulative_service_le_job_cost.
            apply suspended_implies_not_completed in SUSP.
            rewrite neq_ltn; apply/orP; left.
              by rewrite ltnNge.
          }
          { apply leq_sum_nat; move => s /andP [_ LT] _.
            destruct (boolP [exists t:'I_t2, (t>=t1)&& (service sched j t==s)]) as [EX|ALL];
              last first.
            {
              rewrite negb_exists in ALL; move: ALL => /forallP ALL.
              rewrite big_nat_cond big1 //.
              move => i /andP [/andP [GEi LTi] SERV].
              by specialize (ALL (Ordinal LTi)); rewrite /= SERV GEi andbT in ALL.
            }
            move: EX => /existsP [t' /andP [GE' /eqP SERV]].
            unfold suspended_at, suspension_duration.
            set b := time_after_last_execution job_arrival sched j.
            set n := next_suspension j s.
            apply leq_trans with (n := \sum_(t1 <= t < t2 | b t' <= t < b t' + n) 1).
            {
              rewrite big_mkcond [\sum_(_ <= _ < _ | b t' <= _ < _) _]big_mkcond /=.
              apply leq_sum_nat; intros t LEt _.
              case: (boolP (completed_by _ _ _ _)) => [COMP | NOTCOMP];
                [by case (_ == _) | simpl].
              case EQ: (service _ _ _ == _); last by done.
              move: EQ => /eqP EQ. rewrite /n -EQ.
              case INT: (_ <= _ < _); last by done.
              apply eq_leq; symmetry; apply/eqP; rewrite eqb1.
              move: INT => /andP [GEt LTt].
              rewrite (same_service_in_suspension_interval _ _ _ _ t') //.
              {
                rewrite -/b [b t'](same_service_implies_same_last_execution _ _ _ _ t);
                  last by rewrite SERV EQ.
                by apply/andP; split.
              }
              {
                rewrite /suspension_duration -/b.
                rewrite [b t'](same_service_implies_same_last_execution _ _ _ _ t);
                  last by rewrite SERV EQ.
                by apply/andP; split; last by apply ltnW.
              }
            }
            apply leq_trans with (n := \sum_(b t' <= t < b t' + n) 1);
              last by simpl_sum_const; rewrite addKn.
            by apply leq_sum1_smaller_range; move => i [LE LE']; split.
          }
        Qed.

      End BoundOnCumulativeSuspension.

      (* Next, we show that when a job completes, it must have suspended
         as long as the total suspension time. *)
      Section SuspendsForTotalSuspension.

        (* Assume that jobs do not execute before they arrive... *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute job_arrival sched.

        (* ...and nor after completion. *)
        Hypothesis H_completed_jobs_dont_execute:
          completed_jobs_dont_execute job_cost sched.

        (* Assume that the schedule respects self-suspensions. *)
        Hypothesis H_respects_self_suspensions: respects_self_suspensions.

        (* Let j be any job. *)
        Variable j: Job.

        (* Assume that j has completed by time t. *)
        Variable t: time.
        Hypothesis H_j_has_completed: completed_by job_cost sched j t.

        (* Then, we prove that the cumulative suspension time must be
           exactly equal to the total suspension time of the job. *)
        Lemma cumulative_suspension_eq_total_suspension:
          cumulative_suspension j t = total_suspension job_cost next_suspension j.
        Proof.
          rename H_j_has_completed into COMP, H_jobs_must_arrive_to_execute into ARR.
          have EARLIER := exists_last_execution_with_smaller_service job_arrival
                                                           job_cost sched ARR j t COMP.
          apply/eqP; rewrite eqn_leq; apply/andP; split;
            first by apply cumulative_suspension_le_total_suspension.
          rewrite /total_suspension /cumulative_suspension /cumulative_suspension_during.
          move: COMP => /eqP COMP.
          apply leq_trans with (n := \sum_(0 <= s < job_cost j)
                           \sum_(0 <= t0 < t | service sched j t0 == s) suspended_at j t0);
            last first.
          {
            rewrite (exchange_big_dep_nat (fun x => true)) //=.
            apply leq_sum_nat; move => t0 /andP [_ LT] _.
            case (boolP [exists s: 'I_(job_cost j), service sched j t0 == s]) => [EX | ALL].
            {
              move: EX => /existsP [s /eqP EQs].
              rewrite big_mkcond /=.
              rewrite (bigD1_seq (nat_of_ord s)); [simpl | | by apply iota_uniq];
                last by rewrite mem_index_iota; apply/andP;split; last by apply ltn_ord.
              rewrite EQs eq_refl big1; first by rewrite addn0.
              by move => i /negbTE NEQ; rewrite eq_sym NEQ.
            }
            {
              rewrite big_nat_cond big1; first by done.
              move => i /andP [/andP [_ LTi] /eqP SERV].
              rewrite negb_exists in ALL; move: ALL => /forallP ALL.
              by specialize (ALL (Ordinal LTi)); rewrite /= SERV eq_refl in ALL.
            }
          }
          {
            apply leq_sum_nat; move => s /andP [_ LTs] _.
            rewrite /suspended_at /suspension_duration.
            set b := time_after_last_execution job_arrival sched j.
            set n := next_suspension j.

            move: (EARLIER s LTs) => [t' EQ'].
            apply leq_trans with (n := \sum_(0 <= t0 < t | (service sched j t0 == s) &&
                          (b t' <= t0 < b t' + n (service sched j (b t')))) 1); last first.
            { rewrite big_mkcond [\sum_(_ <= _ < _ | _ == s)_]big_mkcond.
              apply leq_sum_nat; move => i /andP [_ LTi] _.
              case EQi: (service sched j i == s); [rewrite andTb | by rewrite andFb].
              case LE: (_ <= _ <= _); last by done.
              rewrite lt0n eqb0 negbK.
              apply suspended_in_suspension_interval with (t := t'); try (by done).
              rewrite -ltnNge.
                by apply: (leq_ltn_trans _ LTs); apply eq_leq; apply/eqP.
            }
            { apply leq_trans with (n := \sum_(b t'<= t0< b t'+ n (service sched j (b t')) |
                                            (0 <= t0 < t) && (service sched j t0 == s)) 1).
              {
                apply leq_trans with (n := \sum_(b t' <= t0 < b t'
                                                         + n (service sched j (b t'))) 1);
                  first by simpl_sum_const; rewrite addKn -EQ'.
                rewrite [in X in _ <= X]big_mkcond /=.
                apply leq_sum_nat; move => i /andP [LEi GTi] _.
                apply eq_leq; symmetry; apply/eqP; rewrite eqb1.
                apply/andP; split.
                {
                  have SUSPi: suspended_at j i.
                  {
                    apply: (suspended_in_suspension_interval _ _ _ _ t');
                      try (by done); last by apply/andP; split.
                    rewrite -ltnNge.
                    rewrite (same_service_in_suspension_interval _ _ _ _ t') //;
                      first by rewrite EQ'.
                    by apply/andP; split; last by apply ltnW.
                  }
                  apply contraT; rewrite -leqNgt; intro LE.
                  apply suspended_implies_not_completed in SUSPi.
                  exfalso; move: SUSPi => /negP COMPi; apply COMPi.
                  apply completion_monotonic with (t0 := t); try (by done).
                  by apply/eqP.
                }
                {
                  rewrite -EQ'; apply/eqP.
                  apply same_service_in_suspension_interval; try (by done).
                  by apply/andP; split; last by apply ltnW.
                }
              }
              {
                apply leq_sum1_smaller_range.
                by move => i [LEb /andP [LE EQs]]; split;
                  last by apply/andP; split.
              }
            }
          }
        Qed.

      End SuspendsForTotalSuspension.

      (* In this section, we prove that a job executes just before it starts suspending.  *)
      Section ExecutionBeforeSuspension.

        (* Assume that jobs do not execute before they arrive... *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute job_arrival sched.

        (* ...and nor after completion. *)
        Hypothesis H_completed_jobs_dont_execute:
          completed_jobs_dont_execute job_cost sched.

        (* Assume that the schedule respects self-suspensions. *)
        Hypothesis H_respects_self_suspensions: respects_self_suspensions.

        (* Let j be any job... *)
        Variable j: Job.

        (* ...that has arrived by some time t. *)
        Variable t: time.
        Hypothesis H_arrived: has_arrived job_arrival j t.

        (* If job j is not suspended at time t, but starts to suspend at time t + 1, ... *)
        Hypothesis H_not_suspended_at_t: ~~ suspended_at j t.
        Hypothesis H_begins_suspension: suspended_at j t.+1.

        (* ...then j must be scheduled at time t. *)
        Lemma executes_before_suspension:
          scheduled_at sched j t.
        Proof.
          rename H_not_suspended_at_t into NOTSUSPs, H_begins_suspension into SUSPs'.
          move: SUSPs' => /andP [NOTCOMP' /andP [GE LT]].
          apply contraT; intro NOTSCHED.
          suff BUG: suspended_at j t by rewrite BUG in NOTSUSPs.
          apply suspended_in_suspension_interval with (t := t.+1); try done.
          {
            apply contraT; rewrite negbK; intro COMP.
            suff COMP': completed_by job_cost sched j t.+1 by rewrite COMP' in NOTCOMP'.
            by apply completion_monotonic with (t0 := t).
          }
          apply/andP; split; last by apply: (leq_ltn_trans _ LT).
          apply leq_trans with (n := time_after_last_execution job_arrival sched j t);
            last by apply last_execution_bounded_by_identity.
          apply eq_leq, same_service_implies_same_last_execution.
          rewrite /service /service_during big_nat_recr //= /service_at.
          by apply negbTE in NOTSCHED; rewrite NOTSCHED addn0.
        Qed.

      End ExecutionBeforeSuspension.

    End Lemmas.

  End DefiningSuspensionIntervals.

End SuspensionIntervals.


Require Import FP.Structures.Comonad.
Require Import FP.Data.Function.
Require Import FP.Data.Identity.
Require Import FP.Structures.Monad.
Require Import FP.Data.Cont.
Require Import FP.Structures.MonadCont.
Require Import FP.Structures.Monad.
Require Import FP.Data.Susp.
Require Import FP.Structures.Monoid.

Import FunctionNotation.
Import MonadNotation.
Import SuspNotation.

Class Iterable A T :=
  { coiter : forall {m} {M:Comonad m} {B}, (m B -> A -> B) -> m B -> T -> B }.

Section Iterable.
  Context {T A} {F:Iterable A T}.

  Definition iter {B} (f:B -> A -> B) (b:B) : T -> B :=
    coiter (fun (bM:identity B) (a:A) => f (run_identity bM) a) (Identity b).

  Definition miter {m} {M:Monad m} {B} (f:B -> A -> m B) (b:B) : T -> m B :=
    iter (fun (bM:m B) (a:A) => b <- bM ;; f b a) (ret b).

  Definition reviter {B} (f:B -> A -> B) : B -> T -> B :=
    run_cont '..'
      miter begin fun (b:B) (a:A) =>
        callcc $ fun (k:B -> cont B B) =>
          b <- k b ;;
          ret $ f b a
      end.

  Definition lazyiter {B}
      (f:forall {C}, (C -> B) -> C -> A -> B) (b:B) : T -> B :=
    coiter (fun (bM:susp B) (a:A) => f force bM a) (delay | b).
End Iterable.

Class TreeIterable A T :=
  { co_treeiter : forall {m} {M:Comonad m} {B} {BM:Monoid B},
                    (m B -> A -> B) -> m B -> T -> B
  }.

Section TreeIterable.
  Context {A T} {I:TreeIterable A T}.

  Definition treeiter {B} {BM:Monoid B} (f:B -> A -> B) (b:B) : T -> B :=
    co_treeiter (fun (bM:identity B) (a:A) => f (un_identity bM) a) (Identity b).
End TreeIterable.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal30.

Set Printing Depth 1000.
Definition lfind_eval  l1:=
append l1 Nil.

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) Nil))))).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).


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

(* Cuihtlauac Alvarado - octobre 2000 *)

(** Properties of a boolean equality   *)

Require Export Bool.

Section Bool_eq_dec.

  Variable A : Set.

  Variable beq : A -> A -> bool.

  Variable beq_refl : forall x:A, true = beq x x.

  Variable beq_eq : forall x y:A, true = beq x y -> x = y.

  Definition beq_eq_true : forall x y:A, x = y -> true = beq x y.
  Proof.
    intros x y H.
    case H.
    apply beq_refl.
  Defined.

  Definition beq_eq_not_false : forall x y:A, x = y -> false <> beq x y.
  Proof.
    intros x y e.
    rewrite <- beq_eq_true; trivial; discriminate.
  Defined.

  Definition beq_false_not_eq : forall x y:A, false = beq x y -> x <> y.
  Proof.
    exact
     (fun (x y:A) (H:false = beq x y) (e:x = y) => beq_eq_not_false x y e H).
  Defined.

  Definition exists_beq_eq : forall x y:A, {b : bool | b = beq x y}.
  Proof.
    intros.
    exists (beq x y).
    constructor.
  Defined.

  Definition not_eq_false_beq : forall x y:A, x <> y -> false = beq x y.
  Proof.
    intros x y H.
    symmetry  in |- *.
    apply not_true_is_false.
    intro.
    apply H.
    apply beq_eq.
    symmetry  in |- *.
    assumption.
  Defined.

  Definition eq_dec : forall x y:A, {x = y} + {x <> y}.
  Proof.
    intros x y; case (exists_beq_eq x y).
    intros b; case b; intro H.
      left; apply beq_eq; assumption.
      right; apply beq_false_not_eq; assumption.
  Defined.

End Bool_eq_dec.


Require Import Rel.
Require Import FunctionalExtensionality.

Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Class ValNull (val : Type) := {
  null   :  val
}.

Section Defs.
  Context {A val : Type} {HA : RelDec (@eq A)} {HR : RelDec_Correct HA}.
  Context {VNB : ValNull val}.

  Definition stack := A -> val.

  Definition stack_empty : stack := fun x => null.

  Definition stack_add x v s : stack :=
    fun x' => if x' ?[ eq ] x then v else s x'.

  Lemma stack_lookup_add (s : stack) (x : A) (v : val) :
      ((stack_add x v s) : stack) x = v.
  Proof.
    unfold stack_add; consider (x ?[ eq ] x); intros H; [reflexivity|congruence].
  Qed.

  Lemma stack_lookup_add2 (x y : A) (v : val) (s : stack) (Hneq: x <> y) :
    (stack_add x v s) y = s y.
  Proof.
    unfold stack_add. consider (y ?[ eq ] x); intros; [congruence|reflexivity].
  Qed.

  Lemma stack_add_same (s: stack) x:
    stack_add x (s x) s = s.
  Proof.
    apply functional_extensionality.
    intro x'. unfold stack_add.
    consider (x' ?[ eq ] x); intros; subst; reflexivity.
  Qed.

  Lemma stack_add_overwrite (s: stack) x v v':
    stack_add x v (stack_add x v' s) = stack_add x v s.
  Proof.
    apply functional_extensionality.
    intro x'. unfold stack_add.
    consider (x' ?[ eq ] x); intros; reflexivity.
  Qed.

  Lemma stack_add_val_eq (s : stack) (x : A) v1 v2 (Hs : stack_add x v1 s = stack_add x v2 s) :
  	v1 = v2.
  Proof.
    assert (stack_add x v1 s x = stack_add x v2 s x).
    rewrite Hs. reflexivity.
    do 2 rewrite stack_lookup_add in H. apply H.
  Qed.

End Defs.

Implicit Arguments stack [].
Implicit Arguments stack_empty [[VNB]].

Hint Rewrite @stack_lookup_add
             @stack_add_same
             @stack_add_overwrite : stack.

Hint Rewrite @stack_lookup_add2 using solve [auto] : stack.