Require Import base.

(* Need(?) the -noinit flag *)

(* Inspired by https://github.com/coq-contribs/zfc/blob/master/zfc.v *)

Require Export Ltac.
Require Export Logic.
Require Export Specif.
(* Attempting to reason without classical logic is too hard (and useless) *)
Require Export Classical.

(* ens ("superset") (transformation function) *)
Inductive Ensemble : Type := ens : forall A : Type, (A -> Ensemble) -> Ensemble.
Definition pi1e (e : Ensemble) := let (A, _) := e in A.
Definition pi2e (e : Ensemble) := match e return pi1e e -> Ensemble with ens _ f => f end.
Corollary ens_pi_is_orig : forall a : Ensemble, a = ens (pi1e a) (pi2e a).
Proof. by intros [A f]; exact (eq_refl _). Qed.
Fixpoint Ensemble_eq (a b : Ensemble) : Prop := let (a', f) := a in let (b', g) := b in
	   (forall x : a', exists y : b', Ensemble_eq (f x) (g y))
	/\ (forall y : b', exists x : a', Ensemble_eq (f x) (g y)).

(* Ensemble_eq is defined by induction in a sense *)
Lemma Eeq_refl : forall a : Ensemble, Ensemble_eq a a.
Proof.
	by intros a; induction a as [a f IHa]; split;
	  intros x; exists x; exact (IHa x).
Qed.
Lemma Eeq_trans : forall a b c : Ensemble, Ensemble_eq a b -> Ensemble_eq b c -> Ensemble_eq a c.
Proof.
	intros a; induction a as [a f IHa]; intros [b g] [c h].
	minimize Ensemble_eq; intros [ainclb bincla] [binclc cinclb]; split.
	clear bincla cinclb; intros x.
	specialize (ainclb x) as [y xinbbyy]; specialize (binclc y) as [z yincbyz].
	by exists z; exact (IHa _ _ _ xinbbyy yincbyz).
	clear ainclb binclc; intros z.
	specialize (cinclb z) as [y zinbbyy]; specialize (bincla y) as [x yinabyx].
	by exists x; exact (IHa _ _ _ yinabyx zinbbyy).
Qed.
Lemma Eeq_sym : forall (a b : Ensemble), (Ensemble_eq a b) -> (Ensemble_eq b a).
Proof.
	intros a; induction a as [a f IHa]; intros [b g] [ainclb bincla]; split.
	by intros y; specialize (bincla y) as [x Hx]; exists x; exact (IHa _ _ Hx).
	by intros x; specialize (ainclb x) as [y Hy]; exists y; exact (IHa _ _ Hy).
Qed.

Infix "E=" := Ensemble_eq (at level 70, no associativity).
Notation "a 'E<>' b" := (~ (a E= b)) (at level 70, no associativity).
Definition In (a B : Ensemble) := let (B', f) := B in exists b : B', a E= (f b).
Infix "inE" := In (at level 70, no associativity).
Notation "'Eforall' x 'in' E , P" := (forall x : Ensemble, x inE E -> P) (at level 200, no associativity, only parsing, x binder).
Notation "'Eexists' x 'in' E , P" := (exists x : Ensemble, (x inE E) /\ P) (at level 200, no associativity, only parsing, x binder).
Notation "'Eforall' x 'in' E 'as' v , P" := (forall x : Ensemble, forall v : x inE E, P) (at level 200, no associativity, only parsing, x binder).
Notation "'Eexists' x 'in' E 'as' v , P" := (exists x : Ensemble, exists v : x inE E, P) (at level 200, no associativity, only parsing, x binder, v binder).
Corollary application_in : forall A : _, forall f : _, forall x : A, f x inE (ens A f).
Proof. by intros A f x; exists x; exact (Eeq_refl _). Qed.
Notation "a 'not_in' b" := (~ (a inE b)) (at level 70, no associativity).
Definition Included (A B : Ensemble) : Prop :=
	Eforall e in A, (e inE B).
Infix "incl" := Included (at level 70, no associativity).
Definition NotIncluded (A B : Ensemble) : Prop :=
	Eexists e in A, ~(e inE B).
Infix "not_incl" := NotIncluded (at level 70, no associativity).

(* Strangely enough, this axiom is provable...
 * (This should be due to how induction works on sets I guess) *)
Lemma extensionality_axiom
	: forall A B : Ensemble, (forall x : _, ((x inE A) <-> (x inE B))) -> (A E= B).
Proof.
	intros [A f] [B g] H; split.
	by intros x; exact (proj1 (iff_and (H (f x))) (application_in _ _ _)).
	intros y;
	  specialize (proj2 (iff_and (H (g y))) (application_in _ _ _)) as [x yinAbyx].
	by exists x; exact (Eeq_sym _ _ yinAbyx).
Qed.
Definition is_prop (P : Ensemble -> Prop) : Prop
	:= forall A : Ensemble, (P A) -> forall B : Ensemble, (A E= B) -> (P B).
Axiom pairing_axiom
	: forall A B : Ensemble, exists C : Ensemble, forall x : Ensemble,
	(x inE C) <-> ((x E= A) \/ (x E= B)).
Axiom union_axiom
	: forall A : Ensemble, exists C : Ensemble, forall x : Ensemble,
	(x inE C) <-> exists Y, (Y inE A) /\ (x inE Y).
Axiom power_set_axiom : forall A : Ensemble, exists C : Ensemble,
	forall X, (X inE C) <-> (X incl A).
Axiom empty_set_axiom : exists E : Ensemble, E = E.
Axiom schema_restricted_comprehension_axiom :
	forall (P : Ensemble -> Prop) (A : Ensemble),
	exists C : Ensemble, forall x,
	(x inE C) <-> ((x inE A) /\ (P x)).

Lemma eq_is_Eeq : forall a b : Ensemble, (a = b) -> (a E= b).
Proof. by intros a ? H; rewrite <-H; exact (Eeq_refl a). Qed.
Lemma Eeq_in_trans_l : forall a b c : Ensemble, (a E= b) -> (a inE c) -> b inE c.
Proof.
	intros [a f] [b g] [c h] [ainclb bincla] [x aincbyx].
	exists x; rewrite (ens_pi_is_orig (h x));
	  rewrite (ens_pi_is_orig (h x)) in aincbyx;
	  destruct aincbyx as [ainclhx hxincla];
	  split.
	intros y.
	specialize (bincla y) as [z Hz];
	  specialize (ainclhx z) as [k Hk].
	by exists k; exact (Eeq_trans _ _ _ (Eeq_sym _ _ Hz) Hk).
	intros y.
	specialize (hxincla y) as [z Hz];
	  specialize (ainclb z) as [k Hk].
	by exists k; exact (Eeq_trans _ _ _ (Eeq_sym _ _ Hk) Hz).
Qed.
Lemma Eeq_in_trans_r : forall a b c : Ensemble, (a E= b) -> (b inE c) -> a inE c.
Proof.
	by intros a b c aeqb binc; apply Eeq_sym in aeqb;
	  exact (Eeq_in_trans_l _ _ _ aeqb binc).
Qed.
Lemma Eeq_incl_trans_l : forall a b c : Ensemble, (a E= b) -> (a incl c) -> b incl c.
Proof.
	intros [a f] [b g] [c h] [_ bincla] ainclc x [y xinbbyy].
	specialize (bincla y) as [z Hz];
	  specialize (ainclc _ (application_in _ _ z)) as [k Hk];
	  exists k.
	by exact (Eeq_trans _ _ _ xinbbyy (Eeq_trans _ _ _ (Eeq_sym _ _ Hz) Hk)).
Qed.
Lemma Eeq_incl_trans_r : forall a b c : Ensemble, (a E= b) -> (b incl c) -> a incl c.
Proof.
	by intros a b c aeqb binclc; apply Eeq_sym in aeqb;
	  exact (Eeq_incl_trans_l _ _ _ aeqb binclc).
Qed.
Lemma in_Eeq_trans_l : forall a b c : Ensemble, (b E= c) -> (a inE b) -> a inE c.
Proof.
	intros [a f] [b g] [c h] [binclc _] [x ainbbyx].
	specialize (binclc x) as [y Hy]; exists y.
	by exact (Eeq_trans _ _ _ ainbbyx Hy).
Qed.
Lemma in_Eeq_trans_r : forall a b c : Ensemble, (b E= c) -> (a inE c) -> a inE b.
Proof.
	by intros a b c beqc ainc; apply Eeq_sym in beqc;
	  exact (in_Eeq_trans_l _ _ _ beqc ainc).
Qed.
Lemma incl_Eeq_trans_l : forall a b c : Ensemble, (b E= c) -> (a incl b) -> a incl c.
Proof.
	intros [a f] [b g] [c h] [binclc _] ainclc x [y xinbbyy].
	specialize (ainclc _ (application_in _ _ y)) as [z Hz];
	  specialize (binclc z) as [k Hk];
	  exists k.
	by exact (Eeq_trans _ _ _ xinbbyy (Eeq_trans _ _ _ Hz Hk)).
Qed.
Lemma incl_Eeq_trans_r : forall a b c : Ensemble, (b E= c) -> (a incl c) -> a incl b.
Proof.
	by intros a b c beqc ainclc; apply Eeq_sym in beqc;
	  exact (incl_Eeq_trans_l _ _ _ beqc ainclc).
Qed.
Arguments Eeq_refl a : clear implicits.
Arguments Eeq_trans {a b c} ainclb binclc.
Arguments Eeq_sym {a b} ainclb.
Arguments eq_is_Eeq {a b} aeqb.
Arguments Eeq_in_trans_l {a b c} aeqb ainc.
Arguments Eeq_in_trans_r {a b c} aeqb binc.
Arguments Eeq_incl_trans_l {a b c} aeqb ainclc.
Arguments Eeq_incl_trans_r {a b c} aeqb binclc.
Arguments in_Eeq_trans_l {a b c} aeqb ainc.
Arguments in_Eeq_trans_r {a b c} aeqb binc.
Arguments incl_Eeq_trans_l {a b c} aeqb ainclc.
Arguments incl_Eeq_trans_r {a b c} aeqb binclc.

Lemma incl_refl : forall a : Ensemble, a incl a.
Proof. by intros a b bina; exact bina. Qed.
Lemma incl_trans : forall a b c : Ensemble, a incl b -> b incl c -> a incl c.
Proof.
	intros a b c ainclb binclc x xina.
	by exact (binclc _ (ainclb _ xina)).
Qed.
Lemma incl_antisym : forall a b : Ensemble, a incl b -> b incl a -> a E= b.
Proof.
	intros [a f] [b g] ainclb bincla; split.
	intros x.
	by exact (ainclb _ (application_in a f x)).
	intros y.
	specialize (bincla _ (application_in b g y)) as [x gyeqfx].
	by exists x; exact (Eeq_sym gyeqfx).
Qed.
Lemma Eeq_incl_l : forall a b : Ensemble, a E= b -> a incl b.
Proof.
	intros [a f] [b g] [ainclb _].
	intros x [y xinabyy].
	specialize (ainclb y) as [z fyeqgz].
	exists z.
	by exact (Eeq_trans xinabyy fyeqgz).
Qed.
Lemma Eeq_incl_r : forall a b : Ensemble, a E= b -> b incl a.
Proof.
	by intros a b beqa; exact (Eeq_incl_l _ _ (Eeq_sym beqa)).
Qed.
Arguments incl_refl a : clear implicits.
Arguments incl_trans {a b c} ainclb binclc.
Arguments incl_antisym {a b} ainclb bincla.
Arguments Eeq_incl_l {a b} aeqb.
Arguments Eeq_incl_r {a b} aeqb.

Lemma notincl_not_incl : forall a b : _, (a not_incl b) -> ~ (a incl b).
Proof. by intros a b [e [eina enib]] ainclb; exact (enib (ainclb _ eina)). Qed.
Lemma not_incl_notincl : forall a b : _, ~ (a incl b) -> (a not_incl b).
Proof.
	intros a b nainclb.
	specialize (not_all_ex_not _ _ nainclb) as [e He].
	by exists e; exact (imply_to_and _ _ He).
Qed.
Arguments notincl_not_incl {a b} anib.
Arguments not_incl_notincl {a b} anib.

Lemma ex_empty_set : exists E : Ensemble, forall x : Ensemble, ~ (x inE E).
Proof.
	specialize empty_set_axiom as [e _].
	specialize (schema_restricted_comprehension_axiom (fun x => x <> x) e) as [V HV].
	exists V; intros x xiV.
	by exact (proj2 (proj1 (iff_and (HV x)) xiV) (eq_refl x)).
Qed.
Definition EmptySet := ens False (fun f => match f return Ensemble with end).
Lemma empty_is_empty : forall x, x not_in EmptySet.
Proof. by intros _ [[] _]. Qed.
Lemma empty_is_empty' : ~ (exists x, x inE EmptySet).
Proof. by intros [_ [[] _]]. Qed.
Lemma empties_are_empty : forall a : Ensemble, (~ (exists x, x inE a)) -> (a E= EmptySet).
Proof.
	intros a ae.
	apply incl_antisym.
	intros x xina.
	by is_false (ae (ex_intro _ x xina)).
	intros ? [[] _].
Qed.
Corollary non_empty_is_not_empty : forall A : Ensemble,
  (A E<> EmptySet) -> exists x : _, x inE A.
Proof.
	intros a anee.
	apply NNPP; intros nexxina.
	by exact (anee (empties_are_empty a nexxina)).
Qed.

Inductive prod (A B:Type) : Type :=
  pair : A -> B -> A * B
where "x * y" := (prod x y) : type_scope.
Add Printing Let prod.
Arguments pair {A B} _ _.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
Definition fst {A B} (H: prod A B) := match H with (x, y) => x end.
Definition snd {A B} (H: prod A B) := match H with (x, y) => y end.

Definition separation_cons (A : Ensemble) (P : Ensemble -> Prop) : Ensemble :=
	let (A', f) := A in
	 ens { x : A' | P (f x) }
	   (fun p : { x : A' | P (f x) } => match p with exist _ x _ => f x end).
Notation "E{ x 'in' A | P }" := (separation_cons A (fun x => P))
	(at level 69, only parsing, x binder).
Notation "{ x 'in' A | P }" := (E{ x in A | P })
	(at level 69, only printing, x binder).

Lemma separation_cons_included : forall (A : Ensemble) (P : Ensemble -> Prop),
	E{x in A | P x } incl A.
Proof.
	intros [A f] P x [[y _] xinabyy].
	by exists y; exact xinabyy.
Qed.
Lemma separation_cons_separated : forall (A : Ensemble) (P : Ensemble -> Prop) (Pp : is_prop P),
	Eforall x in E{x in A | P x}, P x.
Proof.
	intros [A f] P Pp x [[y Pfy] xinsepbyy].
	by exact (Pp _ Pfy _ (Eeq_sym xinsepbyy)).
Qed.
Lemma separation_cons_separates : forall (A : Ensemble) (P : Ensemble -> Prop) (Pp : is_prop P),
	Eforall x in A, P x -> (x inE E{x in A | P x}).
Proof.
	intros [A f] P Pp x [y xinAbyy] Px.
	apply Pp in Px.
	by exists (exist (fun x => P (f x)) y (Px _ xinAbyy)); exact xinAbyy.
Qed.

Corollary ex_union_set : forall A B : Ensemble, exists C : Ensemble,
	forall x, (x inE C) <-> ((x inE A) \/ (x inE B)).
Proof.
	intros a b.
	specialize (pairing_axiom a b) as [c' Hc'].
	specialize (union_axiom c') as [c Hc].
	exists c; intros x; specialize (Hc x) as [xincisexy exyisxinc]; split.
	intros xinc; specialize (xincisexy xinc) as [y [yinc' xiny]].
	by specialize (proj1 (iff_and (Hc' y)) yinc') as [xeq | xeq];
	  apply (in_Eeq_trans_l xeq) in xiny; [left | right]; exact xiny.
	intros [xin | xin]; apply exyisxinc; [exists a | exists b]; split.
	1: by exact (proj2 (iff_and (Hc' a)) (or_introl (Eeq_refl _))).
	2: by exact (proj2 (iff_and (Hc' b)) (or_intror (Eeq_refl _))).
	1,2: by exact xin.
Qed.
Inductive binarychoice := | leftopt : binarychoice | rightopt : binarychoice.
Definition pairing_cons (A B : Ensemble)
	:= ens binarychoice (fun b => match b with | leftopt => A | rightopt => B end).
Definition singleton (x : Ensemble) := pairing_cons x x.
Notation "Ep{ A ; B }" := (pairing_cons A B) (at level 69, only parsing).
Notation "{ A  ;  B }" := (pairing_cons A B) (at level 69, only printing).
Notation "Ep{ A }" := (singleton A) (at level 69, only parsing).
Notation "E{ A }" := (singleton A) (at level 69, only printing).
(* For all Ensemble A,
 * ens_union_cons constructs a type that is then mapped to all elements
 *  of the elements of A.
 * existT x y: x is of the type of A, and maps to B by A;
 *   then y is of the type of B, and maps to the final set by B.
 *)
Definition ens_union_cons (A : Ensemble) : Ensemble := let (A', f) := A in
	ens { x : A' & pi1e (f x) }
		(fun X => match X with existT _ x y => pi2e (f x) y end).
Definition pair_union_cons (A B : Ensemble) : Ensemble
	:= ens_union_cons (Ep{A ; B}).

Infix "\union" := pair_union_cons (at level 50, left associativity).
Notation "'\Union' a" := (ens_union_cons a) (at level 69, no associativity).
Notation "a \\ b" := (separation_cons a (fun x => x not_in b)) (at level 69, no associativity).
Definition inter a b := separation_cons a (fun x => x inE b).
Lemma is_prop_inE_l : forall B : Ensemble, is_prop (fun a => a inE B).
Proof.
	intros B a ainB c aeqc; exact (Eeq_in_trans_l aeqc ainB).
Qed.
Lemma is_prop_inE_r : forall a : Ensemble, is_prop (fun B => a inE B).
Proof.
	intros a B ainB c aeqc; exact (in_Eeq_trans_l aeqc ainB).
Qed.
Infix "\inter" := inter (at level 50, left associativity).

Lemma ens_union_is_union : forall A : Ensemble,
	Eforall B in (\Union A), Eexists C in A, B inE C.
Proof.
	intros [A f] [B g] [[x y] BinCbyy].
	exists (f x); split.
	by exact (application_in _ _ _).
	rewrite (ens_pi_is_orig (f x)).
	by exists y; exact BinCbyy.
Qed.
Lemma union_is_ens_union : forall A : Ensemble,
	Eforall B in A, B incl (\Union A).
Proof.
	intros [A f] [B g] [x BinAbyx] [C h] [y CinBbyy].
	rewrite (ens_pi_is_orig (f x)) in BinAbyx.
	destruct BinAbyx as [Binclfx _].
	specialize (Binclfx y) as [y' gxinfxbyy'].
	exists (existT _ x y').
	by exact (Eeq_trans CinBbyy gxinfxbyy').
Qed.
Arguments ens_union_is_union {A B} BinUA.
Arguments union_is_ens_union {A B} BinA.

Lemma ens_inter_is_inter : forall A B : Ensemble,
	Eforall C in A \inter B, (C inE A) /\ (C inE B).
Proof.
	intros a b c cininter; split.
	by exact (separation_cons_included _ _ _ cininter).
	by exact (separation_cons_separated _ _ (is_prop_inE_l _) _ cininter).
Qed.
Lemma inter_is_ens_inter : forall A B : Ensemble,
	Eforall C in A, (C inE B) -> C inE (A \inter B).
Proof. by intros a b c; exact (separation_cons_separates _ _ (is_prop_inE_l _) _). Qed.
Lemma inter_sym : forall A B : Ensemble, A \inter B E= B \inter A.
Proof.
	intros a b; apply incl_antisym; intros x xininter; apply inter_is_ens_inter.
	1,3: by exact (proj2 (ens_inter_is_inter _ _ _ xininter)).
	1,2: by exact (proj1 (ens_inter_is_inter _ _ _ xininter)).
Qed.
Arguments ens_inter_is_inter {A B C} CinAuB.
Arguments inter_is_ens_inter {A B C} CinA CinB.

Lemma l_in_pairing : forall A B : Ensemble, A inE Ep{A ; B}.
Proof.
	by intros A B; exists leftopt; exact (Eeq_refl _).
Qed.
Lemma r_in_pairing : forall A B : Ensemble, B inE Ep{A ; B}.
Proof.
	by intros A B; exists rightopt; exact (Eeq_refl _).
Qed.
Lemma pairing_is_lr : forall A B : Ensemble,
	Eforall C in Ep{A ; B}, C E= A \/ C E= B.
Proof.
	intros A B C [[|] eeq].
	by left;  exact eeq.
	by right; exact eeq.
Qed.
Lemma pairing_trans_l : forall A B C : Ensemble,
	A E= B -> Ep{A ; C} E= Ep{B ; C}.
Proof.
	intros A B C AeqB; apply incl_antisym.
	intros x xinAC.
	specialize (pairing_is_lr _ _ _ xinAC) as [xeqA | xeqC].
	by exact (Eeq_in_trans_r (Eeq_trans xeqA AeqB) (l_in_pairing _ _)).
	by exact (Eeq_in_trans_r xeqC (r_in_pairing _ _)).
	intros x xinBC.
	specialize (pairing_is_lr _ _ _ xinBC) as [xeqB | xeqC].
	by exact (Eeq_in_trans_r (Eeq_trans xeqB (Eeq_sym AeqB)) (l_in_pairing _ _)).
	by exact (Eeq_in_trans_r xeqC (r_in_pairing _ _)).
Qed.
Lemma pairing_trans_r : forall A B C : Ensemble,
	A E= B -> Ep{C ; A} E= Ep{C ; B}.
Proof.
	intros A B C AeqB; apply incl_antisym.
	intros x xinCA.
	specialize (pairing_is_lr _ _ _ xinCA) as [xeqC | xeqA].
	by exact (Eeq_in_trans_r xeqC (l_in_pairing _ _)).
	by exact (Eeq_in_trans_r (Eeq_trans xeqA AeqB) (r_in_pairing _ _)).
	intros x xinCB.
	specialize (pairing_is_lr _ _ _ xinCB) as [xeqC | xeqB].
	by exact (Eeq_in_trans_r xeqC (l_in_pairing _ _)).
	by exact (Eeq_in_trans_r (Eeq_trans xeqB (Eeq_sym AeqB)) (r_in_pairing _ _)).
Qed.
Lemma pairing_trans : forall A B C D : Ensemble, A E= C -> B E= D -> Ep{A ; B} E= Ep{C ; D}.
Proof.
	intros A B C D AeqC BeqD; apply incl_antisym.
	intros x xinAB; specialize (pairing_is_lr _ _ _ xinAB) as [xeqA | xeqB].
	by exact (Eeq_in_trans_r (Eeq_trans xeqA AeqC) (l_in_pairing _ _)).
	by exact (Eeq_in_trans_r (Eeq_trans xeqB BeqD) (r_in_pairing _ _)).
	intros x xinCD; specialize (pairing_is_lr _ _ _ xinCD) as [xeqC | xeqD].
	by exact (Eeq_in_trans_r (Eeq_trans xeqC (Eeq_sym AeqC)) (l_in_pairing _ _)).
	by exact (Eeq_in_trans_r (Eeq_trans xeqD (Eeq_sym BeqD)) (r_in_pairing _ _)).
Qed.
Lemma pairing_sym : forall A B : Ensemble, Ep{A ; B} E= Ep{B ; A}.
Proof.
	intros A B; split; intros [|];
	  [exists rightopt | exists leftopt | exists rightopt | exists leftopt];
	  by exact (Eeq_refl _).
Qed.
Lemma pairing_inj : forall A B C : Ensemble, Ep{A ; C} E= Ep{B ; C} -> A E= B.
Proof.
	intros A B C ACeqBC.
	specialize (pairing_is_lr _ _ _ (in_Eeq_trans_l ACeqBC (l_in_pairing A C))) as [AeqB | AeqC].
	by exact AeqB.
	specialize (pairing_is_lr _ _ _
	  (in_Eeq_trans_l (Eeq_sym ACeqBC) (l_in_pairing B C))) as [BeqA | BeqC].
	by exact (Eeq_sym BeqA).
	by exact (Eeq_trans AeqC (Eeq_sym BeqC)).
Qed.

Lemma pair_union_is_union_l : forall A B : Ensemble, A incl (A \union B).
Proof.
	intros A B e einA.
	by exact (union_is_ens_union (l_in_pairing _ _) _ einA).
Qed.
Lemma pair_union_is_union_r : forall A B : Ensemble, B incl (A \union B).
Proof.
	intros A B e einB.
	by exact (union_is_ens_union (r_in_pairing _ _) _ einB).
Qed.
Lemma pair_union_is_union : forall A B : Ensemble,
	Eforall C in A \union B, C inE A \/ C inE B.
Proof.
	intros [A f] [B g] C [[[|] xval] CinAuBbyx].
	by left;  exists xval; exact CinAuBbyx.
	by right; exists xval; exact CinAuBbyx.
Qed.
Lemma incl_incl_is_union_incl : forall A B C : Ensemble,
	A incl C -> B incl C -> (A \union B) incl C.
Proof.
	intros A B C AinclC BinclC x xinAuB;
	  specialize (pair_union_is_union _ _ _ xinAuB) as [xinA | xinB].
	by exact (AinclC _ xinA).
	by exact (BinclC _ xinB).
Qed.
Arguments pairing_is_lr {A B C} CinAB.
Arguments pairing_inj {A B C} ACeqBC.
Arguments pairing_trans {A B C D} AeqC BeqD.
Arguments pair_union_is_union {A B C} CinAuB.
Arguments incl_incl_is_union_incl {A B C} AinclC BinclC.

Lemma singleton_has_elem : forall A : Ensemble, A inE Ep{A}.
Proof.
	by intros [A f]; exists leftopt; exact (Eeq_refl _).
Qed.
Lemma singleton_is_singleton : forall A : Ensemble, Eforall B in Ep{A}, B E= A.
Proof.
	by intros A B BinsA;
	  specialize (pairing_is_lr BinsA) as [H | H];
	  exact H.
Qed.
Lemma singleton_incl_is_in : forall A B : Ensemble, Ep{A} incl B -> A inE B.
Proof.
	intros A B sAinclB.
	by exact (sAinclB _ (singleton_has_elem A)).
Qed.
Lemma in_is_singleton_incl : forall A B : Ensemble, A inE B -> Ep{A} incl B.
Proof.
	intros A B AinB x xinA.
	by exact (Eeq_in_trans_r (singleton_is_singleton _ _ xinA) AinB).
Qed.
Lemma singleton_refl : forall A B : Ensemble, A E= B -> Ep{A} E= Ep{B}.
Proof.
	intros A B AeqB; apply incl_antisym.
	intros x xinsA.
	apply singleton_is_singleton in xinsA.
	apply (Eeq_in_trans_r (Eeq_trans xinsA AeqB)).
	by exact (singleton_has_elem _).
	intros x xinsB.
	apply singleton_is_singleton in xinsB.
	apply (Eeq_in_trans_r (Eeq_trans xinsB (Eeq_sym AeqB))).
	by exact (singleton_has_elem _).
Qed.
Lemma singleton_inj : forall A B : Ensemble, Ep{A} E= Ep{B} -> A E= B.
Proof.
	intros A B sAeqsB.
	by exact (singleton_is_singleton _ _ (singleton_incl_is_in _ _ (Eeq_incl_l sAeqsB))).
Qed.
Lemma singleton_union_singleton : forall A B : Ensemble, (Ep{A}) \union (Ep{B}) E= Ep{A ; B}.
Proof.
	intros A B; apply incl_antisym.
	intros x xinsAusB; specialize (pair_union_is_union xinsAusB) as [xinsA | xinsB].
	by exact (Eeq_in_trans_r (singleton_is_singleton _ _ xinsA) (l_in_pairing _ _)).
	by exact (Eeq_in_trans_r (singleton_is_singleton _ _ xinsB) (r_in_pairing _ _)).
	intros x xinAB; specialize (pairing_is_lr xinAB) as [xeqA | xeqB].
	by exact (pair_union_is_union_l _ _ _ (Eeq_in_trans_r xeqA (singleton_has_elem _))).
	by exact (pair_union_is_union_r _ _ _ (Eeq_in_trans_r xeqB (singleton_has_elem _))).
Qed.
Arguments singleton_is_singleton {A B} AinsB.
Arguments singleton_incl_is_in {A B} sAinclB.
Arguments in_is_singleton_incl {A B} AinB.
Arguments singleton_refl {A B} AeqB.
Arguments singleton_inj {A B} sAeqsB.

Lemma exists_inter_set
 : forall A, (A E<> EmptySet) ->
  exists C, forall x, (x inE C) <-> (forall a, (a inE A) -> (x inE a)).
Proof.
	intros A Ane.
	specialize (non_empty_is_not_empty _ Ane) as [a0 a0inA]; clear Ane.
	specialize (schema_restricted_comprehension_axiom
	  (fun e => Eforall a in A, e inE a) a0) as [C HC].
	exists C; intros x; specialize (HC x) as [HCl HCr]; split; [clear HCr | clear HCl].
	by intros xiC; exact (proj2 (HCl xiC)).
	by intros H0; exact (HCr (conj (H0 _ a0inA) H0)).
Qed.

Definition Succ (A : Ensemble) := A \union (Ep{A}).
Definition is_nat (A : Ensemble) :=
	(EmptySet inE A) /\ Eforall x in A, ((Succ x) inE A).
Axiom infinity_axiom : { N : Ensemble | (is_nat N) /\ (forall a, (is_nat a) -> N incl a) }.

Definition two_tuple A B := Ep{Ep{A} ; Ep{A ; B}}.
Notation "E( A , B )" := (two_tuple A B) (at level 69, no associativity, only parsing).
Notation "( A ,  B )" := (two_tuple A B) (at level 69, no associativity, only printing).
Lemma two_tuple_antisym : forall A B : Ensemble, E(A, B) E= E(B, A) -> A E= B.
Proof.
	intros A B ABeqBA.
	specialize (pairing_trans_r _ _ (Ep{B}) (pairing_sym A B)) as B_ABeqB_BA.
	specialize (pairing_inj (Eeq_trans ABeqBA (Eeq_sym B_ABeqB_BA))) as sAeqsB.
	by exact (singleton_inj sAeqsB).
Qed.
Lemma two_tuple_eq_l : forall A B C : Ensemble, A E= B -> E(A, C) E= E(B, C).
Proof.
	intros A B C AeqB.
	specialize (singleton_refl AeqB) as sAeqsB.
	specialize (pairing_trans_l _ _ C AeqB) as ACeqBC.
	by exact (pairing_trans sAeqsB ACeqBC).
Qed.
Lemma two_tuple_eq_r : forall A B C : Ensemble, B E= C -> E(A, B) E= E(A, C).
Proof.
	intros A B C BeqC.
	specialize (singleton_refl (Eeq_refl A)) as sAeqsA.
	specialize (pairing_trans_r _ _ A BeqC) as ABeqAC.
	by exact (pairing_trans sAeqsA ABeqAC).
Qed.
Lemma two_tuple_eq : forall A B C D : Ensemble, A E= C -> B E= D -> E(A, B) E= E(C, D).
Proof.
	intros A B C D AeqC BeqD.
	specialize (singleton_refl AeqC) as sAeqsC.
	specialize (pairing_trans AeqC BeqD) as ABeqCD.
	by exact (pairing_trans sAeqsC ABeqCD).
Qed.
Lemma two_tuple_inj_l : forall A B C : Ensemble, E(A, C) E= E(B, C) -> A E= B.
Proof.
	intros A B C pACeqpBC.
	specialize (pairing_is_lr (Eeq_incl_l pACeqpBC _
	    (l_in_pairing _ _))) as [sAeqsB | sAeqBC].
	by exact (singleton_inj sAeqsB).
	by exact (Eeq_sym
	  (singleton_is_singleton (in_Eeq_trans_r sAeqBC (l_in_pairing B C)))).
Qed.
Lemma two_tuple_inj_r : forall A B C : Ensemble, E(A, B) E= E(A, C) -> B E= C.
Proof.
	intros A B C pACeqpBC.
	specialize (pairing_is_lr (Eeq_incl_r pACeqpBC _
	    (r_in_pairing _ _))) as [ACeqsA | sAeqBC].
	specialize (pairing_inj (Eeq_trans (pairing_sym _ _) ACeqsA)) as CeqA.
	specialize (pairing_is_lr (Eeq_incl_l pACeqpBC _
	    (r_in_pairing _ _))) as [ABeqsA | ABeqAC].
	specialize (pairing_inj (Eeq_trans (pairing_sym _ _) ABeqsA)) as BeqA.
	by exact (Eeq_trans BeqA (Eeq_sym CeqA)).
	by exact (pairing_inj
	  (Eeq_trans (Eeq_trans (pairing_sym _ _) ABeqAC) (pairing_sym _ _))).
	by exact (Eeq_sym (pairing_inj
	  (Eeq_trans (Eeq_trans (pairing_sym _ _) sAeqBC) (pairing_sym _ _)))).
Qed.
Arguments two_tuple_antisym {A B} ABeqBA.
Arguments two_tuple_eq {A B C D} AeqC BeqD.

Definition power_set_cons (A : Ensemble) : Ensemble := let (A', f) := A in
	ens (A' -> Prop) (fun P => ens { x : A' | P (x) } (fun k => let (v, _) := k in f v)).
Notation "'Pe' ( A )" := (power_set_cons A) (only printing).
Lemma power_set_is_powset : forall A : Ensemble,
	Eforall B in power_set_cons A, B incl A.
Proof.
	intros [A f] B [c BinPAbyc] x xinB.
	specialize (Eeq_incl_l BinPAbyc _ xinB) as [[y _] xinPSetbyy].
	by exists y; exact xinPSetbyy.
Qed.
Lemma powset_is_power_set : forall A : Ensemble,
	forall B : Ensemble, B incl A -> B inE (power_set_cons A).
Proof.
	intros [A f] B BinclA.
	exists (fun v => f v inE B).
	apply incl_antisym.
	intros x xinB.
	specialize (BinclA _ xinB) as [y xinAbyy].
	rewrite (ens_pi_is_orig B); rewrite (ens_pi_is_orig B) in xinB.
	destruct xinB as [z xinBbyz].
	specialize (Eeq_trans (Eeq_sym xinAbyy) xinBbyz) as fyeqgz.
	exists (exist _ _ (ex_intro _ z fyeqgz)).
	by exact xinAbyy.
	intros x [[y Hy] xinPAbyy].
	by exact (Eeq_in_trans_r xinPAbyy Hy).
Qed.
Lemma power_set_incl : forall A B : Ensemble,
	A incl B -> power_set_cons A incl power_set_cons B.
Proof.
	intros [A f] [B g] AinclB x [P xinPAbyP].
	exists (fun b => g b inE x).
	rewrite (ens_pi_is_orig x); rewrite (ens_pi_is_orig x) in xinPAbyP;
	  destruct xinPAbyP as [xinclPA PAinclx]; split.
	intros y.
	specialize (xinclPA y) as [[z Pz] yeqfz].
	specialize (AinclB _ (application_in _ _ z)) as [k fzeqgk].
	specialize (Eeq_in_trans_l
	  (Eeq_trans yeqfz fzeqgk) (application_in (pi1e x) (pi2e x) y)) as gkinx.
	exists (exist _ k gkinx).
	by exact (Eeq_trans yeqfz fzeqgk).
	intros [y [z yinxbyz]].
	by exists z; exact (Eeq_sym yinxbyz).
Qed.
Lemma power_set_trans : forall A B : Ensemble,
	A E= B -> (power_set_cons A) E= (power_set_cons B).
Proof.
	intros A B AeqB; apply incl_antisym.
	by specialize (Eeq_incl_l AeqB) as AinclB; exact (power_set_incl _ _ AinclB).
	by specialize (Eeq_incl_r AeqB) as BinclA; exact (power_set_incl _ _ BinclA).
Qed.
Arguments power_set_incl {A B} AinclB.
Arguments power_set_trans {A B} AinclB.

Definition cartesian_cons (A B : Ensemble) :=
	E{ x in power_set_cons ((power_set_cons A) \union (power_set_cons (A \union B))) |
	  exists a b : Ensemble, ((a inE A) /\ (b inE B)) /\ (x E= E(a, b))}.
Lemma cartesian_cons_is_product : forall A B : Ensemble,
	Eforall C in cartesian_cons A B,
	 exists a b : Ensemble, ((a inE A) /\ (b inE B)) /\ (C E= E(a, b)).
Proof.
	intros A B C [[x [a [b [[ainA binB] xeqab]]]] Ceqx].
	exists a, b; split; [split|].
	by exact ainA.
	by exact binB.
	by exact (Eeq_trans Ceqx xeqab).
Qed.
Lemma product_is_cartesian_cons : forall A B : Ensemble,
	forall a b : Ensemble, a inE A -> b inE B -> E(a, b) inE cartesian_cons A B.
Proof.
	intros A B a b ainA binB.
	apply separation_cons_separates.
	unfold is_prop; intros E [a1 [b1 [[a1in b1in] eqE]]] F EeqF.
	exists a1, b1; split; [split; [exact a1in|exact b1in]|exact (Eeq_trans (Eeq_sym EeqF) eqE)].
	specialize (in_is_singleton_incl ainA) as sainclA; clear ainA.
	specialize (in_is_singleton_incl binB) as sbinclB; clear binB.
	specialize (incl_trans sainclA (pair_union_is_union_l A B)) as sainclAB.
	specialize (incl_trans sbinclB (pair_union_is_union_r A B)) as sbinclAB; clear sbinclB.
	specialize (incl_incl_is_union_incl sainclAB sbinclAB) as sausbinclAB; clear sainclAB sbinclAB.
	specialize (singleton_union_singleton a b) as sausbeqab.
	specialize (Eeq_incl_trans_l sausbeqab sausbinclAB) as abinclAB; clear sausbeqab sausbinclAB.
	specialize (powset_is_power_set _ _ abinclAB) as abinPAB; clear abinclAB.
	specialize (in_is_singleton_incl abinPAB) as sabinclPAB; clear abinPAB.
	specialize (incl_trans sabinclPAB (pair_union_is_union_r (power_set_cons A) _)) as sabinclAPAB; clear sabinclPAB.
	specialize (powset_is_power_set _ _ sainclA) as sainPA; clear sainclA.
	specialize (in_is_singleton_incl sainPA) as ssainclPA; clear sainPA.
	specialize (incl_incl_is_union_incl
	  (incl_trans ssainclPA (pair_union_is_union_l _ _))
	  sabinclAPAB) as ssausabinclAPAB; clear ssainclPA sabinclAPAB.
	specialize (Eeq_incl_trans_l (singleton_union_singleton _ _) ssausabinclAPAB) as sapabinclAPAB; clear ssausabinclAPAB.
	by exact (powset_is_power_set _ _ sapabinclAPAB).

	exists a, b; split; [split|].
	by exact ainA.
	by exact binB.
	by exact (Eeq_refl _).
Qed.
Definition cartesian (A B : Ensemble) := let (a, f) := A in let (b, g) := B in
	ens (a * b) (fun p => let (x, y) := p in E(f x, g y)).
Lemma cartesian_to_cons : forall A B, cartesian A B E= cartesian_cons A B.
Proof.
	assert (H0 : forall A B, A incl B /\ B incl A -> A E= B).
	{ intros [A f] [B g] [AiB BiA]; split.
	  by intros x; exact (AiB _ (application_in _ _ x)).
	  by intros y; specialize (BiA _ (application_in _ _ y)) as [x Hx];
	    exists x; exact (Eeq_sym Hx). }
	intros [A f] [B g]; apply H0; clear H0; split.
	intros e [[x y] He].
	by apply (Eeq_in_trans_r He), product_is_cartesian_cons; exact (application_in _ _ _).

	intros e [[prop [a [b [[[va ain] [vb bin]] Hpair]]]] He].
	exists (va, vb).
	apply (Eeq_trans (Eeq_trans He Hpair)).
	by apply two_tuple_eq; [exact ain|exact bin].
Qed.
Lemma cartesian_is_product : forall A B : Ensemble,
	Eforall C in cartesian A B,
	 exists a b : Ensemble, ((a inE A) /\ (b inE B)) /\ (C E= E(a, b)).
Proof.
	intros A B C CinAxB.
	apply cartesian_cons_is_product.
	exact (in_Eeq_trans_l (cartesian_to_cons _ _) CinAxB).
Qed.
Lemma product_is_cartesian : forall A B : Ensemble,
	forall a b : Ensemble, a inE A -> b inE B -> E(a, b) inE cartesian A B.
Proof.
	by intros A B a b ain bin; apply (in_Eeq_trans_r (cartesian_to_cons _ _));
	  exact (product_is_cartesian_cons _ _ _ _ ain bin).
Qed.

Definition partial_application_set (A B : Ensemble) : Ensemble :=
	E{ f in power_set_cons (cartesian A B) |
	 forall x y y', E(x, y) inE f -> E(x, y') inE f -> y E= y' }.
Definition total_application_set (A B : Ensemble) : Ensemble :=
	E{ f in partial_application_set A B |
	 Eforall x in A, Eexists y in B, E(x, y) inE f }.
Lemma total_incl_partial : forall A B : Ensemble,
	total_application_set A B incl partial_application_set A B.
Proof.
	by intros [A fA] [B fB] f [[w _] Hw]; exists w; exact Hw.
Qed.
Definition partial_application_cons : forall {A B}, Eforall f in partial_application_set A B,
  forall x : pi1e A, {y : pi1e B | E(pi2e A x, pi2e B y) inE f} -> pi1e B.
	intros A B f inpa x [y _].
	exact y.
Defined.

(** May break Coq's internal consistency: *)
Axiom ex_to_exist : forall A B x f, (exists y, E(pi2e A x, pi2e B y) inE f)
 -> {y : pi1e B | E(pi2e A x, pi2e B y) inE f}.
Definition total_application_cons {A B} f (f_fun : f inE (total_application_set A B)) :
  pi1e A -> pi1e B.
	intros x.
	destruct A as [A fA]; destruct B as [B fB].
	apply (partial_application_cons f (total_incl_partial _ _ _ f_fun) x), ex_to_exist.
	destruct f_fun as [[[prop Hpartial] Htotal] Hf].
	specialize (Htotal _ (application_in _ _ x)) as [y [[v Hy] Hpair]].
	exists v; unfold pi2e; refine (in_Eeq_trans_r Hf (Eeq_in_trans_l _ Hpair)).
	by exact (two_tuple_eq_r _ _ _ Hy).
Defined.


Require Import List PeanoNat Omega Bool MSets MSetDecide Ensembles.

Import ListNotations.

Require Import Strings Sets AutomataTactics.

Structure dfa := {
  Q : S.t;
  Sigma : S.t;

  t : member Q -> member Sigma -> member Q;
  s : member Q;

  A : subset Q;
}.

Arguments Q {d}.
Arguments Sigma {d}.
Arguments t {d} _ _.
Arguments s {d}.
Arguments A {d}.

Fixpoint tStar {M : dfa}
               (q : member (@Q M))
               (str : string Sigma)
               : member Q :=
  match str with
  | []      => q
  | x :: xs => tStar (t q x) xs
  end.

Definition accepted {M : dfa} (x : string Sigma) : bool :=
  match @A M, @tStar M s x with
  | exist _ accepted _, exist _ final _ => S.mem final accepted
  end.

Definition accepted_lang (M : dfa) : language Sigma := fun str => @accepted M str = true.

Definition false_dfa {Sigma : S.t} : dfa :=
  Build_dfa (S.singleton 0) Sigma (fun q => fun x => q) (exist _ 0 eq_refl)
    empty_set.

Definition true_dfa {Sigma : S.t} : dfa :=
  Build_dfa (S.singleton 0) Sigma (fun q => fun x => q) (exist _ 0 eq_refl)
    full_set.

Lemma false_trans_does_nothing :
  forall (Sigma : S.t) (str : string Sigma), @tStar (@false_dfa Sigma) s str = s.
Proof.
autoinduction str.
Qed.

Lemma true_trans_does_nothing :
  forall (Sigma : S.t) (str : string Sigma), @tStar (@true_dfa Sigma) s str = s.
Proof.
autoinduction str.
Qed.

Lemma false_accepts_empty :
  forall {Sigma : S.t},
    accepted_lang false_dfa = empty_language Sigma.
Proof.
simplify.
apply Extensionality_Ensembles.
simplify.
inversion H.
unfold accepted in H1.
rewrite false_trans_does_nothing in H1.
inversion H1.
Qed.

Lemma true_accepts_full :
  forall {Sigma : S.t},
    accepted_lang true_dfa = full_language Sigma.
Proof.
simplify.
apply Extensionality_Ensembles.
simplify.
unfold accepted_lang.
unfold accepted.
rewrite true_trans_does_nothing.
simplify.
Qed.

Definition and_states (M N : dfa) : S.t

Definition and_dfa (M N : dfa) : dfa :=
  Build_dfa (and_states M N).

Definition even_len_states := S.union (S.singleton 0) (S.singleton 1).

Lemma even_len_states_has_two : forall (n : nat), S.mem (S (S n)) even_len_states = true -> False.
Proof.
simplify.
Qed.

Lemma absurd : forall {A}, False -> A.
Proof.
intuition.
Qed.

Definition even_len_dfa_trans {Sigma : S.t}
  (q : member even_len_states) (x : member Sigma) : member even_len_states :=
  match q with
  | exist _ 0 _ => exist _ 1 eq_refl
  | exist _ 1 _ => exist _ 0 eq_refl
  | exist _ (S (S n)) prf => absurd (even_len_states_has_two n prf)
  end.

Definition even_len_dfa {Sigma : S.t} : dfa :=
  Build_dfa even_len_states Sigma
    even_len_dfa_trans (exist _ 0 eq_refl) (@singleton_subset even_len_states 0 eq_refl).

Lemma even_dfa_accepted_is_0 :
  forall {Sigma : S.t}, @A (@even_len_dfa Sigma) = @singleton_subset even_len_states 0 eq_refl.
Proof.
simplify.
Qed.

Fixpoint even_len {A} (str : list A) : bool :=
  match str with
  | [] => true
  | [_] => false
  | _ :: xs => negb (even_len xs)
  end.

Lemma neg_twice_true : forall (b : bool), negb (negb b) = true <-> b = true.
Proof.
simplify.
induction b.
reflexivity.
inversion H.
rewrite H.
simplify.
Qed.

Lemma even_len_add_is_odd :
  forall {A} (str : list A) (x : A),
    even_len (x :: str) = true <-> even_len str = false.
Proof.
simplify.
inversion H.
destruct str.
inversion H1.
apply negb_true_iff.
assumption.

unfold negb.
rewrite H.
destruct str.
inversion H.
reflexivity.
Qed.

Lemma even_len_dfa_alternates :
  forall {Sigma : S.t} (str : string Sigma) (a : member Sigma),
    tStar (@s even_len_dfa) str = exist _ 0 eq_refl <->
    tStar (@s even_len_dfa) (a :: str) = exist _ 1 eq_refl.
Proof.
simplify.
induction str.
simplify.
destruct str.
simplify.
inversion H.
unfold tStar in IHstr.
simpl in IHstr.

Lemma even_len_dfa_works :
  forall {Sigma : S.t} (str : string Sigma),
    @accepted even_len_dfa str = true -> even_len str = true.
Proof.
simplify.
induction str.
simplify.
unfold accepted in H.
pose proof @even_dfa_accepted_is_0 Sigma0.
rewrite H0 in H.
unfold singleton_subset in H.
destruct tStar.
rewrite S.mem_spec in H.
pose proof mem_singleton_eq x 0 H.


Require Import Coq.omega.Omega.
Require Import Bedrock.Examples.AutoSep.
Require Import Coq.Arith.Arith Coq.Lists.List.

Set Implicit Arguments.

Local Hint Extern 1 (himp _ (allocated _ _ _) (allocated _ _ _)) => apply allocated_shift_base.

Lemma wplus_lt_lift : forall n m o : nat,
  goodSize (n + m)
  -> goodSize o
  -> natToW n ^+ natToW m < natToW o
  -> (n + m < o)%nat.
  unfold wlt; intros.
  rewrite <- natToWord_plus in H1.
  unfold wplusN, wordBinN in *.
  repeat rewrite wordToN_nat in *.
  repeat rewrite wordToNat_natToW_goodSize in * by auto.
  nomega.
Qed.

Local Hint Extern 1 (_ <= _)%nat => match goal with
                                      | [ H : _ < _ |- _ ] =>
                                        apply wplus_lt_lift in H;
                                          [ omega | solve [ eauto ] | solve [ eauto ] ]
                                    end.

Lemma goodSize_plus2 : forall n,
  goodSize (n + 2)
  -> goodSize n.
  intros; eapply goodSize_plus_l; eauto.
Qed.

Lemma goodSize_diff : forall x y,
  goodSize (x + 2)
  -> goodSize (x - y - 2 + 2).
  intros; eapply goodSize_weaken; eauto.
Qed.

Local Hint Resolve goodSize_plus2 goodSize_diff.

(** * A free-list heap managed by the malloc library *)

Module Type FREE_LIST.
  Parameter freeable : W -> nat -> Prop.

  Axiom goodSize_freeable : forall p sz,
    freeable p sz
    -> goodSize sz.

  Axiom freeable_narrow : forall a sz sz',
    freeable a sz
    -> (sz' <= sz)%nat
    -> freeable a sz'.

  Axiom freeable_split : forall a b x y,
    freeable a (x + 2)
    -> natToW (y + 2) < natToW x
    -> goodSize (y + 2)
    -> b = a ^+ $4 ^* (natToW x ^- natToW y)
    -> freeable b (y + 2).

  Axiom it's_not_zero : forall x y a b,
    x = y ^+ $4 ^* ($ (a) ^- natToW b)
    -> freeable y (a + 2)
    -> natToW (b + 2) < natToW a
    -> goodSize (b + 2)
    -> x <> $0.

  Parameter freeList : nat (* number of elements in list *) -> W -> HProp.
  Parameter mallocHeap : HProp.

  Axiom freeList_extensional : forall n p, HProp_extensional (freeList n p).
  Axiom mallocHeap_extensional : HProp_extensional mallocHeap.

  Axiom mallocHeap_fwd : mallocHeap ===> Ex n, Ex p, 0 =*> p * freeList n p.
  Axiom mallocHeap_bwd : (Ex n, Ex p, 0 =*> p * freeList n p) ===> mallocHeap.

  Axiom nil_bwd : forall n p, p = 0 -> [| n = 0 |] ===> freeList n p.
  Axiom cons_bwd : forall n (p : W), p <> 0
    -> (Ex n', Ex sz, Ex p', [| n = S n' /\ freeable p (sz+2) |] * (p ==*> $ (sz), p')
      * (p ^+ $8) =?> sz * freeList n' p')
    ===> freeList n p.

  Axiom cons_fwd : forall n (p : W), p <> 0
    -> freeList n p
    ===> Ex n', Ex sz, Ex p', [| n = S n' /\ freeable p (sz+2) |] * (p ==*> $ (sz), p')
    * (p ^+ $8) =?> sz * freeList n' p'.
End FREE_LIST.

Module FreeList : FREE_LIST.
  Transparent goodSize.

  Definition noWrapAround (p : W) (sz : nat) :=
    forall n, (n < sz * 4)%nat -> p ^+ $ (n) <> $0.

  Definition freeable (p : W) (sz : nat) := goodSize sz /\ noWrapAround p sz.

  Lemma goodSize_narrow : forall sz sz' q,
    (N.of_nat sz < q)%N
    -> (sz' <= sz)%nat
    -> (N.of_nat sz' < q)%N.
    intros; nomega.
  Qed.

  Lemma freeable_narrow : forall a sz sz',
    freeable a sz
    -> (sz' <= sz)%nat
    -> freeable a sz'.
    unfold freeable; intuition eauto.
    eapply goodSize_narrow; eauto.

    do 2 intro.
    apply H2.
    omega.
  Qed.

  Lemma goodSize_freeable : forall p sz,
    freeable p sz
    -> goodSize sz.
    unfold freeable; tauto.
  Qed.

  Lemma it's_not_zero : forall x y a b,
    x = y ^+ $4 ^* ($ (a) ^- natToW b)
    -> freeable y (a + 2)
    -> natToW (b + 2) < natToW a
    -> goodSize (b + 2)
    -> x <> $0.
    intros.
    destruct H0.
    intro.
    apply (H3 (4 * (a - b))).
    auto.
    rewrite mult_comm.
    rewrite natToW_times4.
    rewrite natToW_minus.
    rewrite wmult_comm.
    subst; assumption.
    apply lt_goodSize' in H1; auto.
  Qed.

  Hint Extern 1 (_ < _)%N => apply goodSize_plus2.

  Lemma freeable_split : forall a b x y,
    freeable a (x + 2)
    -> natToW (y + 2) < natToW x
    -> goodSize (y + 2)
    -> b = a ^+ $4 ^* (natToW x ^- natToW y)
    -> freeable b (y + 2).
    intros; rewrite natToW_plus in *.
    destruct H; split; auto; subst.
    do 2 intro.
    specialize (H3 (4 * (x - y) + n)).
    intro.
    apply H3.
    auto.
    rewrite natToW_plus.
    rewrite mult_comm.
    rewrite natToW_times4.
    rewrite natToW_minus.
    rewrite wmult_comm.
    rewrite wplus_assoc.
    assumption.
    auto.
  Qed.

  Open Scope Sep_scope.

  Fixpoint freeList (n : nat) (p : W) : HProp :=
    match n with
      | O => [| p = 0 |]
      | S n' => [| p <> 0 |] * Ex sz, Ex p', [| freeable p (sz+2) |] * (p ==*> $ (sz), p')
        * (p ^+ $8) =?> sz * freeList n' p'
    end.

  Definition mallocHeap := Ex n, Ex p, 0 =*> p * freeList n p.

  Theorem freeList_extensional : forall n p, HProp_extensional (freeList n p).
    destruct n; reflexivity.
  Qed.

  Theorem mallocHeap_extensional : HProp_extensional mallocHeap.
    reflexivity.
  Qed.

  Theorem mallocHeap_fwd : mallocHeap ===> Ex n, Ex p, 0 =*> p * freeList n p.
    unfold mallocHeap; sepLemma.
  Qed.

  Theorem mallocHeap_bwd : (Ex n, Ex p, 0 =*> p * freeList n p) ===> mallocHeap.
    unfold mallocHeap; sepLemma.
  Qed.

  Theorem nil_bwd : forall n p, p = 0 -> [| n = 0 |] ===> freeList n p.
    destruct n; sepLemma.
  Qed.

  Theorem cons_bwd : forall n (p : W), p <> 0
    -> (Ex n', Ex sz, Ex p', [| n = S n' /\ freeable p (sz+2) |] * (p ==*> $ (sz), p')
      * (p ^+ $8) =?> sz * freeList n' p')
    ===> freeList n p.
    destruct n; sepLemma; match goal with
                            | [ H : S _ = S _ |- _ ] => injection H
                          end; sepLemma.
  Qed.

  Theorem cons_fwd : forall n (p : W), p <> 0
    -> freeList n p
    ===> Ex n', Ex sz, Ex p', [| n = S n' /\ freeable p (sz+2) |] * (p ==*> $ (sz), p')
    * (p ^+ $8) =?> sz * freeList n' p'.
    destruct n; sepLemma.
  Qed.
End FreeList.

Import FreeList.
Export FreeList.
Hint Immediate freeList_extensional mallocHeap_extensional.

Definition splitMe cur full (_ : nat) := (cur =?> full)%Sep.

Local Hint Resolve goodSize_freeable.

Lemma malloc_split : forall cur full init,
  (init <= full)%nat
  -> splitMe cur full init ===> cur =?> init
  * (cur ^+ $ (init * 4)) =?> (full - init).
  intros; eapply Himp_trans; [
    eapply allocated_split; eauto
    | sepLemma; apply allocated_shift_base; [
      rewrite mult_comm; simpl; unfold natToW; W_eq
      | reflexivity ] ].
Qed.

(*TIME Clear Timing Profile. *)

Definition hints : TacPackage.
(*TIME idtac "malloc:prepare". Time *)
  prepare (mallocHeap_fwd, cons_fwd, malloc_split) (mallocHeap_bwd, nil_bwd, cons_bwd).
(*TIME Time *)Defined.

Definition initS : spec := SPEC("size") reserving 0
  Al n,
  PRE[V] [| V("size") = $ (n) |] * [| freeable 4 (n+2) |] * 0 =?> (3 + n)
  POST[_] mallocHeap.

Definition freeS : spec := SPEC("p", "n") reserving 1
  Al n,
  PRE[V] [| V "n" = $ (n) |] * [| V "p" <> 0 |] * [| freeable (V "p") (n+2) |] * V "p" =?> (2 + n) * mallocHeap
  POST[_] mallocHeap.

Definition mallocS : spec := SPEC("n") reserving 4
  Al sz,
  PRE[V] [| V "n" = $ (sz) |] * [| goodSize (sz+2) |] * mallocHeap
  POST[R] [| R <> 0 |] * [| freeable R (sz+2) |] * R =?> (sz + 2) * mallocHeap.

Definition mallocM := bmodule "malloc" {{
  bfunction "init"("size") [initS]
    0 *<- 4;;
    4 *<- "size";;
    8 *<- 0;;
    Return 0
  end with bfunction "free"("p", "n", "tmp") [freeS]
    "p" *<- "n";;
    "tmp" <-* 0;;
    0 *<- "p";;
    "p" <- "p" + 4;;
    "p" *<- "tmp";;
    Return 0
  end with bfunction "malloc"("n", "cur", "prev", "tmp", "tmp2") [mallocS]
    "cur" <-* 0;;
    "prev" <- 0;;

    [Al sz, Al len,
      PRE[V] [| V "n" = $ (sz) |] * [| goodSize (sz+2) |] * V "prev" =*> V "cur" * freeList len (V "cur")
      POST[R] Ex p, Ex len', [| R <> 0 |] * [| freeable R (sz+2) |] * R =?> (sz + 2)
        * V "prev" =*> p * freeList len' p]
    While ("cur" <> 0) {
      "tmp" <-* "cur";;
      If ("tmp" = "n") {
        (* Exact size match on the current free list block *)
        "tmp" <- "cur" + 4;;
        "tmp" <-* "tmp";;
        "prev" *<- "tmp";;
        Return "cur"
      } else {
        "tmp" <- "n" + 2;;
        "tmp2" <-* "cur";;
        If ("tmp" < "tmp2") {
          (* This free list block is large enough to split in two. *)

          (* Calculate starting address of a suffix of this free block to return to caller. *)
          "tmp" <- "tmp2" - "n";;
          "tmp" <- 4 * "tmp";;
          "tmp" <- "cur" + "tmp";;

          (* Decrement size of free list block to reflect deleted suffix. *)
          "tmp2" <- "tmp2" - "n";;
          "tmp2" <- "tmp2" - 2;;
          "cur" *<- "tmp2";;

          (* Return suffix starting address. *)
          Return "tmp"
        } else {
          (* Current block too small; continue to next. *)
          "prev" <- "cur" + 4;;
          "cur" <-* "prev"
        }
      }
    };;

    Diverge (* out of memory! *)
  end
}}.

Lemma four_neq_zero : natToW 4 <> natToW 0.
  discriminate.
Qed.

Lemma cancel8 : forall x y z,
  (z + 2 <= y)%nat
  -> x ^+ $8 ^+ ($ (y) ^- $ (z + 2)) ^* $4 = x ^+ $4 ^* ($ (y) ^- natToW z).
  intros.
  autorewrite with sepFormula.
  rewrite natToW_plus.
  unfold natToW.
  W_eq.
Qed.

Local Hint Extern 1 False => eapply it's_not_zero; eassumption.
Local Hint Extern 1 (freeable _ _) => eapply freeable_narrow; [ eassumption | omega ].
Local Hint Extern 1 (freeable _ _) => eapply freeable_split; eassumption.

Local Hint Extern 1 (@eq (word _) _ _) => words.
Local Hint Extern 5 (@eq nat _ _) => omega.
Local Hint Extern 5 (_ <= _)%nat => omega.

Section mallocOk.
  Hint Rewrite natToW_times4 cancel8 natToW_minus using solve [ auto ] : sepFormula.

  Ltac main := generalize four_neq_zero; sep hints;
    try match goal with
          | [ H1 : _ = ?X, H2 : ?X = _ |- _ ] =>
            rewrite H2 in H1;
              apply natToW_inj in H1; [ | solve [ eauto ] | solve [ eauto ] ];
                subst
        end; congruence || eauto; try rewrite <- (plus_comm 2);
    simpl; cancel hints.

  Ltac split_case := post; evaluate hints;
    match goal with
      | [ H : sel _ _ = natToW _ |- _ ] => rewrite H in *
    end;
    match goal with
      | [ _ : natToW ?init ^+ natToW 2 < natToW ?full,
        H : context[((?base ^+ natToW 8) =?> ?full)%Sep],
        H' : freeable _ (?full + 2) |- _ ] =>
      change ((base ^+ natToW 8) =?> full)%Sep
      with (splitMe (base ^+ natToW 8) full (full - init - 2)) in H;
        assert (full - init - 2 <= full)%nat by omega
    end; sep hints;
    try match goal with
          | [ H : natToW (?a + ?b) < natToW ?c |- _ ] =>
            rewrite natToW_plus in H;
              apply wplus_lt_lift in H; [ | solve [ eauto ] | solve [ eauto ] ]
        end; sep hints; auto.

  Ltac combined :=
    match goal with
      | [ |- context[Times] ] =>
        match goal with
          | [ |- context[Logic.ex _] ] => split_case
        end
      | _ => main
    end.

  Theorem mallocMOk : moduleOk mallocM.
(*TIME idtac "malloc:verify". Time *)
    vcgen; abstract combined.
(*TIME Time *)Qed.

(*TIME Print Timing Profile. *)
End mallocOk.