From Hammer Require Import Hammer.

Set Implicit Arguments.

From QuicksortComplexity Require Import util.
Require Import List.
Require Import Le.
Require Import Lt.
Require Import Plus.
From QuicksortComplexity Require Import monads.
Require Import Coq.Program.Wf.
From QuicksortComplexity Require Import nat_seqs.
From QuicksortComplexity Require Import list_utils.
Require Import Bool.
Require Import Recdef.
From QuicksortComplexity Require Import monoid_monad_trans.
Require Import Compare_dec.
Require Coq.Program.Wf.
Require Import Wf_nat.
From QuicksortComplexity Require Import arith_lems.
From QuicksortComplexity Require ne_list.
Require Import Omega.
From QuicksortComplexity Require fix_measure_utils.

Set Shrink Obligations.

Definition numbers: list nat := 3 :: 1 :: 0 :: 4 :: 5 :: 2 :: nil.

Hint Resolve length_filter_le.

Module nonmonadic.
Section nonmonadic.

Variables (T: Set) (le: T -> T -> bool).

Definition gt (x y: T): bool := negb (le x y).

Program Fixpoint qs (l: list T) {measure (length l) lt}: list T :=
match l with
| nil => nil
| pivot :: t => qs (filter (gt pivot) t) ++ (pivot :: nil) ++ qs (filter (le pivot) t)
end.

Next Obligation. simpl; auto with arith. Qed.
Next Obligation. simpl; auto with arith. Qed.

Definition body (l : list T) (qs0 : {l' : list T | length l' < length l} -> list T) :=
match l as l0 return (l0 = l -> list T) with
| nil => fun _ => nil
| pivot :: t0 => fun Heq_l =>
qs0 (exist (fun l' => length l' < length l) (filter (gt pivot) t0) (qs_obligation_1 (fun l H => qs0 (exist _ l H)) Heq_l)) ++
(pivot :: nil) ++
qs0 (exist (fun l' => length l' < length l) (filter (le pivot) t0) (qs_obligation_2 (fun l H => qs0 (exist _ l H)) Heq_l))
end refl_equal.

Lemma body_eq:
forall (x0 : list T) (g h0 : {y : list T | length y < length x0} -> list T),
(forall (x : list T) (p p' : length x < length x0),
g (exist (fun y : list T => length y < length x0) x p) =
h0 (exist (fun y : list T => length y < length x0) x p')) ->
body x0 g = body x0 h0.
Proof with auto. hammer_hook "qs_definitions" "qs_definitions.nonmonadic.body_eq".
intros.
destruct x0...
simpl.
f_equal...
f_equal...
Qed.

Lemma unfold: forall l, qs l = Fix_sub (list T) (MR lt (fun l0 : list T => length l0)) qs_obligation_3 (fun _ : list T => list T) body l.
Proof. hammer_hook "qs_definitions" "qs_definitions.nonmonadic.unfold". reflexivity. Qed.

Lemma qs_unfold (t: list T) (h: T): qs (h :: t) = qs (filter (gt h) t) ++ (h :: nil) ++ qs (filter (le h) t).
Proof with auto. hammer_hook "qs_definitions" "qs_definitions.nonmonadic.qs_unfold".
intros.
unfold qs.
fold body.
rewrite fix_measure_utils.unfold.
unfold body at 1.
simpl proj1_sig.
f_equal.
apply body_eq.
Qed.

Section rect.

Variable P: list T -> list T -> Prop.

Hypothesis Pnil: P nil nil.

Hypothesis Pcons: forall h t,
P (filter (gt h) t) (qs (filter (gt h) t)) ->
P (filter (le h) t) (qs (filter (le h) t)) -> P (h :: t) (qs (filter (gt h) t) ++ h :: nil ++ qs (filter (le h) t)).

Lemma qs_rect: forall l, P l (qs l).
Proof with auto with arith. hammer_hook "qs_definitions" "qs_definitions.nonmonadic.qs_rect".
unfold qs.
fold body.
apply fix_measure_utils.rect.
apply body_eq.
intros.
destruct x...
simpl.
apply Pcons; apply H; unfold MR; simpl...
Qed.

End rect.

End nonmonadic.
End nonmonadic.

Module mon_det.
Section mon_det.

Variables (M: Monad) (T: Set).

Definition filter (c: T -> M bool) (l: list T): M { l': list T | length l' <= length l }.

Proof with auto with arith. hammer_hook "qs_definitions" "qs_definitions.mon_det.filter".
induction l.
refine (ret (exist _ nil _))...
refine (
b <- c a ;
t <- IHl ;
ret (if b then exist _ (a :: proj1_sig t) _ else exist _ (proj1_sig t) _)
); simpl; destruct t...
Defined.

Lemma hm (e: extMonad M) c l: forall U (f: list T -> M U) g,
ext_eq g (f ∘ @proj1_sig _ _) -> filter c l >>= g = filterM c l >>= f.
Proof with auto. hammer_hook "qs_definitions" "qs_definitions.mon_det.hm".
induction l.
simpl. intros.
repeat rewrite mon_lunit.
rewrite H.
unfold compose...
intros.
simpl.
repeat rewrite mon_assoc.
apply e. intro.
repeat rewrite mon_assoc.
apply IHl.
intro. unfold compose.
repeat rewrite mon_lunit.
rewrite H.
unfold compose.
destruct x...
Qed.

Fixpoint simple_filter (c: T -> M bool) (l: list T): M (list T) :=
match l with
| nil => ret nil
| h :: t =>
t' <- simple_filter c t ;
b <- c h ;
ret (if b then h :: t' else t')
end.

Definition fold_filter (c: T -> M bool): list T -> M (list T) :=
foldrM (fun x l => b <- c x ; ret (if b then x :: l else l)) nil.

Lemma simple_fold_filter: forall c l, simple_filter c l = fold_filter c l.
Proof with auto. hammer_hook "qs_definitions" "qs_definitions.mon_det.simple_fold_filter".
unfold fold_filter.
induction l...
simpl.
rewrite IHl...
Qed.

Variable le: T -> T -> M bool.

Definition gt (x y: T): M bool := liftM negb (le x y).

Program Fixpoint qs (l: list T) {measure (length l) lt}: M (list T) :=
match l with
| nil => ret nil
| pivot :: t =>
lower <- filter (gt pivot) t >>= (fun l => qs l);
upper <- filter (le pivot) t >>= (fun l => qs l);
ret (lower ++ pivot :: upper)
end.

Next Obligation. simpl. auto with arith. Qed.
Next Obligation. simpl. auto with arith. Qed.

Definition body (l: list T) (qs0: {l': list T | length l' < length l} -> M (list T)) :=
match l as l1 return (l1 = l -> M (list T)) with
| nil => fun _ => ret (m:=M) nil
| pivot :: t => fun Heq_l =>
lower <-
x <- filter (gt pivot) t;
qs0 (exist _ (proj1_sig x) (qs_obligation_1 (fun l H => qs0 (exist _ l H)) Heq_l x));
upper <-
x <- filter (le pivot) t;
qs0 (exist _ (proj1_sig x) (qs_obligation_2 (fun l H => qs0 (exist _ l H)) Heq_l x));
ret (m:=M) (lower ++ pivot :: upper)
end refl_equal.

Lemma unfold: forall l, qs l =
Fix_sub (list T) (MR lt (fun l0 : list T => length l0)) qs_obligation_3 (fun _ : list T => M (list T)) body l.
Proof. hammer_hook "qs_definitions" "qs_definitions.mon_det.unfold". reflexivity. Qed.

Variable e: extMonad M.

Lemma body_eq:
forall (x0 : list T)
(g h : {y : list T | length y < length x0} -> M (list T)),
(forall (x1 : list T) (p p' : length x1 < length x0),
g (exist (fun y : list T => length y < length x0) x1 p) =
h (exist (fun y : list T => length y < length x0) x1 p')) ->
body x0 g = body x0 h.
Proof with auto. hammer_hook "qs_definitions" "qs_definitions.mon_det.body_eq".
intros. destruct x0...
simpl.
rewrite mon_assoc. rewrite mon_assoc.
apply e. intro.
simpl @length in H.
erewrite H.
apply e. intro.
do 2 rewrite mon_assoc.
apply e. intro.
erewrite H...
Qed.

Lemma unfold' pivot t: qs (pivot :: t) =
lower <- filterM (gt pivot) t >>= qs;
upper <- filterM (le pivot) t >>= qs;
ret (lower ++ pivot :: upper).
Proof with auto. hammer_hook "qs_definitions" "qs_definitions.mon_det.unfold'".
intros.
unfold qs at 1.
simpl.
fold body.
rewrite fix_measure_utils.unfold.
simpl.
repeat rewrite mon_assoc.
apply hm...
intro.
unfold compose.
unfold qs.
fold body.
apply e.
intro.
repeat rewrite mon_assoc.
apply hm...
intro...
apply body_eq.
Qed.

End mon_det.
End mon_det.

Arguments mon_det.qs [M T].

Lemma mon_det_nonmonadic_eq (X: Set) (Xle: X -> X -> Prop) (leb: X -> X -> IdMonad.M bool):
forall l, mon_det.qs leb l = nonmonadic.qs leb l.
Proof with auto. hammer_hook "qs_definitions" "qs_definitions.mon_det_nonmonadic_eq".
intros.
pattern l, (nonmonadic.qs leb l).
apply nonmonadic.qs_rect...
simpl.
intros.
rewrite mon_det.unfold'.
simpl. unfold IdMonad.bind, IdMonad.ret.
do 2 rewrite <- filterM_id.
rewrite H0.
unfold mon_det.gt.
unfold nonmonadic.gt in H.
simpl. unfold IdMonad.bind, IdMonad.ret.
rewrite H...
intro...
Qed.

Definition profiled_leb (x y: nat): SimplyProfiled bool := (1, leb x y).
Eval vm_compute in mon_det.qs profiled_leb numbers.

Eval vm_compute in mon_det.qs (M:=IdMonad.M) leb numbers.

Module mon_det_partition.
Section mon_det_partition.

Variables (T: Set) (M: Monad) (cmp: T -> T -> M comparison).

Fixpoint partition (pivot: T) (l: list T) :
M { p: Partitioning T | Permutation.Permutation (p Eq ++ p Lt ++ p Gt) l } :=

match l return M { p: Partitioning T | Permutation.Permutation (p Eq ++ p Lt ++ p Gt) l } with
| nil => ret (@emp T)
| h :: t =>
b <- cmp h pivot;
tt <- partition pivot t ;
ret (addToPartitioning b h tt)
end.

Program Fixpoint qs (l: list T) {measure (length l) lt}: M (list T) :=
match l with
| nil => ret nil
| h :: t =>
part <- partition h t;
low <- qs (part Lt);
upp <- qs (part Gt);
ret (low ++ h :: part Eq ++ upp)
end.

Next Obligation. simpl. rewrite <- H. repeat rewrite app_length. omega. Qed.
Next Obligation. simpl. rewrite <- H. repeat rewrite app_length. omega. Qed.

End mon_det_partition.
End mon_det_partition.

Module mon_nondet.
Section mon_nondet.

Variables (T: Set) (M: Monad) (cmp: T -> T -> M comparison).

Fixpoint partition (pivot: T) (l: list T) :
M { p: Partitioning T | Permutation.Permutation (p Eq ++ p Lt ++ p Gt) l } :=

match l return M { p: Partitioning T | Permutation.Permutation (p Eq ++ p Lt ++ p Gt) l } with
| nil => ret (@emp T)
| h :: t =>
b <- cmp h pivot;
tt <- partition pivot t ;
ret (addToPartitioning b h tt)
end.

Variable pick: forall (A: Set), ne_list.L A -> M A.

Program Fixpoint qs (l: list T) {measure (length l) lt}: M (list T) :=
match l with
| nil => ret nil
| h :: t =>
i <- pick (ne_list.from_vec (vec.nats 0 (length (h :: t))));
part <- partition (vec.nth (vec.from_list (h :: t)) i) (vec.to_list (vec.remove (vec.from_list (h :: t)) i));
low <- qs (part Lt);
upp <- qs (part Gt);
ret (low ++ vec.nth (vec.from_list (h :: t)) i :: part Eq ++ upp)
end.

Next Obligation.
simpl.
replace (length t) with (length (vec.to_list (vec.remove (vec.from_list (h :: t)) i))).
simpl.
rewrite <- H.
repeat rewrite app_length.
omega.
rewrite vec.length.
reflexivity.
Qed.

Next Obligation.
simpl.
replace (length t) with (length (vec.to_list (vec.remove (vec.from_list (h :: t)) i))).
simpl.
rewrite <- H.
repeat rewrite app_length.
omega.
rewrite vec.length.
reflexivity.
Qed.

End mon_nondet.
End mon_nondet.

From QuicksortComplexity Require Import sort_order.

Fixpoint simplerPartition (e: E) (d: e) (l: list e) {struct l}: { p: Partitioning e | Permutation.Permutation (p Eq ++ p Lt ++ p Gt) l } :=
match l return { p: Partitioning e | Permutation.Permutation (p Eq ++ p Lt ++ p Gt) l } with
| nil => emp e
| h :: t => addToPartitioning (Ecmp e h d) _ (simplerPartition e d t)
end.

Arguments mon_nondet.qs [T M].

Module nonmonadic_using_Function.

Function qs (l: list nat) {measure length l}: list nat :=
match l with
| nil => nil
| pivot :: t => qs (filter (geb pivot) t) ++ (pivot :: nil) ++ qs (filter (ltb pivot) t)
end.
Proof with simpl; auto with arith. hammer_hook "qs_definitions" "qs_definitions.profiled_leb". intros... intros... Defined.

End nonmonadic_using_Function.


(*
Copyright © 2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import CoRN.model.totalorder.QposMinMax.
Require Export CoRN.metric2.Hausdorff.
Require Import CoRN.logic.Classic.
Require Export CoRN.stdlib_omissions.List.
Require Export CoRN.metric2.Classification.
Require Import CoRN.metric2.Complete.
Require Import CoRN.metric2.Prelength.

Set Implicit Arguments.

Local Open Scope Q_scope.

Section Finite.

Variable X:MetricSpace.

(** [FinSubset_ball] says that the distance between x and l is <= e.
    It is stated as a negation, to remind that a <= b means
    ~(b < a) in the real numbers.
    As shown by lemma AlmostInExists, the double negation can
    be removed, at the cost of slightly increasing e. *)
Definition FinSubset_ball (e:Q) (x:X) (l:list X) : Prop :=
  ~~ exists y:X, In y l /\ ball e x y.

Definition InFinEnumC (x:X) (l:list X) : Prop
  := FinSubset_ball 0 x l.

Lemma InFinEnumC_weaken : forall x l, In x l -> InFinEnumC x l.
Proof.
  intros. intro abs.
  contradict abs.
  exists x. split. exact H. apply ball_refl.
  apply Qle_refl.
Qed.

Lemma FinSubset_ball_nil : forall e x, ~FinSubset_ball e x nil.
Proof.
 intros e x H.
 unfold FinSubset_ball in H.
 contradict H; intros [y [H _]].
 contradiction.
Qed.

Lemma FinSubset_ball_cons : forall x e a l,
    FinSubset_ball e x l -> FinSubset_ball e x (a :: l).
Proof.
  intros. intro abs. unfold FinSubset_ball in H.
  contradict H; intros [z [H0 H1]].
  contradict abs. exists z. split.
  right. exact H0. exact H1.
Qed.

Lemma FinSubset_ball_orC : forall e x a l,
    FinSubset_ball e x (a :: l) -> orC (ball e x a) (FinSubset_ball e x l).
Proof.
  intros. intro abs.
  unfold FinSubset_ball in H.
  contradict H; intros [y [H H0]].
  destruct H.
  - subst y. destruct abs. contradiction.
  - destruct abs. contradict H2.
    intro abs; contradict abs.
    exists y. split; assumption.
Qed.

Lemma FinSubset_ball_wd : forall x y d e l,
    d == e -> msp_eq x y -> (FinSubset_ball d x l <-> FinSubset_ball e y l).
Proof.
  split.
  - intros H1 abs.
    unfold FinSubset_ball in H1.
    contradict H1; intros [z [H1 H2]].
    contradict abs. exists z. split.
    exact H1. rewrite <- H, <- H0. exact H2.
  - intros H1 abs.
    unfold FinSubset_ball in H1.
    contradict H1; intros [z [H1 H2]].
    contradict abs. exists z. split.
    exact H1. rewrite H, H0. exact H2.
Qed.

Lemma FinSubset_ball_weak_le : forall (e1 e2:Q) x l,
    e1 <= e2 -> FinSubset_ball e1 x l
    -> FinSubset_ball e2 x l.
Proof.
  intros. intro abs.
  unfold FinSubset_ball in H0.
  contradict H0; intros [y [iny H0]].
  contradict abs. exists y. split.
  exact iny.
  apply (ball_weak_le X x y H), H0.
Qed.

Lemma FinSubset_ball_nonneg : forall (e:Q) x l,
    FinSubset_ball e x l -> 0 <= e.
Proof.
  intros. apply Qnot_lt_le. intro abs.
  unfold FinSubset_ball in H.
  contradict H; intros [y [_ H]].
  apply (Qlt_not_le _ _ abs).
  apply (msp_nonneg (msp X) e x y H).
Qed.

Lemma FinSubset_ball_closed : forall (e:Q) x l,
    (forall d:Q, 0 < d -> FinSubset_ball (e+d) x l) -> FinSubset_ball e x l.
Proof.
 induction l.
 - intros H. exfalso. exact (FinSubset_ball_nil (H (1#1) eq_refl)).
 - intros H abs.
   assert (~ball e x a) as A.
   { intro H0. contradict abs. exists a.
     split. left. reflexivity. exact H0. }
   assert (~ (exists y : X, In y l /\ ball e x y)) as B.
   { intros [y H1]. contradict abs. exists y.
     split. right. apply H1. apply H1. }
   clear abs.
   revert B.
   apply IHl. clear IHl.
   intros d dpos.
   (* Improve A *)
   assert (existsC Qpos (fun d => ~ball (e+proj1_sig d) x a)) as Aprime.
   { intros Y.
     apply A.
     apply ball_closed.
     intros d0 d0pos.
     apply (msp_stable (msp X)).
     apply (Y (exist _ _ d0pos)). }
   clear A.
   destruct Aprime as [G | d0 Hd0] using existsC_ind.
   intro abs; contradict G; intro G; contradiction.
 intros Z.
 destruct (Qlt_le_dec (proj1_sig d0) d).
 + revert Z.
  apply (@FinSubset_ball_weak_le (e + proj1_sig d0)).
   apply Qlt_le_weak.
   rewrite -> Qlt_minus_iff in *.
   setoid_replace (e + d + - (e + proj1_sig d0))
     with (d + - proj1_sig d0) by (simpl; ring).
   assumption.
  intros Y.
  destruct d0 as [d0 d0pos].
  apply (H d0 d0pos).
  intros [y abs].
  contradict Y. exists y.
  simpl.
  split. 2: apply abs.
  destruct abs. destruct H0.
  2: exact H0. subst y. contradiction.
 + specialize (H d dpos).
   unfold FinSubset_ball in H.
   contradict H; intros [y [iny H]].
   destruct iny. subst y.
   contradict Hd0.
   apply (@ball_weak_le X (e + d)).
   rewrite -> Qle_minus_iff in *.
   setoid_replace (e + proj1_sig d0 + - (e + d))
     with (proj1_sig d0 + - d) by (simpl; ring).
   assumption. exact H.
   contradict Z. exists y.
   split. exact H0. exact H.
Qed.

(** Left and right triangle laws for balls and [FinSubset_ball]. *)
Lemma FinSubset_ball_triangle_l : forall e1 e2 x1 x2 l,
    (ball e1 x1 x2) -> FinSubset_ball e2 x2 l -> FinSubset_ball (e1 + e2) x1 l.
Proof.
  intros. intro abs.
  unfold FinSubset_ball in H0.
  contradict H0; intros [y H0].
  contradict abs. exists y. split.
  apply H0.
  eapply ball_triangle.
   apply H.
  apply H0.
Qed.

Lemma FinSubset_ball_app_l : forall e x l1 l2,
    FinSubset_ball e x l1 -> FinSubset_ball e x (l1 ++ l2).
Proof.
 intros e x l1 l2 H abs.
 unfold FinSubset_ball in H.
 contradict H; intros [y H].
 contradict abs. exists y. split.
 apply in_app_iff. left.
 apply H. apply H.
Qed.

Lemma FinSubset_ball_app_r : forall e x l1 l2,
    FinSubset_ball e x l2 -> FinSubset_ball e x (l1 ++ l2).
Proof.
 intros e x l1 l2 H abs.
 unfold FinSubset_ball in H.
 contradict H; intros [y H].
 contradict abs. exists y. split.
 apply in_app_iff. right.
 apply H. apply H.
Qed.
(* begin hide *)
Hint Resolve FinSubset_ball_app_l FinSubset_ball_app_r.
(* end hide *)
Lemma FinSubset_ball_app_orC : forall e x l1 l2,
    FinSubset_ball e x (l1 ++ l2)
    -> orC (FinSubset_ball e x l1) (FinSubset_ball e x l2).
Proof.
 intros e x l1 l2 H [H0 H1].
 unfold FinSubset_ball in H.
 contradict H; intros [y [H H2]].
 apply in_app_iff in H. destruct H.
 contradict H0. intro abs.
 contradict abs. exists y.
 split; assumption.
 contradict H1. intro abs.
 contradict abs. exists y.
 split; assumption.
Qed.

(**
** Equivalence
Two finite enumerations, represented as lists, are equivalent
if they (classically) have the same elements.
*)
Definition FinEnum_eq (a b:list X) : Prop :=
 forall x, InFinEnumC x a <-> InFinEnumC x b.

(**
** Metric Space
Finite enumerations form a metric space under the Hausdorff metric for
any stable metric space X.
*)
Definition FinEnum_ball (e:Q) (x y:list X) :=
 hausdorffBall X e (fun a => InFinEnumC a x) (fun a => InFinEnumC a y).

Lemma FinEnum_ball_e_wd : forall (e1 e2:Q) (a b : list X), (e1 == e2) ->
 (FinEnum_ball e1 a b <-> FinEnum_ball e2 a b).
Proof.
 intros e1 e2 a b He.
 apply hausdorffBall_wd; auto with *.
Qed.

Lemma hemiMetric_closed : forall e A b,
 (forall d, 0 < d -> hemiMetric X (e+d) A (fun a => InFinEnumC a b)) ->
  hemiMetric X e A (fun a => InFinEnumC a b).
Proof.
 intros e A b H x Hx.
 pose (fun n y => ball (e + (1#(P_of_succ_nat n))%Q) x y) as P.
 assert (forall n, existsC X (fun x => ~~In x b /\ P n x)) as HP.
 { intros n.
   unfold P.
   destruct (H (1#(P_of_succ_nat n))%Q eq_refl x Hx)
     as [HG | y [Hy0 Hy1]] using existsC_ind.
   apply existsC_stable; auto.
   clear - Hy0 Hy1.
   intro abs.
   unfold InFinEnumC, FinSubset_ball in Hy0.
   contradict Hy0; intros [y0 [Hy0 yeq]].
   specialize (abs y0).
   contradict abs. split.
   intro abs. contradiction.
   rewrite <- yeq. exact Hy1. }
 destruct (infinitePidgeonHolePrinicple _ _ P HP) as [HG | y [Hy0 Hy1]] using existsC_ind.
  apply existsC_stable; auto.
 apply existsWeaken.
 exists y.
 split; auto using InFinEnumC_weaken.
 apply ball_closed.
 intros [n d] dpos.
 destruct n. inversion dpos. 2: inversion dpos.
 destruct (Hy1 (nat_of_P d)) as [HG | m [Hmd Hm]] using existsC_ind.
  apply (msp_stable (msp X) (e + (Zpos p#d))%Q); assumption.
 eapply ball_weak_le;[|apply Hm].
 simpl.
 rewrite -> Qle_minus_iff.
 ring_simplify.
 rewrite <- Qle_minus_iff.
 apply Zmult_le_compat.
 apply Pos.le_1_l.
 simpl. apply Pos2Nat.inj_le.
 apply (le_trans _ _ _ Hmd).
 rewrite nat_of_P_o_P_of_succ_nat_eq_succ.
 apply le_S, le_refl.
 discriminate. discriminate.
Qed.

Lemma FinEnum_ball_closed : forall e a b,
 (forall d, 0 < d -> FinEnum_ball (e+d) a b) ->
 FinEnum_ball e a b.
Proof.
 unfold FinEnum_ball, hausdorffBall.
 intros e a b Hab.
 split.
 - apply Qnot_lt_le. intro abs.
   specialize (Hab (-e * (1#2))). destruct Hab.
   rewrite <- (Qmult_0_l (1#2)). apply Qmult_lt_r.
   reflexivity. apply (Qplus_lt_l _ _ e). ring_simplify.
   exact abs.
   ring_simplify in H.
   rewrite <- (Qmult_0_r (1#2)) in H.
   apply Qmult_le_l in H. exact (Qlt_not_le _ _ abs H). reflexivity.
 - split; apply hemiMetric_closed; firstorder.
Qed.

Lemma FinEnum_ball_eq :
 forall a b : list X, (forall e : Qpos, FinEnum_ball (proj1_sig e) a b) -> FinEnum_eq a b.
Proof.
 unfold FinEnum_ball, FinEnum_eq.
 cut (forall a b : list X, (forall e : Qpos, hemiMetric X (proj1_sig e) (fun a0 : X => InFinEnumC a0 a)
   (fun a0 : X => InFinEnumC a0 b)) -> forall x : X, InFinEnumC x a -> InFinEnumC x b).
 { unfold hausdorffBall.
  split; apply H; firstorder. }
 induction a.
 intros. exfalso.
 unfold InFinEnumC, FinSubset_ball in H0.
 contradict H0; intros [y [H0 _]].
 contradiction.
 intros b H x Hx.

 intro abs. unfold InFinEnumC, FinSubset_ball in Hx.
 contradict Hx; intros [y [iny Hx]].
 destruct iny.
 - subst y.
  assert (H':forall n :nat ,
             existsC X (fun y : X => InFinEnumC y b
                                  /\ ball (m:=X) (1#(P_of_succ_nat n)) x y)).
  { intros e.
    apply (H (exist (Qlt 0) (1#(P_of_succ_nat e)) eq_refl)).
    intro H0. contradict H0.
    exists a. split. left. reflexivity. exact Hx. }
  assert (H'':forall n :nat ,
             existsC X (fun y : X => ~~In y b
                                  /\ ball (m:=X) (1#(P_of_succ_nat n)) x y)).
  { intros n.
   destruct (H' n) as [HG | z [Hz0 Hz1]] using existsC_ind.
    auto using existsC_stable.
   clear - Hz1 Hz0.
   intro abs. unfold InFinEnumC, FinSubset_ball in Hz0.
   contradict Hz0; intros [y [iny Hz0]].
   specialize (abs y).
   contradict abs. split.
   intro abs. contradiction.
   rewrite <- Hz0. exact Hz1. }
   destruct (infinitePidgeonHolePrinicple _ _ _ H'')
     as [HG | y [Hy0 Hy1]] using existsC_ind.
  contradict HG. intro HG. contradiction.
  revert abs. change (FinSubset_ball 0 x b).
  rewrite -> (FinSubset_ball_wd x y).
  2: reflexivity.
  apply InFinEnumC_weaken, Hy0.
  apply ball_eq.
  intros [n d] dpos.
  destruct n. inversion dpos. 2: inversion dpos.
  replace d with (Pos.of_succ_nat (Init.Nat.pred (Pos.to_nat d))).
  destruct (Hy1 (pred (nat_of_P d))) as [HG | z [Hz0 Hz1]] using existsC_ind.
  apply (msp_stable (msp X) (Zpos p # Pos.of_succ_nat (Init.Nat.pred (Pos.to_nat d)))). auto.
  apply ball_weak_le with (1 # P_of_succ_nat z); auto.
  simpl.
  apply Zmult_le_compat; [..|auto with *].
  apply Pos.le_1_l. simpl.
  assert (forall i j:nat, le i j -> Pos.of_succ_nat i <= Pos.of_succ_nat j)%positive.
  { intros.
    rewrite Pos.of_nat_succ, Pos.of_nat_succ.
    apply Pos2Nat.inj_le.
    rewrite Nat2Pos.id, Nat2Pos.id.
    apply le_n_S, H0. discriminate. discriminate. }
  apply H0, Hz0.
  discriminate.
  rewrite Pos.of_nat_succ.
  rewrite <- (Pos2Nat.id d) at 2.
  apply f_equal.
  symmetry. apply (S_pred _ O).
  apply Pos2Nat.is_pos.
 - revert abs. apply IHa.
   intros e y0 Hy.
   apply H. intro abs.
   unfold InFinEnumC, FinSubset_ball in Hy.
   contradict Hy; intros [y1 Hy].
   contradict abs.
   exists y1. split.
   right. apply Hy.
   apply Hy.
   intro abs; contradict abs.
   exists y. split; assumption.
Qed.

Lemma FinEnum_is_MetricSpace : is_MetricSpace FinEnum_ball.
Proof.
 split.
 - intros e epos x. apply hausdorffBall_refl, epos.
 - intros e x y. apply hausdorffBall_sym.
 - intros e d x y z. apply hausdorffBall_triangle.
 - intros e x y. unfold FinEnum_ball.
   apply FinEnum_ball_closed.
 - intros. apply H.
 - intros e x y.
   apply hausdorffBall_stable.
Qed.

Definition FinEnum : MetricSpace :=
Build_MetricSpace FinEnum_ball_e_wd FinEnum_is_MetricSpace.

Lemma FinEnum_eq_equiv : forall (x y : FinEnum),
    FinEnum_eq x y <-> msp_eq x y.
Proof.
  unfold FinEnum_eq, msp_eq. split.
  - intros. split. apply Qle_refl. split.
    intros z H0. rewrite H in H0.
    intro abs. apply (abs z).
    split. exact H0. reflexivity.
    intros z H0. rewrite <- H in H0.
    intro abs. apply (abs z).
    split. exact H0. reflexivity.
  - split.
    + intros z H0.
      destruct H as [_ [H1 _]].
      specialize (H1 x0 z). clear z.
      unfold existsC in H1.
      contradict H1; intros x1 [H1 H2].
      unfold InFinEnumC, FinSubset_ball in H1.
      contradict H1; intros [t H1].
      contradict H0. exists t. split.
      apply H1. rewrite H2. apply H1.
    + intros z H0.
      destruct H as [_ [_ H1]].
      specialize (H1 x0 z). clear z.
      unfold existsC in H1.
      contradict H1; intros x1 [H1 H2].
      unfold InFinEnumC, FinSubset_ball in H1.
      contradict H1; intros [t H1].
      contradict H0. exists t. split.
      apply H1. rewrite H2. apply H1.
Qed.

Lemma FinSubset_ball_triangle_r : forall e1 e2 x (l1 l2 : FinEnum),
    FinSubset_ball e1 x l1 -> (ball e2 l1 l2) -> FinSubset_ball (e1 + e2) x l2.
Proof.
 intros e1 e2 x l1 l2 H1 [epos [H2 _]].
 revert l2 H1 H2.
 induction l1; intros l2 H1 H2.
 exfalso; exact (FinSubset_ball_nil H1).
 unfold hemiMetric in *.
 apply FinSubset_ball_orC in H1.
 destruct H1 as [G | H1 | H1] using orC_ind.
 intro abs; contradict G; intro G; contradiction.
  assert (Z:InFinEnumC a (a :: l1)).
  { intro abs; contradict abs.
    exists a. split. left; reflexivity. reflexivity. }
  destruct (H2 a Z) as [ G | z [Hz0 Hz1]] using existsC_ind.
 intro abs; contradict G; intro G; contradiction.
  clear - H1 Hz0 Hz1.
  apply FinSubset_ball_closed.
  intros d dpos.
  apply FinSubset_ball_triangle_l with z.
   apply ball_triangle with a; assumption.
   apply FinSubset_ball_weak_le with (e1:=0).
   apply Qlt_le_weak, dpos. exact Hz0.
 apply IHl1.
  assumption.
 intros y Hy.
 apply H2.
 apply FinSubset_ball_cons.
 exact Hy.
Qed.

Lemma FinEum_map_ball : forall (f:X -> X) (e:Qpos) (s:FinEnum),
 (forall x, ball (proj1_sig e) x (f x)) -> ball (proj1_sig e) s (map f s).
Proof.
 intros f e s H.
 induction s. split. apply Qpos_nonneg.
 - split; intros a b abs; apply (FinSubset_ball_nil b).
 - destruct IHs as [IHs0 IHs1].
   split. apply Qpos_nonneg.
   split; intros x y abs; unfold InFinEnumC, FinSubset_ball in y; contradict y
   ; intros [y [iny H0]].
   destruct iny.
   + subst y.
     specialize (abs (f a)). contradict abs.
     split.
     apply InFinEnumC_weaken.
     left. reflexivity.
     rewrite H0. apply H.
   + destruct IHs1 as [IHs1 _].
     pose proof (@FinSubset_ball_wd x y 0 0 s eq_refl H0) as [_ H2].
     specialize (IHs1 x (H2 (InFinEnumC_weaken y s H1))).
     unfold existsC in IHs1. contradict IHs1.
     intros z [H3 H4].
     specialize (abs z). contradict abs.
     split. 2: exact H4. simpl.
     apply FinSubset_ball_cons.
     exact H3.
   + destruct iny. subst y.
     specialize (abs a). contradict abs.
     split. apply InFinEnumC_weaken. left. reflexivity.
     rewrite H0. apply ball_sym, H.
     destruct IHs1 as [_ IHs1].
     pose proof (@FinSubset_ball_wd x y 0 0 (map f s) eq_refl H0) as [_ H2].
     specialize (IHs1 x (H2 (InFinEnumC_weaken y _ H1))).
     unfold existsC in IHs1. contradict IHs1.
     intros z [H3 H4].
     specialize (abs z). contradict abs.
     split. 2: exact H4. simpl.
     apply FinSubset_ball_cons.
     exact H3.
Qed.

Section Strong.
(**
** Strong Hausdroff Metric
This section shows that the strong version of the Hausdroff metric
is equivalen to the weak version when X is a located metric.
*)
Hypothesis almostDecideX : locatedMetric X.

Lemma HemiMetricHemiMetricStrong : forall (e:Q) A b,
    hemiMetric X e A (fun a => InFinEnumC a b)
    -> hemiMetricStrong X e A (fun a => InFinEnumC a b).
Proof.
 intros e A b H x Hx.
 generalize (H x Hx).
 clear H.
 revert x Hx.
 induction b; intros x Hx H d.
 - abstract (unfold existsC in H; contradict H;
             intros y [H _]; exact (FinSubset_ball_nil H)).
 - destruct (@almostDecideX e (e + proj1_sig d) x a).
   clear - e d.
   abstract ( simpl; rewrite -> Qlt_minus_iff; ring_simplify; auto with * ).
  exists a.
  clear - b0.
  abstract (auto using InFinEnumC_weaken with * ).
 assert (Z:existsC X (fun y : X => InFinEnumC y b /\ ball (m:=X) e x y)).
 { clear - H n.
   destruct (H) as [HG | y [Hy0 Hy1]] using existsC_ind.
   auto using existsC_stable.
   apply existsWeaken. exists y.
   split. 2: exact Hy1.
   apply FinSubset_ball_orC in Hy0.
   destruct Hy0 as [HG | Hy | Hy] using orC_ind.
   intro abs. contradict HG; intro HG; contradiction.
   2: assumption.
   apply (ball_wd _ eq_refl _ _ (reflexivity _) _ _ Hy) in Hy1.
   contradiction. }
 exists (let (y,_) := (IHb x Hx Z d) in y).
 clear - IHb.
 abstract (destruct (IHb x Hx Z d) as [y [Hy0 Hy1]]; split; auto;
           apply FinSubset_ball_cons, Hy0).
Defined.

Lemma HausdorffBallHausdorffBallStrong : forall (e:Q) (a b:FinEnum),
 ball e a b ->
 hausdorffBallStrong X e (fun x => InFinEnumC x a) (fun x => InFinEnumC x b).
Proof.
 intros e a b [H0 H1].
 split; apply HemiMetricHemiMetricStrong; apply H1.
Defined.

Lemma HemiMetricStrongAlmostDecidableBody :
 forall (e d:Q) a (b : FinEnum),
 e < d ->
 {hemiMetric X d (fun x => msp_eq x a) (fun x => InFinEnumC x b)} +
 {~hemiMetric X e (fun x => msp_eq x a) (fun x => InFinEnumC x b)}.
Proof.
  intros e d a b.
  induction b.
  - intros Hed.
    right.
    abstract (intros H; apply (H a); try reflexivity;
              intros x [Hx0 Hx1]; exact (FinSubset_ball_nil Hx0)).
  - intros Hed.
    destruct (IHb Hed) as [H|H].
    left.
    abstract (intros x Hx; destruct (H x Hx) as [HG | z [Hz0 Hz1]] using existsC_ind;
              [apply existsC_stable; auto|]; apply existsWeaken; exists z; split;
              try assumption;
              apply FinSubset_ball_cons, Hz0).
    destruct (@almostDecideX _ _ a a0 Hed).
    + left.
      intros x Hx; apply existsWeaken; exists a0.
      split. auto using InFinEnumC_weaken with *.
      apply (ball_wd _ eq_refl _ _ Hx _ _ (reflexivity _)).
      auto using InFinEnumC_weaken with *.
    + right.
      intros H0; assert (Haa:msp_eq a a) by reflexivity;
        destruct (H0 a Haa) as [HG | z [Hz0 Hz1]] using existsC_ind; [tauto|].
      apply FinSubset_ball_orC in Hz0.
      destruct Hz0 as [HG | Hz2 | Hz2] using orC_ind.
      tauto.
      apply (ball_wd _ eq_refl _ _ (reflexivity _) _ _ Hz2) in Hz1.
      contradiction.
      apply H; intros x Hx; apply existsWeaken; exists z.
      split. exact Hz2.
      apply (ball_wd _ eq_refl _ _ Hx _ _ (reflexivity _)). auto.
Defined.

Lemma HemiMetricStrongAlmostDecidable :
 forall (e d:Q) (a b : FinEnum),
 e < d ->
 {hemiMetric X d (fun x => InFinEnumC x a) (fun x => InFinEnumC x b)} +
 {~hemiMetric X e (fun x => InFinEnumC x a) (fun x => InFinEnumC x b)}.
Proof.
 induction a.
  intros a _.
  left.
  intros x Hx _.
  exact (FinSubset_ball_nil Hx).
 intros b Hed.
 destruct (IHa b Hed) as [I|I].
  destruct (@HemiMetricStrongAlmostDecidableBody _ _ a b Hed) as [J|J].
   left.
   abstract ( intros x Hx; apply FinSubset_ball_orC in Hx;
              destruct Hx as [HG | ? | ?] using orC_ind;
              [auto using existsC_stable
     |apply J; assumption |apply I; assumption]).
  right.
  abstract (intros H; apply J; intros x Hx; apply H;
            intro abs; contradict abs; exists a; split; [left; reflexivity | apply Hx]).
 right.
  abstract (intros H; apply I; intros x Hx; apply H;
            apply FinSubset_ball_cons, Hx).
Defined.

(** Finite Enumerations preserve the locatedness property. *)
Lemma FinEnum_located : locatedMetric FinEnum.
Proof.
 intros e d a b Hed.
 destruct (Q.Qle_dec 0 e).
 - destruct (@HemiMetricStrongAlmostDecidable _ _ a b Hed).
   destruct (@HemiMetricStrongAlmostDecidable _ _ b a Hed).
   left. split. apply (Qle_trans _ _ _ q). apply Qlt_le_weak, Hed.
   split; assumption.
   right. intro abs. destruct abs, H0. contradiction.
   right. intro abs. destruct abs, H0. contradiction.
 - right. intro abs. destruct abs. contradiction.
Defined.

(** Finite Enumerations preserve the prelength property assuming X
is a located metric space.

If we change the definition of prelenght space to use a classical
existential, then we could drop the located assumption of X.  I
believe there would be no harm in changing the definition this way,
but it has not been done yet. *)
Hypothesis preLengthX : PrelengthSpace X.

Lemma FinEnum_prelength : PrelengthSpace FinEnum.
Proof.
 intros a b e.
 revert a b.
 cut (forall d1 d2 : Qpos, proj1_sig e < proj1_sig (d1 + d2)%Qpos ->
   forall (a b:FinEnum), hemiMetricStrong X (proj1_sig e) (fun x : X => InFinEnumC x a)
     (fun x : X => InFinEnumC x b) ->
       exists2 c : FinEnum, ball (proj1_sig d1) a c &  hemiMetric X (proj1_sig d2) (fun x : X => InFinEnumC x c) (fun x : X => InFinEnumC x b)).
  intros Z a b d1 d2 He H.
  destruct (HausdorffBallHausdorffBallStrong H) as [Hl Hr].
  clear H.
  destruct (Z _ _ He _ _ Hl) as [c0 Hc0 Hc0c].
  assert (He0: proj1_sig e < proj1_sig (d2 + d1)%Qpos).
   clear - He.
   abstract (simpl; rewrite -> Qplus_comm; assumption).
  destruct (Z _ _ He0 _ _ Hr) as [c1 Hc1 Hc1c].
  clear Z Hl Hr.
  exists (c0 ++ c1).
  split. apply Qpos_nonneg. destruct Hc0 as [_ Hc0].
   abstract ( destruct Hc0 as [Hc0a Hc0b]; destruct Hc1 as [Hc1a Hc1b]; split; intros x Hx;
     [destruct (Hc0a x Hx) as [ G | y [Hya Hyb]] using existsC_ind;
       [auto using existsC_stable | apply existsWeaken; exists y; unfold InFinEnumC; auto]
         |destruct (@FinSubset_ball_app_orC _ _ _ _ Hx) as [G | Hxl | Hxr] using orC_ind;
           [auto using existsC_stable |destruct (Hc0b x Hxl) as [ G | y [Hya Hyb]] using existsC_ind;
             [auto using existsC_stable | apply existsWeaken; exists y; auto]
               |destruct (Hc1c x Hxr) as [ G | y [Hya Hyb]] using existsC_ind;
                 [auto using existsC_stable | apply existsWeaken; exists y; auto]]]).
   split. apply Qpos_nonneg.
   destruct Hc0 as [_ Hc0]. destruct Hc1 as [_ Hc1].
  abstract ( destruct Hc0 as [Hc0a Hc0b]; destruct Hc1 as [Hc1a Hc1b]; split; intros x Hx;
    [destruct (@FinSubset_ball_app_orC _ _ _ _ Hx) as [G | Hxl | Hxr] using orC_ind;
      [auto using existsC_stable |destruct (Hc0c x Hxl) as [ G | y [Hya Hyb]] using existsC_ind;
        [auto using existsC_stable | apply existsWeaken; exists y; auto]
          |destruct (Hc1b x Hxr) as [ G | y [Hya Hyb]] using existsC_ind;
            [auto using existsC_stable | apply existsWeaken; exists y; auto]]
              |destruct (Hc1a x Hx) as [ G | y [Hya Hyb]] using existsC_ind;
                [auto using existsC_stable | apply existsWeaken; exists y; unfold InFinEnumC; auto]]).
 intros d1 d2 He a b H.
 induction a.
  exists nil.
   apply ball_refl. apply Qpos_nonneg.
  intros x Hx; exfalso; exact (FinSubset_ball_nil Hx).
 destruct IHa as [c1 Hc1a Hc1b].
 abstract (intros x Hx d; apply (H x); apply FinSubset_ball_cons, Hx).
 destruct (Qpos_sub _ _ He) as [g Hg].
 pose (exist (Qlt 0) (1#2) eq_refl) as half.
 destruct (fun z => H a z (half*g)%Qpos) as [b0 Hb0].
 abstract (intro abs; contradict abs; exists a; split;
           [left; reflexivity | reflexivity]).
 clear H.
 destruct (@preLengthX a b0 (e + half * g)%Qpos d1 d2) as [c Hc0 Hc1].
   abstract ( clear - Hg; unfold QposEq in Hg; rewrite -> Hg; simpl; rewrite -> Qlt_minus_iff; ring_simplify;
     apply (Qpos_ispos ((1#2)*g))).
  abstract (clear - Hb0; destruct Hb0; auto).
 exists (c :: c1).
 - split. apply Qpos_nonneg. split; intros x Hx.
   + apply FinSubset_ball_orC in Hx.
     destruct Hx as [ G | Hx | Hx ] using orC_ind.
     auto using existsC_stable.
     apply existsWeaken. exists c. split.
     intro abs; contradict abs; exists c; split; [left; reflexivity | reflexivity].
     rewrite Hx. assumption.
     destruct Hc1a as [_ Hc1a].
     destruct Hc1a as [Hc1a _].
     destruct (Hc1a x Hx) as [ G | y [Hy0 Hy1]] using existsC_ind;
       [auto using existsC_stable|].
     apply existsWeaken; exists y; split; auto.
     apply FinSubset_ball_cons. exact Hy0.
   + apply FinSubset_ball_orC in Hx.
     destruct Hx as [ G | Hx | Hx ] using orC_ind.
     auto using existsC_stable.
     apply existsWeaken; exists a; split.
     intro abs; contradict abs; exists a; split; [left; reflexivity | reflexivity].
     apply (ball_wd _ eq_refl _ _ Hx _ _ (reflexivity _)); auto with *.
     destruct Hc1a as [_ Hc1a].
     destruct Hc1a as [_ Hc1a];
       destruct (Hc1a x Hx) as [ G | y [Hy0 Hy1]] using existsC_ind;
       [auto using existsC_stable|]; apply existsWeaken; exists y; split; auto.
     apply (@FinSubset_ball_cons y). exact Hy0.
 - destruct Hb0 as [Hb0a Hb0b]; intros x Hx.
   apply FinSubset_ball_orC in Hx.
   destruct Hx as [ G | Hx | Hx ] using orC_ind.
   auto using existsC_stable.
   apply existsWeaken; exists b0; split; auto.
   apply (ball_wd _ eq_refl _ _ Hx _ _ (reflexivity _)); auto.
   apply Hc1b; auto.
Defined.

End Strong.

End Finite.

(* begin hide *)
Add Parametric Morphism {X : MetricSpace} : (FinSubset_ball X)
    with signature Qeq ==> (@msp_eq _) ==> (@msp_eq (FinEnum X)) ==> iff
      as FinSubset_ball_wd_full.
Proof.
 unfold FinEnum_eq.
 assert (Y:forall x1 x2 : Q, x1 == x2 -> forall y1 y2 : X,
              msp_eq y1 y2 ->forall z : FinEnum X,
                (FinSubset_ball _ x1 y1 z
                 -> FinSubset_ball _ x2 y2 z)).
  { intros x1 x2 Hx y1 y2 Hy.
  induction z.
  intros. exfalso; exact (FinSubset_ball_nil H).
  intros H.
  apply FinSubset_ball_orC in H.
  destruct H as [G | H | H] using orC_ind.
  intro abs; contradict G; intro G; contradiction.
  intro abs; contradict abs.
  exists a. split. left. reflexivity.
   unfold QposEq in Hx. rewrite <- Hx, <- Hy.
   assumption.
   apply FinSubset_ball_cons.
  apply IHz; assumption. }
 intros x1 x2 Hx y1 y2 Hy.
 cut (forall z1 x3 : FinEnum X, (forall x : X, InFinEnumC _ x z1 -> InFinEnumC _ x x3) ->
   (FinSubset_ball _ x1 y1 z1 -> FinSubset_ball _ x2 y2 x3)).
  { intros Z z1 z2 Hz.
  split.
   apply Z.
   intros x H.
   simpl in Hz.
   apply FinEnum_eq_equiv in Hz.
   rewrite <- (Hz x).
   exact H.
  intros H.
  eapply Y.
    unfold QposEq.
    simpl; symmetry.
    apply Hx.
   symmetry.
   apply Hy.
  eapply Z.
   intros a Ha.
   apply FinEnum_eq_equiv in Hz.
   apply <- (Hz a).
   apply Ha.
  eapply Y.
    unfold QposEq.
    simpl; symmetry.
    apply Hx.
   symmetry.
   apply Hy.
  assumption. }
 induction z1; intros z2 Hz.
  intro abs; exfalso; exact (FinSubset_ball_nil abs).
 intros H.
 apply FinSubset_ball_orC in H.
 destruct H as [G | H | H] using orC_ind.
 intro abs; contradict G; intro G; contradiction.
  assert (Z:InFinEnumC _ a z2).
   apply Hz.
   intro abs; contradict abs.
   exists a. split. left; reflexivity. reflexivity.
  rewrite -> Hx, Hy in H.
  clear - H Z.
  induction z2.
  exfalso; exact (FinSubset_ball_nil Z).
  apply FinSubset_ball_orC in Z.
  destruct Z as [G | Z | Z] using orC_ind.
 intro abs; contradict G; intro G; contradiction.
   rewrite -> Z in H.
   intro abs; contradict abs.
   exists a0. split. left. reflexivity. exact H.
   apply FinSubset_ball_cons.
  apply IHz2; auto.
 apply IHz1.
  intros b Hb.
  apply Hz.
  apply FinSubset_ball_cons.
  exact Hb. exact H.
Qed.

(* begin hide *)
Arguments InFinEnumC [X].
Arguments FinSubset_ball [X].
(* end hide *)
(** A list is equivalent to it's reverse as finite enumerations *)
Lemma FinEnum_eq_rev : forall X (f:FinEnum X), msp_eq f (rev f).
Proof.
  intros. apply FinEnum_eq_equiv.
  split.
  - intros H abs. unfold InFinEnumC, FinSubset_ball in H.
    contradict H; intros [y H].
    contradict abs. exists y. split.
    rewrite <- in_rev. apply H. apply H.
  - intros H abs. unfold InFinEnumC, FinSubset_ball in H.
    contradict H; intros [y H].
    contradict abs. exists y. split.
    rewrite in_rev. apply H. apply H.
Qed.

Local Open Scope uc_scope.

(** [map] is comparable with classical in.
    A proper f with respect to the setoid equivalences would be enough. *)
Lemma InFinEnumC_map : forall (X Y:MetricSpace) (f:X --> Y) a l,
    InFinEnumC a l -> InFinEnumC (f a) (map f l).
Proof.
  intros. intro abs.
  unfold InFinEnumC, FinSubset_ball in H.
  contradict H; intros [y [H H0]].
  contradict abs. exists (f y). split.
  apply in_map. exact H.
  rewrite H0. reflexivity.
Qed.

(** The map function for finite enumerations is uniformly continuous *)
Definition FinEnum_map_modulus (z:Qpos) (muf : Qpos -> QposInf) (e:Qpos) :=
match (muf e) with
| QposInfinity => z
| Qpos2QposInf d => d
end.

(* if a is empty and b is not, then (map f a) and (map f b) are not equivalent,
 even if f is the constant function *)
Lemma FinEnum_map_uc : forall z X Y (f:X --> Y),
    is_UniformlyContinuousFunction (map f:FinEnum X -> FinEnum Y)
                                   (FinEnum_map_modulus z (mu f)).
Proof.
 intros z X Y f e.
 cut (forall (a b : FinEnum X) (d:Qpos),
         (QposInf_le d (mu f e)) ->
         ball (proj1_sig d) a b
         -> ball (m:=FinEnum Y) (proj1_sig e) (map f a) (map f b)).
 { intros Z a b.
  unfold FinEnum_map_modulus.
  case_eq (mu f e).
   intros d Hd H.
   apply Z with d; auto.
   rewrite Hd.
   simpl; auto with *.
  intros He H.
  apply Z with z; auto.
  rewrite He.
  constructor. }
 revert e.
 cut (forall (e d:Qpos), (QposInf_le d (mu f e)) -> forall (s1 s2 : FinEnum X),
   hemiMetric X (proj1_sig d) (fun a => InFinEnumC a s1) (fun a => InFinEnumC a s2) ->
     hemiMetric Y (proj1_sig e) (fun a => InFinEnumC a (map f s1:FinEnum Y)) (fun a => InFinEnumC a (map f s2))).
  { intros Z e s1 s2 d Hd [H0 H1].
  split. apply Qpos_nonneg.
  split; apply (Z e d Hd); apply H1. }
 intros e d Hd s1 s2.
 intros H a Ha.
 induction s1.
  exfalso; exact (FinSubset_ball_nil Ha).
  apply FinSubset_ball_orC in Ha.
 destruct Ha as [G | Ha | Ha] using orC_ind.
   auto using existsC_stable.
  assert (Ha0:InFinEnumC a0 (a0::s1)).
  intro abs; contradict abs. exists a0.
  split. left. reflexivity. reflexivity.
  destruct (H a0 Ha0) as [G | y [Hy0 Hy1]] using existsC_ind.
   auto using existsC_stable.
  apply existsWeaken.
  exists (f y).
  split.
   apply InFinEnumC_map; assumption.
   rewrite Ha.
  apply (uc_prf f).
  apply ball_ex_weak_le with d; auto.
 apply IHs1; auto.
 intros b Hb.
 apply H.
 apply (@FinSubset_ball_cons _ b).
 exact Hb.
Qed.
(* begin hide *)
Arguments FinEnum_map_uc z [X Y].
(* end hide *)

Definition FinEnum_map z (X Y : MetricSpace) (f:X --> Y) : FinEnum X --> FinEnum Y
  := Build_UniformlyContinuousFunction (FinEnum_map_uc z f).

(** maping [Cunit] is an injection from FinEnum X to FinEnum Complete X that
preserves the metric *)
Lemma FinEnum_map_Cunit : forall X (s1 s2:FinEnum X) (e:Qpos),
    ball (proj1_sig e) s1 s2 <-> ball (proj1_sig e) (map Cunit s1:FinEnum (Complete X)) (map Cunit s2).
Proof.
 intros X s1 s2 e.
 split.
 - intros H.
   exact (@FinEnum_map_uc (1 # 1) _ _ Cunit e s1 s2 H).
 - revert s1 s2.
 cut (forall (s1 s2 : FinEnum X) ,
   hemiMetric (Complete X) (proj1_sig e) (fun a => InFinEnumC a (map Cunit s1:FinEnum (Complete X)))
     (fun a => InFinEnumC a (map Cunit s2)) ->
       hemiMetric X (proj1_sig e) (fun a => InFinEnumC a s1) (fun a => InFinEnumC a s2)).
  { intros Z s1 s2.
  intros [epos [H0 H1]].
  split. exact epos.
  split; apply Z; assumption. }
 intros s1 s2 H a Ha.
 induction s1.
 exfalso; exact (FinSubset_ball_nil Ha).
 apply FinSubset_ball_orC in Ha.
 destruct Ha as [G | Ha | Ha] using orC_ind.
   auto using existsC_stable.
  clear IHs1.
  assert (Ha0:InFinEnumC (Cunit a0) (map Cunit (a0::s1))).
  intro abs; contradict abs.
  exists (Cunit a0). split.
  left; reflexivity. reflexivity.
  destruct (H _ Ha0) as [G | y [Hy0 Hy1]] using existsC_ind.
   auto using existsC_stable.
  clear - Ha Hy0 Hy1.
  induction s2.
  exfalso; exact (FinSubset_ball_nil Hy0).
  apply FinSubset_ball_orC in Hy0.
  destruct Hy0 as [G | Hy0 | Hy0] using orC_ind.
    auto using existsC_stable.
   apply existsWeaken.
   exists a1.
   split.
  intro abs; contradict abs.
  exists a1. split.
  left; reflexivity. reflexivity.
  rewrite Ha.
  rewrite <- ball_Cunit.
  rewrite <- Hy0.
  assumption.
  destruct (IHs2 Hy0) as [G | z [Hz0 Hz1]] using existsC_ind.
   auto using existsC_stable.
  apply existsWeaken.
  exists z.
  split; auto.
  apply FinSubset_ball_cons.
  exact Hz0.
 apply IHs1; auto.
 intros b Hb.
 apply H.
 apply FinSubset_ball_cons.
 exact Hb.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.

From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import Basic_Cons.Product.

From Categories Require Import NatTrans.NatTrans NatTrans.NatIso.
From Categories Require Import Yoneda.Yoneda.

(** 1 × a ≃ a. where 1 is the terminal object. *)
Section Term_Prod.
  Context {C : Category} {term : (𝟙_ C)%object} {CHP : Has_Products C}.

  Local Notation "1" := (terminal term) : object_scope.

  Local Notation "a × b" := (CHP a b) : object_scope.

  (** Natural transformations to be used with Yoneda. *)
  Program Definition Term_Prod_lr (a : C) :
      ((((Yoneda C) _o (a × 1))%object)
         –≻ ((Yoneda C) _o a)%object)%nattrans
    :=
      {|
        Trans := fun b f => @compose C _ _ _ f (@Pi_1 _ _ _ (CHP a term))
      |}.

  Program Definition Term_Prod_rl (a : C) :
    ((((Yoneda C) _o a)%object)
       –≻ ((Yoneda C) _o (a × 1))%object)%nattrans
    :=
      {|
        Trans := fun b f =>  @Prod_morph_ex C _ _ _ _ f (@t_morph C _ b)
      |}.

  Next Obligation. (* Trans_com *)
  Proof.
    extensionality g.
    eapply Prod_morph_unique; simpl_ids.
    apply Prod_morph_com_1.
    apply Prod_morph_com_2.
    rewrite <- assoc.
    rewrite Prod_morph_com_1; trivial.
    rewrite <- assoc.
    rewrite Prod_morph_com_2.
    apply t_morph_unique.
  Qed.

  Next Obligation. (* Trans_com *)
  Proof.
    symmetry.
    apply Term_Prod_rl_obligation_1.
  Qed.

  Theorem Term_Prod (a : C) : (((×ᶠⁿᶜ C) _o (a, 1)%object) ≃ a)%isomorphism.
  Proof.
    Yoneda.
    apply (NatIso _ _ (Term_Prod_lr a) (Term_Prod_rl a)).
    {
      intros c.
      extensionality g; simpl.
      simpl_ids.
      apply Prod_morph_com_1.
    }
    {
      intros c.
      extensionality g; simpl.
      simpl_ids.
      eapply Prod_morph_unique.
      apply Prod_morph_com_1.
      apply Prod_morph_com_2.
      trivial.
      apply t_morph_unique.
    }
  Qed.

End Term_Prod.


Require Import VST.floyd.proofauto.
Require Import VST.msl.iter_sepcon.
Require Import Lia.
Require malloc.

(* This file has background for memmgr that's independent of the program file *)

(*+ misc *)

(* from VFA, for Z.ltb and Z.eqb *)
Lemma beq_reflect : forall x y, reflect (x = y) (x =? y).
Proof. intros x y. apply iff_reflect. symmetry. apply Z.eqb_eq. Qed.
Hint Resolve Z.ltb_spec0 beq_reflect : bdestruct.
(*  ReflOmegaCore.ZOmega.IP.beq_reflect beq_reflect : bdestruct. *)

Lemma ble_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof. intros x y. apply iff_reflect. symmetry. apply Z.leb_le. Qed.
Hint Resolve ble_reflect : bdestruct.

Lemma andb_reflect : forall x y, reflect (x = true /\ y = true) (x && y).
Proof.
  intros. apply iff_reflect. split.
  intros [Hx Hy]. subst. reflexivity.
  unfold andb. simple_if_tac; intuition.
Qed.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop); assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

(* A bit of infrastructure for brute force proof of claim3.
   TODO consider using Zseq in place of seq in mem_mgr.
*)
Definition Zseq n :=
  if n <? 0 then [] else map Z.of_nat (seq 0 (Z.to_nat n)).

Lemma in_Zseq: forall len n : Z, len >= 0 -> ( In n (Zseq len) <-> (0 <= n < len) ).
Proof.
  intros. unfold Zseq.  bdestruct (len <? 0); try omega. clear H0.
  rewrite in_map_iff. split.
  - intros. destruct H0. destruct H0.
    rewrite in_seq in H1.
    rewrite <- H0. split. rep_omega. destruct H1. simpl in H2.
    apply inj_lt in H2. rewrite Z2Nat.id in H2 by omega. auto.
  - intro. exists (Z.to_nat n).
    split; try rep_omega.
    rewrite in_seq.
    assert (0 <= Z.to_nat n)%nat by (destruct H0; omega).
    simpl. split; try omega. rep_omega.
Qed.

Lemma forall_Forall_range:
     forall (P : Z -> Prop) (n : Z), 0 <= n ->
       ( (forall x, 0 <= x < n -> P x) <-> Forall P (Zseq n) ).
Proof.
  intros.
  assert (Hi:
          (forall x : Z, 0 <= x < n -> P x) <->  (forall x : Z, In x (Zseq n) -> P x)).
  { split. - intros; apply H0; rewrite <- in_Zseq; try omega; auto.
    - intros; apply H0; rewrite in_Zseq; try omega. }
  rewrite Hi. rewrite Forall_forall. reflexivity.
Qed.

(* background for upd_Znth_same_val, belongs in a library *)
Lemma list_extensional {A}{d: Inhabitant A}:
  forall (xs ys: list A),
  Zlength xs = Zlength ys ->
  (forall i, 0 <= i < Zlength xs -> Znth i xs = Znth i ys) -> xs = ys.
Proof.
  intros xs.
  induction xs.
  - intros [|w ws] H Hi. reflexivity.
    rewrite Zlength_nil in H. rewrite Zlength_cons in H.
    assert (0 <= Zlength ws) by apply Zlength_nonneg. omega.
  - intros [|w ws] H Hi.
    rewrite Zlength_nil in H; rewrite Zlength_cons in H.
    assert (H0: 0 <= Zlength xs) by apply Zlength_nonneg; omega.
    specialize (IHxs ws).
    assert (H1: Zlength xs = Zlength ws) by
        ( do 2 rewrite Zlength_cons in H; apply Z.succ_inj in H; auto).
    assert (H2: 0<=0<Zlength (a::xs)) by
        (split; try omega; rewrite Zlength_cons; rep_omega).
    assert (H3: Znth 0 (a :: xs) = Znth 0 (w :: ws)) by (apply Hi; auto).
    apply IHxs in H1.
    + subst. apply Hi in H2. do 2 rewrite Znth_0_cons in H2. subst. reflexivity.
    + apply Hi in H2. do 2 rewrite Znth_0_cons in H2.  subst.
      intros. specialize (Hi (i+1)).   do 2 rewrite Znth_pos_cons in Hi; try omega.
      replace (i+1-1) with i in Hi by omega.
      apply Hi. split; try omega. rewrite Zlength_cons; rep_omega.
Qed.

Lemma upd_Znth_same_val {A} {d: Inhabitant A}:
  forall n (xs: list A), 0 <= n < Zlength xs ->
   (upd_Znth n xs (Znth n xs)) = xs.
Proof.
  intros.  symmetry.  eapply list_extensional.
  rewrite upd_Znth_Zlength; auto.
  intros.  bdestruct (n =? i).
  - subst. rewrite upd_Znth_same; auto.
  - rewrite upd_Znth_diff; auto.
Qed.

Lemma upd_Znth_twice {A} {d: Inhabitant A}:
forall n x y (xs:list A),
   0 <= n < Zlength xs ->
   (upd_Znth n (upd_Znth n xs x) y) = (upd_Znth n xs y).
Proof.
  intros n x y xs H. symmetry.
  eapply list_extensional.
  repeat (rewrite upd_Znth_Zlength; auto).
  intros. bdestruct (n =? i).
  - subst. repeat rewrite upd_Znth_same; auto.
    rewrite upd_Znth_Zlength in *; auto.
  - assert (0 <= i < Zlength xs) by (rewrite upd_Znth_Zlength in H0; auto).
    repeat rewrite upd_Znth_diff; auto;
    rewrite upd_Znth_Zlength in *; auto.
Qed.

Definition zip3 (bs:list nat) (cs:list val) (ds:list Z) := (combine (combine bs cs) ds).

Lemma Zlength_zip3:
   forall bs cs ds,
   Zlength bs = Zlength cs -> Zlength cs = Zlength ds ->
   Zlength (zip3 bs cs ds) = Zlength bs.
Proof.
  intros bs cs ds Hbc Hcd.  unfold zip3.  do 2 rewrite Zlength_correct in *.
  do 2 rewrite combine_length.
  do 2 rewrite Nat2Z.inj_min. rewrite Hbc. rewrite <- Hcd.
  rewrite Z.min_r; try reflexivity.  rewrite Z.min_r; try reflexivity.
Qed.

Lemma Znth_zip3:
   forall bs cs ds n,
   Zlength bs = Zlength cs -> Zlength cs = Zlength ds ->
   0 <= n < Zlength bs ->
   Znth n (zip3 bs cs ds) = (Znth n bs, Znth n cs, Znth n ds).
Proof.
  intros bs cs ds n Hbc Hcd Hn.
  pose proof (Zlength_zip3 bs cs ds Hbc Hcd) as Hz.
  unfold zip3. rewrite <- nth_Znth.
- rewrite combine_nth. rewrite combine_nth.
  rewrite nth_Znth; try omega. rewrite nth_Znth; try omega.
  rewrite nth_Znth; try omega; reflexivity.
  repeat rewrite Zlength_correct in *; omega. rewrite combine_length.
  assert (H3: length bs = length cs) by (repeat rewrite Zlength_correct in *; omega).
  assert (H4: length cs = length ds) by (repeat rewrite Zlength_correct in *; omega).
  rewrite H3; rewrite H4; rewrite Nat.min_id; reflexivity.
- unfold zip3 in Hz; omega.
Qed.

Lemma sublist_zip3:
forall i j bs cs ds,
  0 <= i <= j -> j <= Zlength bs ->
  Zlength bs = Zlength cs -> Zlength cs = Zlength ds ->
(sublist i j (zip3 bs cs ds)) =
(zip3 (sublist i j bs) (sublist i j cs) (sublist i j ds)).
Proof.
  intros.  destruct H as [Hi Hij].
  apply list_extensional.
  - repeat (try rewrite Zlength_sublist; try rewrite Zlength_zip3; try omega).
  - intros.  destruct H as [Hi0lo Hi0hi].
  assert (Hi0: i0 < j - i) by
    (rewrite Zlength_sublist in Hi0hi; auto; rewrite Zlength_zip3; try omega).
  repeat (try rewrite Znth_sublist; try rewrite Znth_zip3; try rewrite Zlength_sublist;
          try omega); auto.
Qed.

Lemma In_zip3:
  forall x bs cs ds,
    In x (zip3 bs cs ds) ->
    In (fst (fst x)) bs /\ In (snd (fst x)) cs /\ In (snd x) ds.
Proof.
intros.
assert (Hx: In (fst x) (combine bs cs)).
{ unfold zip3 in *.
eapply in_combine_l with (y:=snd x).
rewrite <- surjective_pairing. apply H.
}
split3.
- eapply in_combine_l with (y:=snd (fst x)).
  rewrite <- surjective_pairing. apply Hx.
- unfold zip3 in *.
  eapply in_combine_r with (x:=fst (fst x)).
  rewrite <- surjective_pairing. apply Hx.
- unfold zip3 in *.
  eapply in_combine_r with (x:=fst x).
  rewrite <- surjective_pairing.
  apply H.
Qed.

Lemma Zdiv_prod:
  forall a b c, (a*b|c) -> (a|c).
Proof.
  intros. unfold Z.divide in *. destruct H as [z Hz]. exists (z*b)%Z. lia.
Qed.

Ltac simple_if_tac' H :=
  match goal with |- context [if ?A then _ else _] =>
    lazymatch type of A with
    | bool => destruct A eqn: H
    | sumbool _ _ => fail "Use if_tac instead of simple_if_tac, since your expression "A" has type sumbool"
    | ?t => fail "Use simple_if_tac only for bool; your expression"A" has type" t
  end end.
Ltac simple_if_tac'' := let H := fresh in simple_if_tac' H.

(*+ VST related *)

(* maybe some of the next lemmas belong in floyd *)

Lemma malloc_compatible_prefix:
  forall n s p, 0 <= n <= s ->
  malloc_compatible s p -> malloc_compatible n p.
Proof.
  intros n s p H H0; unfold malloc_compatible in *; destruct p; try auto.
  destruct H0. split; try assumption; rep_omega.
Qed.

Lemma malloc_compatible_offset:
  forall n m p, 0 <= n -> 0 <= m ->
  malloc_compatible (n+m) p -> (natural_alignment | m) ->
  malloc_compatible n (offset_val m p).
Proof.
  intros n m p Hn Hm Hp Ha. unfold malloc_compatible in *.
  destruct p; try auto. destruct Hp as [Hi Hinm]. simpl.  split.
- replace (Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr m)))
     with (m + (Ptrofs.unsigned i)).
  apply Z.divide_add_r; auto.
  rewrite Ptrofs.add_unsigned;
  rewrite Ptrofs.unsigned_repr; rewrite Ptrofs.unsigned_repr;
     try omega; try split; try rep_omega.
- replace (Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr m)))
     with (m + (Ptrofs.unsigned i)); try rep_omega.
  rewrite Ptrofs.add_unsigned;
  rewrite Ptrofs.unsigned_repr; rewrite Ptrofs.unsigned_repr;
     try omega; try split; try rep_omega.
Qed.

Lemma malloc_compatible_offset_isptr:
  forall n m q, malloc_compatible n (offset_val m q) -> isptr q.
Proof. intros. destruct q; auto. unfold isptr; auto.
Qed.

Ltac mcoi_tac :=
  eapply malloc_compatible_offset_isptr;
  match goal with | H: malloc_compatible _ _ |- _ => apply H end.

(* variations on VST's memory_block_split *)

Lemma memory_block_split_repr:
  forall (sh : share) (b : block) (ofs : ptrofs) (n m : Z), 0 <= n -> 0 <= m ->
       n + m <= n + m + (Ptrofs.unsigned ofs) < Ptrofs.modulus ->
       memory_block sh (n + m) (Vptr b ofs) =
       memory_block sh n (Vptr b ofs) *
       memory_block sh m (Vptr b (Ptrofs.add ofs (Ptrofs.repr n))).
Proof.
  intros sh b ofs n m Hn Hm Hnm.
  assert (Hofs: ofs = (Ptrofs.repr (Ptrofs.unsigned ofs)))
    by (rewrite Ptrofs.repr_unsigned; auto).
  rewrite Hofs.
  normalize.
  erewrite memory_block_split; try assumption.
  reflexivity.
Qed.

Lemma memory_block_split_offset:
  forall (sh : share) (p : val) (n m : Z), 0 <= n -> 0 <= m ->
       memory_block sh (n + m) p =
       memory_block sh n p *
       memory_block sh m (offset_val n p).
Proof.
  intros sh p n m Hn Hm.
  apply pred_ext. (* to enable use of entailer - at cost of duplicate proof *)
  - (* LHS |-- RHS *)
    destruct p; try entailer!.
    rewrite <- offset_val_unsigned_repr.
    simpl.
    rewrite memory_block_split_repr; try assumption.
    + entailer!.
      rewrite Ptrofs.unsigned_repr. cancel.
      unfold size_compatible' in *; rep_omega.
    + unfold size_compatible' in *; rep_omega.
  - (* RHS |-- LHS
       TODO almost same proof, followed by clumsy finish *)
    destruct p; try entailer!.
    rewrite <- offset_val_unsigned_repr.
    simpl.  rewrite memory_block_split_repr; try assumption.
    entailer!. rewrite Ptrofs.unsigned_repr. cancel.
    unfold size_compatible' in *. rep_omega.
    unfold size_compatible' in *.
    split. rep_omega.
    simpl in *.
    rewrite Ptrofs.modulus_eq32; try unfold Archi.ptr64; auto.
    replace (n+m+Ptrofs.unsigned i) with ((n + Ptrofs.unsigned i)+m) by omega.
    assert (Hni:
              n + Ptrofs.unsigned i = (Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr n)))).
    { rewrite Ptrofs.add_unsigned. rewrite Ptrofs.unsigned_repr; try rep_omega.
      rewrite Ptrofs.unsigned_repr; try rep_omega.
      split; try rep_omega. rewrite Ptrofs.unsigned_repr; rep_omega.
    }
    rewrite Hni; rep_omega.
Qed.

(* Two lemmas from hashtable exercise *)
Lemma iter_sepcon_1:
  forall {A}{d: Inhabitant A} (a: A) (f: A -> mpred), iter_sepcon f [a] = f a.
Proof. intros. unfold iter_sepcon. normalize.
Qed.

Lemma iter_sepcon_split3:
  forall {A}{d: Inhabitant A} (i: Z) (al: list A) (f: A -> mpred),
   0 <= i < Zlength al   ->
  iter_sepcon f al =
  iter_sepcon f (sublist 0 i al) * f (Znth i al) * iter_sepcon f (sublist (i+1) (Zlength al) al).
Proof.
  intros. rewrite <- (sublist_same 0 (Zlength al) al) at 1 by auto.
  rewrite (sublist_split 0 i (Zlength al)) by rep_omega.
  rewrite (sublist_split i (i+1) (Zlength al)) by rep_omega.
  rewrite sublist_len_1 by rep_omega.
  rewrite iter_sepcon_app. rewrite iter_sepcon_app. rewrite iter_sepcon_1.
  rewrite sepcon_assoc. reflexivity.
Qed.

(* Pointer misc *)

Lemma weak_valid_pointer_end:
forall p,
valid_pointer (offset_val (-1) p) |-- weak_valid_pointer p.
Proof.
intros.
unfold valid_pointer, weak_valid_pointer.
change predicates_hered.orp with orp. (* delete me *)
apply orp_right2.
destruct p; try solve [simpl; auto].
all: try apply derives_refl.
simpl.
change predicates_hered.FF with FF. apply FF_left.
unfold offset_val.
hnf.
Transparent Nveric.
red.
Opaque Nveric.
red.
hnf; intros; try contradiction.
simpl.
replace (Ptrofs.unsigned i + -1)
with (Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr (-1))) + 0); auto.
clear H.
rewrite Z.add_0_r.
Abort.  (* Not true *)

Lemma max_unsigned_32: Ptrofs.max_unsigned = Int.max_unsigned.
Proof.
  unfold Ptrofs.max_unsigned, Int.max_unsigned.
  unfold Ptrofs.modulus, Int.modulus.
  unfold Ptrofs.wordsize, Int.wordsize.
  unfold Wordsize_Ptrofs.wordsize, Wordsize_32.wordsize.
  unfold Archi.ptr64.
  reflexivity.
Qed.

Lemma ptrofs_add_for_alignment:
   forall poff n, 0 <= n -> Ptrofs.unsigned poff + n <= Ptrofs.max_unsigned ->
     Ptrofs.unsigned (Ptrofs.add poff (Ptrofs.repr n))
     = Ptrofs.unsigned poff + n.
Proof.
  intros.
  replace poff with (Ptrofs.repr(Ptrofs.unsigned poff)) at 1
    by (rewrite Ptrofs.repr_unsigned; reflexivity).
  rewrite ptrofs_add_repr.
  rewrite Ptrofs.unsigned_repr; try reflexivity.
  split.
  assert (0 <= Ptrofs.unsigned poff) by apply Ptrofs.unsigned_range.
  rep_omega.
  assumption.
Qed.

(*+ constants *)

(* These constants should have the same values as the same-named constants
   in the code. *)

Definition WORD: Z := 4.  (* sizeof(size_t) is 4 for 32bit Clight *)
Definition ALIGN: Z := 2.
Definition BINS: Z.
   let x := constr:(gvar_info malloc.v_bin) in
   let x := eval simpl in x in
   match x with tarray _ ?B => exact B
   end.
Defined.

Definition BIGBLOCK: Z := ((Z.pow 2 17) * WORD).
Definition WA: Z := (WORD*ALIGN) - WORD. (* WASTE at start of block *)

(* Note re CompCert 3: I'm currently using tuint for what in the code
is size_t.  That works for 32bit mode.  To generalize the proof
to 64bit as well, it may work to replace tuint by t_size_t defined like
t_size_t := if Archi.ptr64 then tulong else tuint
*)

Lemma WORD_ALIGN_aligned:
  (natural_alignment | WORD * ALIGN)%Z.
Proof. unfold natural_alignment, WORD, ALIGN; simpl. apply Z.divide_refl. Qed.

(* The following hints empower rep_omega and lessen the need for
   manually unfolding the constant definitions. *)

Ltac compute_eq A := let x := eval vm_compute in A in
    exact (A = x).

Lemma BINS_eq: ltac:(compute_eq BINS).  Proof. reflexivity. Qed.
Hint Rewrite BINS_eq : rep_omega.
Global Opaque BINS. (* make rewrites only happen in rep_omega *)

Lemma BIGBLOCK_eq: ltac:(compute_eq BIGBLOCK).  Proof. reflexivity. Qed.
Hint Rewrite BIGBLOCK_eq : rep_omega.
Global Opaque BIGBLOCK.

Lemma WORD_eq: ltac:(compute_eq WORD).  Proof. reflexivity. Qed.
Hint Rewrite WORD_eq : rep_omega.
Global Opaque WORD.

Lemma ALIGN_eq: ltac:(compute_eq ALIGN).  Proof. reflexivity. Qed.
Hint Rewrite ALIGN_eq : rep_omega.
Global Opaque ALIGN.

Lemma WA_eq: ltac:(compute_eq WA).  Proof. reflexivity. Qed.
Hint Rewrite WA_eq : rep_omega.
Global Opaque WA.

(*+ bin/size conversions and their properties *)

Definition bin2sizeZ := fun b: Z => (((b+1)*ALIGN - 1) * WORD)%Z.

Definition size2binZ : Z -> Z := fun s =>
   if (bin2sizeZ(BINS-1)) <? s
   then -1
   else (s+(WORD * (ALIGN-1))-1) / (WORD * ALIGN).

Lemma bin2size_range:
  forall b, 0 <= b < BINS ->
    WORD <= bin2sizeZ b <= bin2sizeZ(BINS-1).
Proof. intros. unfold bin2sizeZ in *. split; simpl in *; try rep_omega. Qed.

Lemma  bin2sizeBINS_eq: ltac:(compute_eq (bin2sizeZ(BINS-1))).
Proof. reflexivity. Qed.
Hint Rewrite bin2sizeBINS_eq: rep_omega.

Lemma bin2size_align:
  forall b, 0 <= b < BINS -> (natural_alignment | bin2sizeZ b + WORD).
Proof. (* by counting in unary *)
  apply forall_Forall_range; try rep_omega; rewrite BINS_eq; rewrite WORD_eq.
  unfold natural_alignment.
  cbn.
  repeat constructor;
  (apply Zmod_divide; [intro Hx; inv Hx | reflexivity ]).
Qed.

Lemma size2bin_range:
  forall s, 0 <= s <= bin2sizeZ(BINS-1) -> 0 <= size2binZ s < BINS.
Proof.
  intros. unfold size2binZ.
  bdestruct (bin2sizeZ (BINS - 1) <? s); try omega.
  rewrite bin2sizeBINS_eq in *.
  rewrite WORD_eq. rewrite ALIGN_eq. rewrite BINS_eq. simpl.
  replace (s + 4 - 1) with (s + 3) by omega.
  split.
  - apply Z.div_pos; rep_omega.
  - apply Z.div_lt_upper_bound; rep_omega.
Qed.

Fact small_chunks_nonempty: bin2sizeZ(size2binZ(0)) > 0.
Proof. reflexivity. Qed.

Lemma claim1: forall s,
  s <= bin2sizeZ(BINS-1) -> s <= bin2sizeZ(size2binZ s).
Proof.
  intros s H.
  unfold bin2sizeZ, size2binZ in *.
  bdestruct (bin2sizeZ (BINS - 1) <? s); try rep_omega.
  rewrite WORD_eq in *; rewrite ALIGN_eq in *; rewrite BINS_eq in *.
  simpl in *; clear H0.
  replace ((((s + 4 - 1) / 8 + 1) * 2 - 1) * 4)%Z
     with ((s + 4 - 1) / 8 * 8 + 4)%Z by omega.
  replace (s + 4 - 1)%Z with (s + 3) by omega.
  assert (Zmod_eq': forall a b, b > 0 -> (a / b * b)%Z = a - a mod b)
     by (intros; rewrite Zmod_eq; omega);
  rewrite Zmod_eq' by omega; clear Zmod_eq'.
  replace (s + 3 - (s + 3) mod 8 + 4)%Z  with (s + 7 - (s + 3) mod 8)%Z by omega.
  assert ( 0 <= (s+3) mod 8 < 8 ) by (apply Z_mod_lt; omega); omega.
Qed.

Lemma claim2: forall s,
  0 <= s <= bin2sizeZ(BINS-1) -> 0 <= size2binZ s < BINS.
Proof.
  intros; unfold bin2sizeZ in *; unfold size2binZ.
  rewrite WORD_eq in *;  rewrite ALIGN_eq in *.
  bdestruct (bin2sizeZ (BINS - 1) <? s); try rep_omega.
  rewrite Z.sub_add in H.
  change (4*(2-1))%Z with 4.
  simpl.
  split.
  apply Z.div_pos; try omega.
  apply Z.div_lt_upper_bound; try omega.
Qed.

Lemma claim3: forall s, 0 <= s <= bin2sizeZ(BINS-1)
    -> size2binZ(bin2sizeZ(size2binZ(s))) = size2binZ(s).
Proof.
  intros.
  pose proof ((size2bin_range s) H).
  pose proof ((bin2size_range (size2binZ(s))) H0).
  unfold size2binZ.
  bdestruct (bin2sizeZ (BINS - 1) <? s).
  bdestruct (bin2sizeZ (BINS - 1) <? bin2sizeZ (-1)); try omega.
  bdestruct (bin2sizeZ (BINS - 1) <?
             bin2sizeZ ((s + WORD * (ALIGN - 1) - 1) / (WORD * ALIGN))).
  - rewrite WORD_eq in *;  rewrite ALIGN_eq in *;  simpl.
    replace (s + 4 - 1) with (s + 3) by omega.
    exfalso; clear H2.
    replace  ((s + 4 * (2 - 1) - 1) / (4 * 2)) with (size2binZ s) in H3; try omega.
    unfold size2binZ; bdestruct (bin2sizeZ (BINS - 1) <? s); try omega.
    rewrite WORD_eq in *; rewrite ALIGN_eq in *; omega.
  - unfold bin2sizeZ; rewrite WORD_eq in *;  rewrite ALIGN_eq in *; simpl.
    (* gave up fumbling with algebra;
       finish by evaluation, of enumerating the values of s in a list *)
    assert (Htest: forall s,  0 <= s < bin2sizeZ(BINS-1) + 1 ->
      ((((s + 4 - 1) / 8 + 1) * 2 - 1) * 4 + 4 - 1) / 8  = (s + 4 - 1) / 8).
    { set (Q:=fun t =>
                ((((t + 4 - 1) / 8 + 1) * 2 - 1) * 4 + 4 - 1) / 8  = (t + 4 - 1) / 8).
      assert (Hs: 0 <= s < bin2sizeZ(BINS - 1) + 1) by omega.
      assert (Hb: 0 <= bin2sizeZ(BINS - 1) + 1) by omega.
      pose proof (forall_Forall_range Q ((bin2sizeZ (BINS - 1))+1) Hb).
      clear H1 H2 H3 Hb; unfold Q in H4; rewrite H4.
      rewrite bin2sizeBINS_eq. simpl. cbn.
      repeat constructor.
    }
    apply (Htest s); omega.
Qed.

(* TODO another brute force proof; can use this and claim2 to prove claim3 *)
Lemma bin2size2bin_id:
  forall b, 0 <= b < BINS -> size2binZ (bin2sizeZ b) = b.
Proof.
  set (Q:= fun x => size2binZ(bin2sizeZ x) = x).
  assert (HB: 0 <= BINS) by rep_omega.
  pose proof (forall_Forall_range Q BINS HB).
  unfold  Q in H. rewrite H. rewrite BINS_eq.
  cbn. repeat constructor.
Qed.

Lemma bin2size2bin_small:
  forall s, s >= 0 -> s <= bin2sizeZ(BINS - 1) -> size2binZ s < BINS.
Proof. intros. apply claim2; rep_omega. Qed.

Lemma bin2siz2e2bin_large:
  forall s, bin2sizeZ(BINS - 1) < s -> size2binZ s = -1.
Proof.
  intros. unfold size2binZ. bdestruct (bin2sizeZ(BINS-1) <? s). reflexivity. contradiction.
Qed.

(* BIGBLOCK needs to be big enough for at least one chunk of the
largest size, because list_from_bin unconditionally initializes the last chunk. *)
Lemma BIGBLOCK_enough: (* and not too big *)
  forall s, 0 <= s <= bin2sizeZ(BINS-1) ->
            0 < (BIGBLOCK - WA) / (s + WORD) < Int.max_signed.
Proof.
  intros; rewrite bin2sizeBINS_eq in *; split.
  apply Z.div_str_pos; rep_omega.
  rewrite Z_div_lt; rep_omega.
Qed.

Lemma BIGBLOCK_enough_j:
  forall s j, 0 <= s -> j < (BIGBLOCK-WA) / (s+WORD) ->
              (s+WORD) <= (BIGBLOCK-WA) - (j * (s+WORD)).
Proof.
  assert (Hlem: forall sw j bw, 0 < sw -> 0 < bw -> j < bw / sw -> sw <= bw - j*sw).
  { intros. assert (j+1 <= bw/sw) by omega.
    assert (bw/sw*sw <= bw) by (rewrite Z.mul_comm; apply Z.mul_div_le; rep_omega).
    assert ((j+1)*sw <= bw/sw*sw) by (apply Zmult_le_compat_r; rep_omega).
    assert ((j+1)*sw <= bw) by rep_omega.
    replace ((j+1)*sw)%Z with (sw + j*sw)%Z in *.
    rep_omega. replace (j+1) with (Z.succ j) by omega; rewrite Z.mul_succ_l; omega.
  }
  intros; apply Hlem; try rep_omega.
Qed.

Lemma malloc_compat_WORD_q:
(* consequence of the list_from_block loop invariant: remainder of big block is aligned *)
forall N j p s q,
  malloc_compatible BIGBLOCK p ->
  N = (BIGBLOCK-WA) / (s+WORD) ->
  0 <= j < N ->
  0 <= s <= bin2sizeZ(BINS-1) ->
  q = (offset_val (WA+(j*(s+WORD))) p) ->
  (natural_alignment | (s + WORD)) ->
  malloc_compatible (BIGBLOCK - (WA + j * (s + WORD)) - WORD) (offset_val WORD q).
Proof.
  intros N j p s q H HN Hj Hs Hq Ha.
  replace (offset_val (WA + (j*(s+WORD))) p) with
          (offset_val WA (offset_val (j*(s+WORD)) p)) in Hq.
  2: (rewrite offset_offset_val;
      replace (j * (s + WORD) + WA) with (WA + j * (s + WORD)) by omega; reflexivity).
  subst q. do 2 rewrite offset_offset_val.
  apply malloc_compatible_offset.
  - pose proof (BIGBLOCK_enough_j s j) as He.
    destruct Hj as [Hj0 Hj1]; destruct Hs as [Hs0 Hs1]; subst N.
    apply He in Hs0 as H0; auto.
    replace (BIGBLOCK - (WA + j * (s + WORD)) - WORD)
      with (BIGBLOCK - WA - j * (s + WORD) - WORD) by omega.
    apply Zle_minus_le_0.
    rep_omega.
  - apply Z.add_nonneg_nonneg; try rep_omega.
    apply Z.mul_nonneg_nonneg; try rep_omega.
  - replace (BIGBLOCK - (WA + j * (s + WORD)))%Z
      with (BIGBLOCK - WA - j * (s + WORD))%Z by omega.
    replace (BIGBLOCK - WA - j * (s + WORD) - WORD + (j * (s + WORD) + (WA + WORD)))%Z
    with BIGBLOCK by omega; auto.
  - assert ((natural_alignment | WA+WORD))
      by (pose proof WORD_ALIGN_aligned; change (WA+WORD) with (WORD*ALIGN)%Z; auto).
    apply Z.divide_add_r; try auto.
    apply Z.divide_mul_r; try auto.
Qed.

(*+ resource vectors to support pre_fill *)

(* Note on design:
The interface specs could be done in terms of a vector indexed on request sizes.
Instead we index on bin number.
The bin size corresponds to the free list length; we use Z bin size, for
compatibility with other VST interfaces.

TODO maxSmallChunk should be constant in the C code too, at least in free.
*)

Definition resvec := list Z. (* resource vector *)

Definition no_neg rvec : Prop := Forall (fun n => 0 <= n) rvec.

Definition emptyResvec : resvec := repeat 0 (Z.to_nat BINS).

Definition maxSmallChunk := bin2sizeZ(BINS-1).

Lemma maxSmallChunk_eq: ltac:(compute_eq maxSmallChunk).  Proof. reflexivity. Qed.
Hint Rewrite maxSmallChunk_eq : rep_omega.
Global Opaque maxSmallChunk. (* make rewrites only happen in rep_omega *)

(* requested size n fits a bin and the bin is nonempty *)
Definition guaranteed (rvec: resvec) (n: Z): bool :=
  (Zlength rvec =? BINS) && (0 <=? n) && (n <=? maxSmallChunk) &&
  (0 <? Znth (size2binZ n) rvec).

(* add m to size of bin b *)
Definition add_resvec (rvec: resvec) (b: Z) (m: Z): resvec :=
   if ((Zlength rvec =? BINS) && (0 <=? b) && (b <? BINS))%bool
   then upd_Znth b rvec (Znth b rvec + m)
   else rvec.

Definition eq_except (rv rv': resvec) (b: Z): Prop :=
  Zlength rv = Zlength rv' /\
  forall i, 0 <= i < Zlength rv -> i <> b -> Znth i rv = Znth i rv'.

(* number of chunks obtained from one BIGBLOCK, for bin b *)
Definition chunks_from_block (b: Z): Z :=
   if ((0 <=? b) && (b <? BINS))%bool
   then (BIGBLOCK - WA) / ((bin2sizeZ b) + WORD)
   else 0.

Lemma chunks_from_block_nonneg:
  forall b, 0 <= chunks_from_block b.
Proof.
intros.
unfold chunks_from_block.
bdestruct (0 <=? b); simpl; [ | omega].
bdestruct (b <? BINS); simpl; [ | omega].
exploit (bin2size_range b); intros. omega.
exploit (BIGBLOCK_enough (bin2sizeZ b)); intros. rep_omega.
rep_omega.
Qed.

Lemma chunks_from_block_pos:
  forall b, 0 <= b < BINS -> 0 < chunks_from_block b.
Proof.
intros.
unfold chunks_from_block.
bdestruct (0 <=? b); simpl; [ | omega].
bdestruct (b <? BINS); simpl; [ | omega].
exploit (bin2size_range b); intros. omega.
exploit (BIGBLOCK_enough (bin2sizeZ b)); intros. rep_omega.
rep_omega.
Qed.

Lemma Zlength_add_resvec:
  forall rvec b m,
  Zlength (add_resvec rvec b m) = Zlength rvec.
Proof.
intros. unfold add_resvec.
bdestruct (Zlength rvec =? BINS); simpl; auto.
bdestruct (0 <=? b); simpl; auto.
bdestruct (b <? BINS); simpl; auto.
apply upd_Znth_Zlength.
omega.
Qed.

Lemma add_resvec_no_neg:
  forall rvec b m, no_neg rvec -> 0 <= m + Znth b rvec -> no_neg (add_resvec rvec b m).
Proof.
intros.
unfold add_resvec.
bdestruct (Zlength rvec =? BINS); simpl; auto.
bdestruct (0 <=? b); simpl; auto.
bdestruct (b <? BINS); simpl; auto.
unfold no_neg.
unfold upd_Znth.
apply Forall_app.
split.
apply Forall_sublist; auto.
constructor.
omega.
apply Forall_sublist; auto.
Qed.

Lemma add_resvec_eq_except:
  forall rvec b m, eq_except (add_resvec rvec b m) rvec b.
Proof.
intros. unfold eq_except. split.
rewrite Zlength_add_resvec; auto.
intros. unfold add_resvec.
bdestruct (Zlength rvec =? BINS); simpl; auto.
bdestruct (0 <=? b); simpl; auto.
bdestruct (b <? BINS); simpl; auto.
rewrite upd_Znth_diff; try rep_omega. rewrite Zlength_add_resvec in *; auto.
Qed.

Lemma eq_except_reflexive:
  forall rvec b, eq_except rvec rvec b.
Proof.
  intros. unfold eq_except. split; reflexivity.
Qed.

Lemma guaranteed_reflect:
  forall lens n,
    reflect (Zlength lens = BINS /\ 0 <= n <= maxSmallChunk /\ 0 < Znth (size2binZ n) lens)
            (guaranteed lens n).
Proof.
intros.
apply iff_reflect.
split; intros.
- destruct H as [Hlen [[Hn Hnb] Hnz]].
  unfold guaranteed.
 bdestruct (Zlength lens =? BINS); try contradiction.
 bdestruct (0 <=? n); try contradiction.
 bdestruct (n <=? maxSmallChunk); try contradiction.
 bdestruct (0 <? Znth (size2binZ n) lens); try contradiction.
 auto.
- unfold guaranteed in H.
 bdestruct (Zlength lens =? BINS); try discriminate.
 bdestruct (0 <=? n); try discriminate.
 bdestruct (n <=? maxSmallChunk); try discriminate.
 bdestruct (0 <? Znth (size2binZ n) lens); try discriminate.
 auto.
Qed.

(* TODO are the following three lemmas useful to clients?
   Otherwise they can go in the code verifications where each is used once. *)

Lemma is_guaranteed: forall lens n,
   guaranteed lens n = true -> 0 < Znth (size2binZ n) lens.
Proof.
  intros. destruct (guaranteed_reflect lens n) as [Ht|Hf].
  destruct Ht as [Hlen [[Hn Hnb] Hnz]]. assumption. inv H.
Qed.

Lemma large_not_guaranteed: forall lens n,
  maxSmallChunk < n -> guaranteed lens n = false.
Proof.
  intros. destruct (guaranteed_reflect lens n) as [Ht|Hf].
  destruct Ht as [Hlen [[Hn Hnb] Hnz]]. rep_omega. reflexivity.
Qed.

Lemma small_not_guaranteed_zero:
  forall rvec n, Zlength rvec = BINS -> 0 <= n <= maxSmallChunk -> no_neg rvec ->
            guaranteed rvec n = false -> Znth (size2binZ n) rvec = 0.
Proof.
intros. unfold guaranteed in *.
unfold no_neg in *.
bdestruct (Zlength rvec =? BINS); try contradiction.
bdestruct (0 <=? n); try omega.
bdestruct (n <=? maxSmallChunk); try omega.
bdestruct (0 <? Znth (size2binZ n) rvec); try discriminate.
assert (0 <= Znth (size2binZ n) rvec).
apply Forall_Znth. rewrite H. apply size2bin_range. apply H0. assumption. rep_omega.
Qed.