(** * Tactics: More Basic Tactics *)

(** This chapter introduces several additional proof strategies
		and tactics that allow us to begin proving more interesting
		properties of functional programs.  We will see:

		- how to use auxiliary lemmas in both "forward-style" and
			"backward-style" proofs;
		- how to reason about data constructors (in particular, how to use
			the fact that they are injective and disjoint);
		- how to strengthen an induction hypothesis (and when such
			strengthening is required); and
		- more details on how to reason by case analysis. *)

Set Warnings "-notation-overridden,-parsing".
From LF Require Export Poly.

(* ################################################################# *)
(** * The [apply] Tactic *)

(** We often encounter situations where the goal to be proved is
		_exactly_ the same as some hypothesis in the context or some
		previously proved lemma. *)

Theorem silly1 : forall (n m o p : nat),
		 n = m  ->
		 [n;o] = [n;p] ->
		 [n;o] = [m;p].
Proof.
	intros n m o p eq1 eq2.
	rewrite <- eq1.

(** Here, we could finish with "[rewrite -> eq2.  reflexivity.]" as we
		have done several times before.  We can achieve the same effect in
		a single step by using the [apply] tactic instead: *)

	apply eq2.  Qed.

(** The [apply] tactic also works with _conditional_ hypotheses
		and lemmas: if the statement being applied is an implication, then
		the premises of this implication will be added to the list of
		subgoals needing to be proved. *)

Theorem silly2 : forall (n m o p : nat),
		 n = m  ->
		 (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
		 [n;o] = [m;p].
Proof.
	intros n m o p eq1 eq2.
	apply eq2. apply eq1.  Qed.

(** Typically, when we use [apply H], the statement [H] will
		begin with a [forall] that binds some _universal variables_.  When
		Coq matches the current goal against the conclusion of [H], it
		will try to find appropriate values for these variables.  For
		example, when we do [apply eq2] in the following proof, the
		universal variable [q] in [eq2] gets instantiated with [n] and [r]
		gets instantiated with [m]. *)

Theorem silly2a : forall (n m : nat),
		 (n,n) = (m,m)  ->
		 (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
		 [n] = [m].
Proof.
	intros n m eq1 eq2.
	apply eq2. apply eq1.  Qed.

(** **** Exercise: 2 stars, standard, optional (silly_ex)

		Complete the following proof without using [simpl]. *)

Theorem silly_ex :
	(forall n, evenb n = true -> oddb (S n) = true) ->
	oddb 3 = true ->
	evenb 4 = true.
Proof.
	intros _ eq2. apply eq2.
Qed.
(** [] *)

(** To use the [apply] tactic, the (conclusion of the) fact
		being applied must match the goal exactly -- for example, [apply]
		will not work if the left and right sides of the equality are
		swapped. *)

Theorem silly3_firsttry : forall (n : nat),
	true = (n =? 5)  ->
	(S (S n)) =? 7 = true.
Proof.
	intros n H.

(** Here we cannot use [apply] directly, but we can use the [symmetry]
		tactic, which switches the left and right sides of an equality in
		the goal. *)

	symmetry.
	simpl. (** (This [simpl] is optional, since [apply] will perform
						 simplification first, if needed.) *)
	apply H.  Qed.

(** **** Exercise: 3 stars, standard (apply_exercise1)

		(_Hint_: You can use [apply] with previously defined lemmas, not
		just hypotheses in the context.  Remember that [Search] is
		your friend.) *)

Theorem rev_exercise1 : forall (l l' : list nat),
	l = rev l' ->
	l' = rev l.
Proof.
	intros l l' H. symmetry. rewrite -> H. apply rev_involutive.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard, optional (apply_rewrite)

		Briefly explain the difference between the tactics [apply] and
		[rewrite].  What are the situations where both can usefully be
		applied? *)

(* FILL IN HERE

		[] *)

(* ################################################################# *)
(** * The [apply with] Tactic *)

(** The following silly example uses two rewrites in a row to
		get from [[a;b]] to [[e;f]]. *)

Example trans_eq_example : forall (a b c d e f : nat),
	[a;b] = [c;d] ->
	[c;d] = [e;f] ->
	[a;b] = [e;f].
Proof.
	intros a b c d e f eq1 eq2.
	rewrite -> eq1. rewrite -> eq2. reflexivity.  Qed.

(** Since this is a common pattern, we might like to pull it out
		as a lemma recording, once and for all, the fact that equality is
		transitive. *)

Theorem trans_eq : forall (X:Type) (n m o : X),
	n = m -> m = o -> n = o.
Proof.
	intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
	reflexivity.  Qed.

(** Now, we should be able to use [trans_eq] to prove the above
		example.  However, to do this we need a slight refinement of the
		[apply] tactic. *)

Example trans_eq_example' : forall (a b c d e f : nat),
	[a;b] = [c;d] ->
	[c;d] = [e;f] ->
	[a;b] = [e;f].
Proof.
	intros a b c d e f eq1 eq2.

(** If we simply tell Coq [apply trans_eq] at this point, it can
		tell (by matching the goal against the conclusion of the lemma)
		that it should instantiate [X] with [[nat]], [n] with [[a,b]], and
		[o] with [[e,f]].  However, the matching process doesn't determine
		an instantiation for [m]: we have to supply one explicitly by
		adding [with (m:=[c,d])] to the invocation of [apply]. *)

	apply trans_eq with (m:=[c;d]).
	apply eq1. apply eq2.   Qed.

(** Actually, we usually don't have to include the name [m] in
		the [with] clause; Coq is often smart enough to figure out which
		instantiation we're giving. We could instead write: [apply
		trans_eq with [c;d]]. *)

(** **** Exercise: 3 stars, standard, optional (apply_with_exercise)  *)
Example trans_eq_exercise : forall (n m o p : nat),
	m = (minustwo o) ->
	(n + p) = m ->
	(n + p) = (minustwo o).
Proof.
	intros n m o p h1 h2. apply trans_eq with (m).
	apply h2. apply h1.
Qed.
(** [] *)

(* ################################################################# *)
(** * The [injection] and [discriminate] Tactics *)

(** Recall the definition of natural numbers:

		 Inductive nat : Type :=
			 | O : nat
			 | S : nat -> nat.

		It is obvious from this definition that every number has one of
		two forms: either it is the constructor [O] or it is built by
		applying the constructor [S] to another number.  But there is more
		here than meets the eye: implicit in the definition (and in our
		informal understanding of how datatype declarations work in other
		programming languages) are two more facts:

		- The constructor [S] is _injective_.  That is, if [S n = S m], it
			must be the case that [n = m].

		- The constructors [O] and [S] are _disjoint_.  That is, [O] is not
			equal to [S n] for any [n].

		Similar principles apply to all inductively defined types: all
		constructors are injective, and the values built from distinct
		constructors are never equal.  For lists, the [cons] constructor
		is injective and [nil] is different from every non-empty list.
		For booleans, [true] and [false] are different.  (Since neither
		[true] nor [false] take any arguments, their injectivity is not
		interesting.)  And so on. *)

(** For example, we can prove the injectivity of [S] by using the
		[pred] function defined in [Basics.v]. *)

Theorem S_injective : forall (n m : nat),
	S n = S m ->
	n = m.
Proof.
	intros n m H1.
	assert (H2: n = pred (S n)). { reflexivity. }
	rewrite H2. rewrite H1. reflexivity.
Qed.

(** This technique can be generalized to any constructor by
		writing the equivalent of [pred] for that constructor -- i.e.,
		writing a function that "undoes" one application of the
		constructor. As a more convenient alternative, Coq provides a
		tactic called [injection] that allows us to exploit the
		injectivity of any constructor.  Here is an alternate proof of the
		above theorem using [injection]: *)

Theorem S_injective' : forall (n m : nat),
	S n = S m ->
	n = m.
Proof.
	intros n m H.

(** By writing [injection H] at this point, we are asking Coq to
		generate all equations that it can infer from [H] using the
		injectivity of constructors. Each such equation is added as a
		premise to the goal. In the present example, adds the premise
		[n = m]. *)

	injection H. intros Hnm. apply Hnm.
Qed.

(** Here's a more interesting example that shows how [injection] can
		derive multiple equations at once. *)

Theorem injection_ex1 : forall (n m o : nat),
	[n; m] = [o; o] ->
	[n] = [m].
Proof.
	intros n m o H.
	injection H. intros H1 H2.
	rewrite H1. rewrite H2. reflexivity.
Qed.

(** The "[as]" variant of [injection] permits us to choose names for
		the introduced equations rather than letting Coq do it. *)

Theorem injection_ex2 : forall (n m : nat),
	[n] = [m] ->
	n = m.
Proof.
	intros n m H.
	injection H as Hnm. rewrite Hnm.
	reflexivity. Qed.

(** **** Exercise: 1 star, standard (injection_ex3)  *)
Example injection_ex3 : forall (X : Type) (x y z : X) (l j : list X),
	x :: y :: l = z :: j ->
	y :: l = x :: j ->
	x = y.
Proof.
	intros X x y z l j h1 h2. injection h1 as xz ylj. injection h2 as yx lj.
	symmetry. apply yx.
Qed.
(** [] *)

(** So much for injectivity of constructors.  What about disjointness?

		The principle of disjointness says that two terms beginning with
		different constructors (like [O] and [S], or [true] and [false])
		can never be equal.  This means that, any time we find ourselves
		working in a context where we've _assumed_ that two such terms are
		equal, we are justified in concluding anything we want to (because
		the assumption is nonsensical).

		The [discriminate] tactic embodies this principle: It is used on a
		hypothesis involving an equality between different
		constructors (e.g., [S n = O]), and it solves the current goal
		immediately.  For example: *)

Theorem eqb_0_l : forall n,
	 0 =? n = true -> n = 0.
Proof.
	intros n.

(** We can proceed by case analysis on [n]. The first case is
		trivial. *)

	destruct n as [| n'] eqn:E.
	- (* n = 0 *)
		intros H. reflexivity.

(** However, the second one doesn't look so simple: assuming [0
		=? (S n') = true], we must show [S n' = 0]!  The way forward is to
		observe that the assumption itself is nonsensical: *)

	- (* n = S n' *)
		simpl.

(** If we use [discriminate] on this hypothesis, Coq confirms
		that the subgoal we are working on is impossible and removes it
		from further consideration. *)

		intros H. discriminate H.
Qed.

(** This is an instance of a logical principle known as the _principle
		of explosion_, which asserts that a contradictory hypothesis
		entails anything, even false things! *)

Theorem discriminate_ex1 : forall (n : nat),
	S n = O ->
	2 + 2 = 5.
Proof.
	intros n contra. discriminate contra. Qed.

Theorem discriminate_ex2 : forall (n m : nat),
	false = true ->
	[n] = [m].
Proof.
	intros n m contra. discriminate contra. Qed.

(** If you find the principle of explosion confusing, remember
		that these proofs are _not_ showing that the conclusion of the
		statement holds.  Rather, they are showing that, if the
		nonsensical situation described by the premise did somehow arise,
		then the nonsensical conclusion would follow.  We'll explore the
		principle of explosion of more detail in the next chapter. *)

(** **** Exercise: 1 star, standard (discriminate_ex3)  *)
Example discriminate_ex3 :
	forall (X : Type) (x y z : X) (l j : list X),
		x :: y :: l = [] ->
		x = z.
Proof.
	intros X x y z l j contra. discriminate contra.
Qed.
(** [] *)

(** The injectivity of constructors allows us to reason that
		[forall (n m : nat), S n = S m -> n = m].  The converse of this
		implication is an instance of a more general fact about both
		constructors and functions, which we will find convenient in a few
		places below: *)

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
	x = y -> f x = f y.
Proof. intros A B f x y eq. rewrite eq.  reflexivity.  Qed.

(* ################################################################# *)
(** * Using Tactics on Hypotheses *)

(** By default, most tactics work on the goal formula and leave
		the context unchanged.  However, most tactics also have a variant
		that performs a similar operation on a statement in the context.

		For example, the tactic [simpl in H] performs simplification in
		the hypothesis named [H] in the context. *)

Theorem S_inj : forall (n m : nat) (b : bool),
	(S n) =? (S m) = b  ->
	n =? m = b.
Proof.
	intros n m b H. simpl in H. apply H.  Qed.

(** Similarly, [apply L in H] matches some conditional statement
		[L] (of the form [X -> Y], say) against a hypothesis [H] in the
		context.  However, unlike ordinary [apply] (which rewrites a goal
		matching [Y] into a subgoal [X]), [apply L in H] matches [H]
		against [X] and, if successful, replaces it with [Y].

		In other words, [apply L in H] gives us a form of "forward
		reasoning": from [X -> Y] and a hypothesis matching [X], it
		produces a hypothesis matching [X].  By contrast, [apply L] is
		"backward reasoning": it says that if we know [X -> Y] and we
		are trying to prove [Y], it suffices to prove [X].

		Here is a variant of a proof from above, using forward reasoning
		throughout instead of backward reasoning. *)

Theorem silly3' : forall (n : nat),
	(n =? 5 = true -> (S (S n)) =? 7 = true) ->
	true = (n =? 5)  ->
	true = ((S (S n)) =? 7).
Proof.
	intros n eq H.
	symmetry in H. apply eq in H. symmetry in H.
	apply H.  Qed.

(** Forward reasoning starts from what is _given_ (premises,
		previously proven theorems) and iteratively draws conclusions from
		them until the goal is reached.  Backward reasoning starts from
		the _goal_, and iteratively reasons about what would imply the
		goal, until premises or previously proven theorems are reached.

		If you've seen informal proofs before (for example, in a math or
		computer science class), they probably used forward reasoning.  In
		general, idiomatic use of Coq tends to favor backward reasoning,
		but in some situations the forward style can be easier to think
		about.  *)

(** **** Exercise: 3 stars, standard, recommended (plus_n_n_injective)

		Practice using "in" variants in this proof.  (Hint: use
		[plus_n_Sm].) *)

Theorem equal_remove_S : forall n m,
	n = m -> S n = S m.
	intros n m eq.
	rewrite eq.
	reflexivity.
Qed.

Theorem plus_n_n_injective : forall n m,
	n + n = m + m ->
	n = m.
Proof.
	intros n. induction n as [| n'].
	- destruct m.
		+ reflexivity.
		+ intros contra. discriminate contra.
	- destruct m.
		+ intros H. inversion H.
		+ intro H. apply equal_remove_S.
			apply IHn'.
			simpl in H.
			inversion H.
			rewrite <- plus_n_Sm in H1.
			rewrite <- plus_n_Sm in H1.
			inversion H1.
			reflexivity.
Qed.
(** [] *)

(* ################################################################# *)
(** * Varying the Induction Hypothesis *)

(** Sometimes it is important to control the exact form of the
		induction hypothesis when carrying out inductive proofs in Coq.
		In particular, we need to be careful about which of the
		assumptions we move (using [intros]) from the goal to the context
		before invoking the [induction] tactic.  For example, suppose
		we want to show that [double] is injective -- i.e., that it maps
		different arguments to different results:

			 Theorem double_injective: forall n m,
				 double n = double m -> n = m.

		The way we _start_ this proof is a bit delicate: if we begin with

			 intros n. induction n.

		all is well.  But if we begin it with

			 intros n m. induction n.

		we get stuck in the middle of the inductive case... *)

Theorem double_injective_FAILED : forall n m,
		 double n = double m ->
		 n = m.
Proof.
	intros n m. induction n as [| n'].
	- (* n = O *) simpl. intros eq. destruct m as [| m'] eqn:E.
		+ (* m = O *) reflexivity.
		+ (* m = S m' *) discriminate eq.
	- (* n = S n' *) intros eq. destruct m as [| m'] eqn:E.
		+ (* m = O *) discriminate eq.
		+ (* m = S m' *) apply f_equal.

(** At this point, the induction hypothesis, [IHn'], does _not_ give us
		[n' = m'] -- there is an extra [S] in the way -- so the goal is
		not provable. *)

			Abort.

(** What went wrong? *)

(** The problem is that, at the point we invoke the induction
		hypothesis, we have already introduced [m] into the context --
		intuitively, we have told Coq, "Let's consider some particular [n]
		and [m]..." and we now have to prove that, if [double n = double
		m] for _these particular_ [n] and [m], then [n = m].

		The next tactic, [induction n] says to Coq: We are going to show
		the goal by induction on [n].  That is, we are going to prove, for
		_all_ [n], that the proposition

			- [P n] = "if [double n = double m], then [n = m]"

		holds, by showing

			- [P O]

				 (i.e., "if [double O = double m] then [O = m]") and

			- [P n -> P (S n)]

				(i.e., "if [double n = double m] then [n = m]" implies "if
				[double (S n) = double m] then [S n = m]").

		If we look closely at the second statement, it is saying something
		rather strange: it says that, for a _particular_ [m], if we know

			- "if [double n = double m] then [n = m]"

		then we can prove

			 - "if [double (S n) = double m] then [S n = m]".

		To see why this is strange, let's think of a particular [m] --
		say, [5].  The statement is then saying that, if we know

			- [Q] = "if [double n = 10] then [n = 5]"

		then we can prove

			- [R] = "if [double (S n) = 10] then [S n = 5]".

		But knowing [Q] doesn't give us any help at all with proving
		[R]!  (If we tried to prove [R] from [Q], we would start with
		something like "Suppose [double (S n) = 10]..." but then we'd be
		stuck: knowing that [double (S n)] is [10] tells us nothing about
		whether [double n] is [10], so [Q] is useless.) *)

(** Trying to carry out this proof by induction on [n] when [m] is
		already in the context doesn't work because we are then trying to
		prove a statement involving _every_ [n] but just a _single_ [m]. *)

(** The successful proof of [double_injective] leaves [m] in the goal
		statement at the point where the [induction] tactic is invoked on
		[n]: *)

Theorem double_injective : forall n m,
		 double n = double m ->
		 n = m.
Proof.
	intros n. induction n as [| n'].
	- (* n = O *) simpl. intros m eq. destruct m as [| m'] eqn:E.
		+ (* m = O *) reflexivity.
		+ (* m = S m' *) discriminate eq.

	- (* n = S n' *) simpl.

(** Notice that both the goal and the induction hypothesis are
		different this time: the goal asks us to prove something more
		general (i.e., to prove the statement for _every_ [m]), but the IH
		is correspondingly more flexible, allowing us to choose any [m] we
		like when we apply the IH. *)

		intros m eq.

(** Now we've chosen a particular [m] and introduced the assumption
		that [double n = double m].  Since we are doing a case analysis on
		[n], we also need a case analysis on [m] to keep the two "in sync." *)

		destruct m as [| m'] eqn:E.
		+ (* m = O *) simpl.

(** The 0 case is trivial: *)

			discriminate eq.

		+ (* m = S m' *)
			apply f_equal.

(** At this point, since we are in the second branch of the [destruct
		m], the [m'] mentioned in the context is the predecessor of the
		[m] we started out talking about.  Since we are also in the [S]
		branch of the induction, this is perfect: if we instantiate the
		generic [m] in the IH with the current [m'] (this instantiation is
		performed automatically by the [apply] in the next step), then
		[IHn'] gives us exactly what we need to finish the proof. *)

			apply IHn'. injection eq as goal. apply goal. Qed.

(** What you should take away from all this is that we need to be
		careful, when using induction, that we are not trying to prove
		something too specific: To prove a property of [n] and [m] by
		induction on [n], it is sometimes important to leave [m]
		generic. *)

(** The following exercise requires the same pattern. *)

(** **** Exercise: 2 stars, standard (eqb_true)  *)
Theorem eqb_true : forall n m,
		n =? m = true -> n = m.
Proof.
	intros n. induction n as [| n' IHn].
	- destruct m.
		+ reflexivity.
		+ discriminate.
	- intros m eq. destruct m as [| m'].
		+ discriminate.
		+ apply f_equal. apply IHn. apply eq.
Qed.
(** [] *)

(** **** Exercise: 2 stars, advanced (eqb_true_informal)

		Give a careful informal proof of [eqb_true], being as explicit
		as possible about quantifiers. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_informal_proof : option (nat*string) := None.
(** [] *)

(** The strategy of doing fewer [intros] before an [induction] to
		obtain a more general IH doesn't always work by itself; sometimes
		some _rearrangement_ of quantified variables is needed.  Suppose,
		for example, that we wanted to prove [double_injective] by
		induction on [m] instead of [n]. *)

Theorem double_injective_take2_FAILED : forall n m,
		 double n = double m ->
		 n = m.
Proof.
	intros n m. induction m as [| m'].
	- (* m = O *) simpl. intros eq. destruct n as [| n'] eqn:E.
		+ (* n = O *) reflexivity.
		+ (* n = S n' *) discriminate eq.
	- (* m = S m' *) intros eq. destruct n as [| n'] eqn:E.
		+ (* n = O *) discriminate eq.
		+ (* n = S n' *) apply f_equal.
				(* Stuck again here, just like before. *)
Abort.

(** The problem is that, to do induction on [m], we must first
		introduce [n].  (If we simply say [induction m] without
		introducing anything first, Coq will automatically introduce [n]
		for us!)  *)

(** What can we do about this?  One possibility is to rewrite the
		statement of the lemma so that [m] is quantified before [n].  This
		works, but it's not nice: We don't want to have to twist the
		statements of lemmas to fit the needs of a particular strategy for
		proving them!  Rather we want to state them in the clearest and
		most natural way. *)

(** What we can do instead is to first introduce all the quantified
		variables and then _re-generalize_ one or more of them,
		selectively taking variables out of the context and putting them
		back at the beginning of the goal.  The [generalize dependent]
		tactic does this. *)

Theorem double_injective_take2 : forall n m,
		 double n = double m ->
		 n = m.
Proof.
	intros n m.
	(* [n] and [m] are both in the context *)
	generalize dependent n.
	(* Now [n] is back in the goal and we can do induction on
		 [m] and get a sufficiently general IH. *)
	induction m as [| m'].
	- (* m = O *) simpl. intros n eq. destruct n as [| n'] eqn:E.
		+ (* n = O *) reflexivity.
		+ (* n = S n' *) discriminate eq.
	- (* m = S m' *) intros n eq. destruct n as [| n'] eqn:E.
		+ (* n = O *) discriminate eq.
		+ (* n = S n' *) apply f_equal.
			apply IHm'. injection eq as goal. apply goal. Qed.

(** Let's look at an informal proof of this theorem.  Note that
		the proposition we prove by induction leaves [n] quantified,
		corresponding to the use of generalize dependent in our formal
		proof.

		_Theorem_: For any nats [n] and [m], if [double n = double m], then
			[n = m].

		_Proof_: Let [m] be a [nat]. We prove by induction on [m] that, for
			any [n], if [double n = double m] then [n = m].

			- First, suppose [m = 0], and suppose [n] is a number such
				that [double n = double m].  We must show that [n = 0].

				Since [m = 0], by the definition of [double] we have [double n =
				0].  There are two cases to consider for [n].  If [n = 0] we are
				done, since [m = 0 = n], as required.  Otherwise, if [n = S n']
				for some [n'], we derive a contradiction: by the definition of
				[double], we can calculate [double n = S (S (double n'))], but
				this contradicts the assumption that [double n = 0].

			- Second, suppose [m = S m'] and that [n] is again a number such
				that [double n = double m].  We must show that [n = S m'], with
				the induction hypothesis that for every number [s], if [double s =
				double m'] then [s = m'].

				By the fact that [m = S m'] and the definition of [double], we
				have [double n = S (S (double m'))].  There are two cases to
				consider for [n].

				If [n = 0], then by definition [double n = 0], a contradiction.

				Thus, we may assume that [n = S n'] for some [n'], and again by
				the definition of [double] we have [S (S (double n')) =
				S (S (double m'))], which implies by injectivity that [double n' =
				double m'].  Instantiating the induction hypothesis with [n'] thus
				allows us to conclude that [n' = m'], and it follows immediately
				that [S n' = S m'].  Since [S n' = n] and [S m' = m], this is just
				what we wanted to show. [] *)

(** Before we close this section and move on to some exercises,
		let's digress briefly and use [eqb_true] to prove a similar
		property of identifiers that we'll need in later chapters: *)

Theorem eqb_id_true : forall x y,
	eqb_id x y = true -> x = y.
Proof.
	intros [m] [n]. simpl. intros H.
	assert (H' : m = n). { apply eqb_true. apply H. }
	rewrite H'. reflexivity.
Qed.

(** **** Exercise: 3 stars, standard, recommended (gen_dep_practice)

		Prove this by induction on [l]. *)

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
		 length l = n ->
		 nth_error l n = None.
Proof.
	intros n X l. generalize dependent n.
	induction l as [| x l' IHl].
	- reflexivity.
	- intros n H. destruct n as [|n'].
		+ simpl. discriminate.
		+ simpl. apply IHl. simpl in H. apply S_injective in H. apply H.
Qed.
(** [] *)

(* ################################################################# *)
(** * Unfolding Definitions *)

(** It sometimes happens that we need to manually unfold a name that
		has been introduced by a [Definition] so that we can manipulate
		its right-hand side.  For example, if we define... *)

Definition square n := n * n.

(** ... and try to prove a simple fact about [square]... *)

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
	intros n m.
	simpl.

(** ... we appear to be stuck: [simpl] doesn't simplify anything at
		this point, and since we haven't proved any other facts about
		[square], there is nothing we can [apply] or [rewrite] with.

		To make progress, we can manually [unfold] the definition of
		[square]: *)

	unfold square.

(** Now we have plenty to work with: both sides of the equality are
		expressions involving multiplication, and we have lots of facts
		about multiplication at our disposal.  In particular, we know that
		it is commutative and associative, and from these it is not hard
		to finish the proof. *)

	rewrite mult_assoc.
	assert (H : n * m * n = n * n * m).
		{ rewrite mult_comm. apply mult_assoc. }
	rewrite H. rewrite mult_assoc. reflexivity.
Qed.

(** At this point, some discussion of unfolding and simplification is
		in order.

		You may already have observed that tactics like [simpl],
		[reflexivity], and [apply] will often unfold the definitions of
		functions automatically when this allows them to make progress.
		For example, if we define [foo m] to be the constant [5]... *)

Definition foo (x: nat) := 5.

(** .... then the [simpl] in the following proof (or the
		[reflexivity], if we omit the [simpl]) will unfold [foo m] to
		[(fun x => 5) m] and then further simplify this expression to just
		[5]. *)

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Proof.
	intros m.
	simpl.
	reflexivity.
Qed.

(** However, this automatic unfolding is somewhat conservative.  For
		example, if we define a slightly more complicated function
		involving a pattern match... *)

Definition bar x :=
	match x with
	| O => 5
	| S _ => 5
	end.

(** ...then the analogous proof will get stuck: *)

Fact silly_fact_2_FAILED : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
	intros m.
	simpl. (* Does nothing! *)
Abort.

(** The reason that [simpl] doesn't make progress here is that it
		notices that, after tentatively unfolding [bar m], it is left with
		a match whose scrutinee, [m], is a variable, so the [match] cannot
		be simplified further.  It is not smart enough to notice that the
		two branches of the [match] are identical, so it gives up on
		unfolding [bar m] and leaves it alone.  Similarly, tentatively
		unfolding [bar (m+1)] leaves a [match] whose scrutinee is a
		function application (that cannot itself be simplified, even
		after unfolding the definition of [+]), so [simpl] leaves it
		alone. *)

(** At this point, there are two ways to make progress.  One is to use
		[destruct m] to break the proof into two cases, each focusing on a
		more concrete choice of [m] ([O] vs [S _]).  In each case, the
		[match] inside of [bar] can now make progress, and the proof is
		easy to complete. *)

Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
	intros m.
	destruct m eqn:E.
	- simpl. reflexivity.
	- simpl. reflexivity.
Qed.

(** This approach works, but it depends on our recognizing that the
		[match] hidden inside [bar] is what was preventing us from making
		progress. *)

(** A more straightforward way to make progress is to explicitly tell
		Coq to unfold [bar]. *)

Fact silly_fact_2' : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
	intros m.
	unfold bar.

(** Now it is apparent that we are stuck on the [match] expressions on
		both sides of the [=], and we can use [destruct] to finish the
		proof without thinking too hard. *)

	destruct m eqn:E.
	- reflexivity.
	- reflexivity.
Qed.

(* ################################################################# *)
(** * Using [destruct] on Compound Expressions *)

(** We have seen many examples where [destruct] is used to
		perform case analysis of the value of some variable.  But
		sometimes we need to reason by cases on the result of some
		_expression_.  We can also do this with [destruct].

		Here are some examples: *)

Definition sillyfun (n : nat) : bool :=
	if n =? 3 then false
	else if n =? 5 then false
	else false.

Theorem sillyfun_false : forall (n : nat),
	sillyfun n = false.
Proof.
	intros n. unfold sillyfun.
	destruct (n =? 3) eqn:E1.
		- (* n =? 3 = true *) reflexivity.
		- (* n =? 3 = false *) destruct (n =? 5) eqn:E2.
			+ (* n =? 5 = true *) reflexivity.
			+ (* n =? 5 = false *) reflexivity.  Qed.

(** After unfolding [sillyfun] in the above proof, we find that
		we are stuck on [if (n =? 3) then ... else ...].  But either
		[n] is equal to [3] or it isn't, so we can use [destruct (eqb
		n 3)] to let us reason about the two cases.

		In general, the [destruct] tactic can be used to perform case
		analysis of the results of arbitrary computations.  If [e] is an
		expression whose type is some inductively defined type [T], then,
		for each constructor [c] of [T], [destruct e] generates a subgoal
		in which all occurrences of [e] (in the goal and in the context)
		are replaced by [c]. *)

(** **** Exercise: 3 stars, standard, optional (combine_split)

		Here is an implementation of the [split] function mentioned in
		chapter [Poly]: *)

Fixpoint split
	{X Y : Type} (l : list (X*Y))
: (list X) * (list Y) :=
	match l with
	| [] => ([], [])
	| (x, y) :: t =>
			match split t with
			| (lx, ly) => (x :: lx, y :: ly)
			end
	end.

(** Prove that [split] and [combine] are inverses in the following
		sense: *)

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
	split l = (l1, l2) ->
	combine l1 l2 = l.
Proof.
	intros X Y l. induction l as [| p l'].
	- intros l1 l2 H. inversion H. reflexivity.
	- intros l1 l2 H. inversion H. destruct p as [x y]; destruct (split l') as [xs' ys'];
		inversion H1. simpl. rewrite IHl'. reflexivity. reflexivity.
Qed.
(** [] *)

(** The [eqn:] part of the [destruct] tactic is optional: We've chosen
		to include it most of the time, just for the sake of
		documentation, but many Coq proofs omit it.

		When [destruct]ing compound expressions, however, the information
		recorded by the [eqn:] can actually be critical: if we leave it
		out, then [destruct] can sometimes erase information we need to
		complete a proof.

		For example, suppose we define a function [sillyfun1] like
		this: *)

Definition sillyfun1 (n : nat) : bool :=
	if n =? 3 then true
	else if n =? 5 then true
	else false.

(** Now suppose that we want to convince Coq of the (rather
		obvious) fact that [sillyfun1 n] yields [true] only when [n] is
		odd.  If we start the proof like this (with no [eqn:] on the
		destruct)... *)

Theorem sillyfun1_odd_FAILED : forall (n : nat),
		 sillyfun1 n = true ->
		 oddb n = true.
Proof.
	intros n eq. unfold sillyfun1 in eq.
	destruct (n =? 3).
	(* stuck... *)
Abort.

(** ... then we are stuck at this point because the context does
		not contain enough information to prove the goal!  The problem is
		that the substitution performed by [destruct] is quite brutal --
		in this case, it thows away every occurrence of [n =? 3], but we
		need to keep some memory of this expression and how it was
		destructed, because we need to be able to reason that, since [n =?
		3 = true] in this branch of the case analysis, it must be that [n
		= 3], from which it follows that [n] is odd.

		What we want here is to substitute away all existing occurences of
		[n =? 3], but at the same time add an equation to the context that
		records which case we are in.  This is precisely what the [eqn:]
		qualifier does. *)

Theorem sillyfun1_odd : forall (n : nat),
		 sillyfun1 n = true ->
		 oddb n = true.
Proof.
	intros n eq. unfold sillyfun1 in eq.
	destruct (n =? 3) eqn:Heqe3.
	(* Now we have the same state as at the point where we got
		 stuck above, except that the context contains an extra
		 equality assumption, which is exactly what we need to
		 make progress. *)
		- (* e3 = true *) apply eqb_true in Heqe3.
			rewrite -> Heqe3. reflexivity.
		- (* e3 = false *)
		 (* When we come to the second equality test in the body
				of the function we are reasoning about, we can use
				[eqn:] again in the same way, allowing us to finish the
				proof. *)
			destruct (n =? 5) eqn:Heqe5.
				+ (* e5 = true *)
					apply eqb_true in Heqe5.
					rewrite -> Heqe5. reflexivity.
				+ (* e5 = false *) discriminate eq.  Qed.

(** **** Exercise: 2 stars, standard (destruct_eqn_practice)  *)
Theorem bool_fn_applied_thrice :
	forall (f : bool -> bool) (b : bool),
	f (f (f b)) = f b.
Proof.
	intros f b. destruct (f b) eqn:Hyp_bool.
	- destruct b .
		+ rewrite Hyp_bool. apply Hyp_bool.
		+ destruct (f true) eqn:Hyp_true.
			{ rewrite Hyp_true. reflexivity. }
			{ apply Hyp_bool. }
	- destruct b .
		+ destruct (f false) eqn:Hyp_false.
			{ apply Hyp_bool. }
			{ apply Hyp_false. }
		+ rewrite Hyp_bool. apply Hyp_bool.
Qed.
(** [] *)

(* ################################################################# *)
(** * Review *)

(** We've now seen many of Coq's most fundamental tactics.  We'll
		introduce a few more in the coming chapters, and later on we'll
		see some more powerful _automation_ tactics that make Coq help us
		with low-level details.  But basically we've got what we need to
		get work done.

		Here are the ones we've seen:

			- [intros]: move hypotheses/variables from goal to context

			- [reflexivity]: finish the proof (when the goal looks like [e =
				e])

			- [apply]: prove goal using a hypothesis, lemma, or constructor

			- [apply... in H]: apply a hypothesis, lemma, or constructor to
				a hypothesis in the context (forward reasoning)

			- [apply... with...]: explicitly specify values for variables
				that cannot be determined by pattern matching

			- [simpl]: simplify computations in the goal

			- [simpl in H]: ... or a hypothesis

			- [rewrite]: use an equality hypothesis (or lemma) to rewrite
				the goal

			- [rewrite ... in H]: ... or a hypothesis

			- [symmetry]: changes a goal of the form [t=u] into [u=t]

			- [symmetry in H]: changes a hypothesis of the form [t=u] into
				[u=t]

			- [unfold]: replace a defined constant by its right-hand side in
				the goal

			- [unfold... in H]: ... or a hypothesis

			- [destruct... as...]: case analysis on values of inductively
				defined types

			- [destruct... eqn:...]: specify the name of an equation to be
				added to the context, recording the result of the case
				analysis

			- [induction... as...]: induction on values of inductively
				defined types

			- [injection]: reason by injectivity on equalities
				between values of inductively defined types

			- [discriminate]: reason by disjointness of constructors on
				equalities between values of inductively defined types

			- [assert (H: e)] (or [assert (e) as H]): introduce a "local
				lemma" [e] and call it [H]

			- [generalize dependent x]: move the variable [x] (and anything
				else that depends on it) from the context back to an explicit
				hypothesis in the goal formula *)

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

(** **** Exercise: 3 stars, standard (eqb_sym)  *)
Theorem eqb_sym : forall (n m : nat),
	(n =? m) = (m =? n).
Proof.
	(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (eqb_sym_informal)

		Give an informal proof of this lemma that corresponds to your
		formal proof above:

	 Theorem: For any [nat]s [n] [m], [(n =? m) = (m =? n)].

	 Proof: *)
	 (* FILL IN HERE

		[] *)

(** **** Exercise: 3 stars, standard, optional (eqb_trans)  *)
Theorem eqb_trans : forall n m p,
	n =? m = true ->
	m =? p = true ->
	n =? p = true.
Proof.
	(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (split_combine)

		We proved, in an exercise above, that for all lists of pairs,
		[combine] is the inverse of [split].  How would you formalize the
		statement that [split] is the inverse of [combine]?  When is this
		property true?

		Complete the definition of [split_combine_statement] below with a
		property that states that [split] is the inverse of
		[combine]. Then, prove that the property holds. (Be sure to leave
		your induction hypothesis general by not doing [intros] on more
		things than necessary.  Hint: what property do you need of [l1]
		and [l2] for [split (combine l1 l2) = (l1,l2)] to be true?) *)

Definition split_combine_statement : Prop
	(* ("[: Prop]" means that we are giving a name to a
		 logical proposition here.) *)
	(* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Theorem split_combine : split_combine_statement.
Proof.
(* FILL IN HERE *) Admitted.

(* Do not modify the following line: *)
Definition manual_grade_for_split_combine : option (nat*string) := None.
(** [] *)

(** **** Exercise: 3 stars, advanced (filter_exercise)

		This one is a bit challenging.  Pay attention to the form of your
		induction hypothesis. *)

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
														 (x : X) (l lf : list X),
		 filter test l = x :: lf ->
		 test x = true.
Proof.
	(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced, recommended (forall_exists_challenge)

		Define two recursive [Fixpoints], [forallb] and [existsb].  The
		first checks whether every element in a list satisfies a given
		predicate:

			forallb oddb [1;3;5;7;9] = true

			forallb negb [false;false] = true

			forallb evenb [0;2;4;5] = false

			forallb (eqb 5) [] = true

		The second checks whether there exists an element in the list that
		satisfies a given predicate:

			existsb (eqb 5) [0;2;3;6] = false

			existsb (andb true) [true;true;false] = true

			existsb oddb [1;0;0;0;0;3] = true

			existsb evenb [] = false

		Next, define a _nonrecursive_ version of [existsb] -- call it
		[existsb'] -- using [forallb] and [negb].

		Finally, prove a theorem [existsb_existsb'] stating that
		[existsb'] and [existsb] have the same behavior. *)

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool
	(* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_forallb_1 : forallb oddb [1;3;5;7;9] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_forallb_2 : forallb negb [false;false] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_forallb_3 : forallb evenb [0;2;4;5] = false.
Proof. (* FILL IN HERE *) Admitted.

(*Example test_forallb_4 : forallb (eqb 5) [] = true.
Proof. (* FILL IN HERE *) Admitted.*)

Fixpoint existsb {X : Type} (test : X -> bool) (l : list X) : bool
	(* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(*Example test_existsb_1 : existsb (eqb 5) [0;2;3;6] = false.
Proof. (* FILL IN HERE *) Admitted.*)

Example test_existsb_2 : existsb (andb true) [true;true;false] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_existsb_3 : existsb oddb [1;0;0;0;0;3] = true.
Proof. (* FILL IN HERE *) Admitted.

Example test_existsb_4 : existsb evenb [] = false.
Proof. (* FILL IN HERE *) Admitted.

Definition existsb' {X : Type} (test : X -> bool) (l : list X) : bool
	(* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Theorem existsb_existsb' : forall (X : Type) (test : X -> bool) (l : list X),
	existsb test l = existsb' test l.
Proof. (* FILL IN HERE *) Admitted.

(** [] *)

(* Wed Jan 9 12:02:44 EST 2019 *)


Require Import Classical.
Require Import ClassicalChoice.
Require Import FunctionalExtensionality.
Require Import PropExtensionality.
Require Import Description.
Require Import ClassicalDescription.
Require Import List.
Require Import Psatz.
Require Import Rbase.
Require Import Rfunctions.
Require Import Sets_basics.

(*Here, we try to formalize the topology lesson here :
http://perso.eleves.ens-rennes.fr/~tpier758/cours/topo.pdf
 *)

(***********************************)
(*Topological spaces, metric spaces*)
(***********************************)

(*Topological spaces : generalities*)

(*Topological spaces*)

Definition is_topo {E} (X : E -> Prop) (T : (E -> Prop) -> Prop) :=
  T empty_set /\
  T X /\
  forall (l : list (E -> Prop)), (forall x, In x l -> T x) -> T (finite_inter l X) /\
  forall (A : (E -> Prop) -> Prop), (forall X, A X -> T X) -> T (union_gen A).

Definition is_open {E} (T : (E -> Prop) -> Prop) o :=
  T o.

Definition is_finer_than {E} (X : E -> Prop) (T1 T2 : (E -> Prop) -> Prop) :=
  subset T1 T2.

(*Notion of neighborhood*)

Definition is_neighbh {E} (X : E -> Prop) (T : (E -> Prop) -> Prop) (x : E) (V : E -> Prop) :=
  subset V X /\ V x /\ exists o, is_open T o.

Definition neigbh_sets {E} (X : E -> Prop) (T : (E -> Prop) -> Prop)


Require Import ssr.
Require Import lib.
Require Import withzero.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope dnat_scope.

(* -------------------------------------------------------------------------- *)
(*  Rings                                                                     *)
(* -------------------------------------------------------------------------- *)

Module Ring.

  Section Axioms.

    Variable d' : eqType.
    Notation d := (withzeroData d').
    Notation "0" := (@Zero _).

    Definition lift_opp (f:d'->d') x :=
      match x with
        | Zero => 0
        | Nz x => Nz (f x)
      end.

    Definition lift_add (add:d'->d'->d) x y :=
      match x, y with
        | Zero, _ => y
        | _, Zero => x
        | Nz x, Nz y => add x y
      end.

    Definition lift_mul (mul:d'->d'->d) x y :=
      match x, y with
        | Nz x, Nz y => mul x y
        | _, _ => 0
      end.

    Variable addr' : d'->d'->d.
    Variable mulr' : d'->d'->d.
    Variable oppr' : d'->d'.
    Variable oner' : d'.

    Notation "x1 + x2" := (lift_add addr' x1 x2).
    Notation "x1 * x2" := (lift_mul mulr' x1 x2).
    Notation "- x" := (lift_opp oppr' x).
    Notation "1" := (Nz oner').

    Structure ring_axioms : Type := Ring_axioms {
      oppL'    : forall x,  - x + x = 0;
      addA'    : forall x1 x2 x3, x1 + (x2 + x3) = (x1 + x2) + x3;
        addC'    : forall x1 x2, x1 + x2 = x2 + x1;
      mul1r'   : forall x, 1 * x = x;
      mulr1'   : forall x, x * 1 = x;
      mulA'    : forall x1 x2 x3, x1 * (x2 * x3) = x1 * x2 * x3;
      distPM'  : forall x1 x2 x3, (x1 + x2) * x3 = x1 * x3 + x2 * x3;
      distMP'  : forall x1 x2 x3, x1 * (x2 + x3) = x1 * x2 + x1 * x3;
      mulC'    : forall x1 x2, x1 * x2 = x2 * x1
    }.

  End Axioms.

  Structure prering : Type := Ring {
    rbase'    : eqType;
    addr'     : rbase' -> rbase' -> withzero rbase';
    oppr'     : rbase' -> rbase';
    oner'     : rbase';
    mulr'     : rbase' -> rbase' -> withzero rbase';
    axioms    : ring_axioms addr' mulr' oppr' oner'
  }.

  Definition rbase r := withzeroData (rbase' r).
  Coercion rbase : prering >-> eqType.

  Variable r:prering.

  Definition addr (x y:r) := lift_add (@addr' r) x y.
  Definition mulr (x y:r) := lift_mul (@mulr' r) x y.
  Definition oppr (x:r)   := lift_opp (@oppr' r) x.
  Definition oner         := Nz (oner' r).

  Notation "x1 + x2" := (addr x1 x2).
  Notation "x1 * x2" := (mulr x1 x2).
  Notation "- x"     := (oppr x).
  Notation "x - y"   := (x + (- y)).
  Notation "1"       := (oner).
  Notation "0"       := (@Zero _).

  Axiom addC   : forall x y:r, x + y = y + x.
  Axiom addA   : forall x y z:r, x + (y + z) = (x + y) + z.
  Axiom addr0  : forall x:r, x + 0 = x.
  Axiom oppL   : forall x:r, -x + x = 0.
  Axiom mulA   : forall x y z:r, x * (y * z) = (x * y) * z.
  Axiom distPM : forall x1 x2 x3:r, (x1 + x2) * x3 = (x1 * x3) + (x2 * x3).
  Axiom distMP : forall x1 x2 x3:r, x1 * (x2 + x3) = (x1 * x2) + (x1 * x3).
  Axiom mul1r  : forall x:r, 1 * x = x.
  Axiom mulC   : forall x y:r, x * y = y * x.

End Ring.

Notation "x1 + x2" := (Ring.addr x1 x2)         : ring_scope.
Notation "x1 * x2" := (Ring.mulr x1 x2)         : ring_scope.
Notation "- x"     := (Ring.oppr x)             : ring_scope.
Notation "0"       := (@Zero _)            : ring_scope.
Notation "1"       := (Ring.oner _)             : ring_scope.
Notation "x - y"   := (x + Ring.oppr y)         : ring_scope.
Notation addrr   := (fun x y => y + x).
Notation mulrr   := (fun x y => y * x).


(** Calculation for the lambda calculus + arithmetic + exceptions. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.
Require Import Coq.Program.Equality.
Module Lambda (Import mem : TruncMem).

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr
| Var : nat -> Expr
| Abs : Expr -> Expr
| App : Expr -> Expr -> Expr
| Throw : Expr
| Catch : Expr -> Expr -> Expr.

(** * Semantics *)

(** The evaluator for this language is given as follows (as in the
paper):
<<
type Env = [Value]
data Value =  Num Int | Fun (Value -> Maybe Value)

eval ::  Expr -> Env -> Maybe Value
eval (Val n) e   = Some (Num n)
eval (Add x y) e = case eval x e of
                     Just (Num n) -> case eval y e of
                                       Just (Num m) -> Num (n+m)
                                       _ -> Nothing
                     _ -> Nothing
eval (Var i) e   = if i < length  e then Just (e !! i) else Nothing
eval (Abs x) e   = Just (Fun (\v -> eval x (v:e)))
eval (App x y) e = case eval x e of
                     Just (Fun f) -> eval y e >>= f
                     _ -> Nothing

>>
After defunctionalisation and translation into relational form we
obtain the semantics below. *)

Inductive Value : Set :=
| Num : nat -> Value
| Clo : Expr -> list Value -> Value.

Definition Env := list Value.

Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity).

Inductive eval : Expr -> Env -> option Value -> Prop :=
| eval_val e n : Val n ⇓[e] Some (Num n)
| eval_add e x y m n : x ⇓[e] m -> y ⇓[e] n
                       -> Add x y ⇓[e] (match m, n with
                                          | Some (Num m'), Some (Num n') => Some (Num (m' + n'))
                                          | _,_ => None
                                        end  )
| eval_throw e : Throw ⇓[e] None
| eval_catch e x y m n : x ⇓[e] m -> y ⇓[e] n
                       -> Catch x y ⇓[e] (match m with
                                            | None => n
                                            | _ => m
                                        end  )
| eval_var e i : Var i ⇓[e] nth e i
| eval_abs e x : Abs x ⇓[e] Some (Clo x e)
| eval_app e  x x'' y  x' e' y' : x ⇓[e] Some (Clo x' e') -> y ⇓[e] Some y' -> x' ⇓[y' :: e'] x''
                                -> App x y ⇓[e] x''
| eval_app_fail x x' y y' e : x ⇓[e] x' -> y ⇓[e] y' ->
                              (x' = None \/ exists n, x' = Some (Num n) \/ y' = None) ->
                              App x y ⇓[e] None
where "x ⇓[ e ] y" := (eval x e y).

(** * Compiler *)

Inductive Code : Set :=
| LOAD : nat -> Code -> Code
| ADD : Reg -> Code -> Code
| STORE : Reg -> Code -> Code
| STC : Reg -> Code -> Code
| LOOKUP : nat -> Code -> Code
| RET : Code
| APP : Reg -> Code -> Code
| ABS : Code -> Code -> Code
| THROW : Code
| UNMARK : Code -> Code
| MARK : Reg -> Code -> Code -> Code
| HALT : Code.

Fixpoint comp (e : Expr) (r : Reg) (c : Code) : Code :=
  match e with
    | Val n => LOAD n c
    | Add x y => comp x r (STORE r (comp y (next r) (ADD r c)))
    | Var i => LOOKUP i c
    | App x y => comp x r (STC r (comp y (next r) (APP r c)))
    | Abs x => ABS (comp x (next first) RET) c
    | Throw => THROW
    | Catch e1 e2 => MARK r (comp e2 r c) (comp e1 (next r) (UNMARK c))
  end.

Definition compile (e : Expr) : Code := comp e first HALT.

(** * Virtual Machine *)

Inductive Value' : Set :=
| Num' : nat -> Value'
| Clo' : Code -> list Value' -> Value'
| Exc' : Value'.

Definition Env' := list Value'.

Definition Han := option Reg.

Inductive RVal : Set :=
| VAL : nat -> RVal
| CLO : Code -> Env' -> RVal
| HAN : Code -> Env' -> Han -> RVal
.

Inductive SElem :=
| MEM : Mem RVal -> SElem
| MARKED : SElem.

Definition Lam : Type := list SElem.

Inductive Conf' : Type :=
| conf : Code -> Value' -> Env' -> Han -> Conf'
| fail : Han -> Conf'.

Definition Conf : Type := Conf' * Lam * Mem RVal.

Notation "⟨ x , y , z , w , k , s ⟩" := (conf x y z w, k, s).
Notation "⟪ x , k , s ⟫" := (fail x, k, s).

Definition empty := (@empty RVal).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
 | vm_load n c s a e k h :  ⟨LOAD n c, a, e, h, k, s⟩ ==> ⟨c, Num' n, e, h, k, s⟩
 | vm_add c m n r s e k h : s[r] = VAL m -> ⟨ADD r c, Num' n, e, h, k, s⟩
                                                     ==> ⟨c, Num'(m + n), e, h, k, s⟩
 | vm_add_fail s c c' e e' h r k : ⟨ADD r c, Clo' c' e', e, h, k, s⟩ ==> ⟪h, k, s⟫
 | vm_store c n r s e k h : ⟨STORE r c, Num' n, e, h, k, s⟩
                              ==> ⟨c, Num' n, e, h, k, s[r:=VAL n]⟩
 | vm_store_fail c r s e k h c' e' : ⟨STORE r c, Clo' c' e', e, h, k, s⟩
                                       ==>  ⟪h, k, s⟫
 | vm_stc c c' e' r s e k h : ⟨STC r c, Clo' c' e', e, h, k, s⟩
                                   ==> ⟨c, Clo' c' e', e, h, k, s[r:=CLO c' e']⟩
 | vm_stc_fail c n r s e k h : ⟨STC r c, Num' n, e, h, k, s⟩
                              ==> ⟪h, k, s⟫
 | vm_lookup e i c v a s k h : nth e i = Some v -> ⟨LOOKUP i c, a, e, h, k, s⟩ ==> ⟨c, v, e, h, k, s⟩
 | vm_lookup_fail e i c a s k h : nth e i = None -> ⟨LOOKUP i c, a, e, h, k, s⟩ ==> ⟪h, k, s⟫
 | vm_ret a c e e' s s' k h : s[first] = CLO c e -> ⟨RET, a, e', h, MEM s' :: k, s⟩ ==> ⟨c, a, e, h, k, s'⟩
 | vm_app c c' e e' v r s k h :
     s[r]=CLO c' e' ->
     ⟨APP r c, v, e, h, k,s⟩ ==> ⟨c', Num' 0, v :: e', h, MEM (truncate r s) :: k, empty[first:=CLO c e]⟩
 | vm_abs a c c' s e k h : ⟨ABS c' c, a, e, h, k, s⟩ ==> ⟨c, Clo' c' e, e, h, k, s⟩
 | vm_throw a e h k s : ⟨THROW, a, e, h, k, s⟩ ==> ⟪h, k, s⟫
 | vm_fail p p' s c k e : s[p] = HAN c e p' -> ⟪ Some p, MARKED :: k, s⟫ ==> ⟨c, Num' 0, e, p', k, s⟩
 | vm_fail_pop p s s' k : ⟪ p, MEM s' :: k, s⟫ ==> ⟪ p, k, s'⟫
 | vm_unmark p p' s a c c' e e' k : s[p] = HAN c' e' p' -> ⟨UNMARK c, a, e, Some p, MARKED :: k, s⟩ ==> ⟨c, a, e, p', k, s⟩
 | vm_mark p r s a c c' e k : ⟨MARK r c' c, a, e, p, k, s⟩ ==> ⟨c, a, e, Some r, MARKED :: k, s[r:= HAN c' e p]⟩
where "x ==> y" := (VM x y).

(** Conversion functions from semantics to VM *)

Fixpoint conv (v : Value) : Value' :=
  match v with
    | Num n => Num' n
    | Clo x e => Clo' (comp x (next first) RET) (map conv e)
  end.

Definition convE : Env -> Env' := map conv.

Inductive stackle : Lam -> Lam -> Prop :=
| stackle_empty : stackle nil nil
| stackle_cons_mem s s' k k' : s ⊑ s' -> stackle k k' -> stackle (MEM s :: k) (MEM s' :: k')
| stackle_cons_han k k' : stackle k k' -> stackle (MARKED :: k) (MARKED :: k').

Hint Constructors stackle : memory.

Lemma stackle_refl k : stackle k k.
Proof.
  induction k; try destruct a; constructor; auto with memory.
Qed.

Lemma stackle_trans k1 k2 k3 : stackle k1 k2 -> stackle k2 k3 -> stackle k1 k3.
Proof.
  intros L1. generalize k3. induction L1; intros k3' L2; solve[assumption| inversion L2; subst; constructor; eauto with memory].
Qed.

Hint Resolve stackle_refl stackle_trans : core.

Inductive cle : Conf -> Conf -> Prop :=
 | cle_mem  f k k' s s' : stackle k k' -> s ⊑ s' -> cle (f, k, s)  (f , k', s' ).

Hint Constructors cle : core.

Lemma rel_eq {T} {R : T -> T -> Prop} x y y' : R x y' -> y = y' -> R x y.
Proof. intros. subst. auto.
Qed .
Lemma rel_eq' {T} {R : T -> T -> Prop} x x' y : R x' y -> x = x' -> R x y.
Proof. intros. subst. auto.
Qed .

Ltac apply_eq t := eapply rel_eq; [apply t | repeat rewrite set_set; auto].

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Machine.
Definition Conf := Conf.
Definition Pre := cle.
Definition Rel := VM.

Lemma monotone : monotonicity cle VM.
  prove_monotonicity1;
    try (match goal with [H : stackle (_ :: _) _ |- _] => inversion H end)
    ; prove_monotonicity2.
Qed.

Lemma preorder : is_preorder cle.
  prove_preorder. Qed.
End VM.

Module VMCalc := Calculation mem VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec p v e r c a s k h :
  freeFrom r s ->  p ⇓[e] v ->
  ⟨comp p r c, a, convE e, h, k, s⟩ =|> match v with
                                         | None => ⟪ h , k , s ⟫
                                         | Some v' => ⟨c , conv v', convE e, h, k, s⟩
                                         end.

(** Setup the induction proof *)

Proof.
  intros F E.
  generalize dependent c.
  generalize dependent a.
  generalize dependent s.
  generalize dependent r.
  generalize dependent k.
  generalize dependent h.
  induction E;intros.

(** Calculation of the compiler *)

(** - [Val n ⇓[e] Num n]: *)

  begin
  ⟨c, Num' n , convE e, h, k, s⟩.
  <== { apply vm_load }
  ⟨LOAD n c, a, convE e, h, k, s⟩.
  [].

(** - [Add x y ⇓[e] Num (m + n)]: *)

  begin
      match  m with
        | Some (Num m') => match n with
                           | Some (Num n') => ⟨ c, Num' (m' + n'), convE e, h, k, s ⟩
                           | _ => ⟪ h, k, s ⟫
                           end
        | _ => ⟪ h, k, s ⟫
      end.
  ⊑ {auto}
      match  m with
        | Some (Num m') => match n with
                           | Some (Num n') => ⟨ c, Num' (m' + n'), convE e, h, k, s[r:=VAL m'] ⟩
                           | _ => ⟪ h, k, s[r:=VAL m'] ⟫
                           end
        | _ => ⟪ h, k, s ⟫
      end.
  <== { apply vm_add }
      match  m with
      | Some (Num m') => match n with
                         | Some (Num n') => ⟨ADD r c, Num' n', convE e, h, k, s[r:=VAL m'] ⟩
                         | _ => ⟪ h, k, s[r:=VAL m'] ⟫
                         end
        | _ => ⟪ h, k, s ⟫
      end.
  <== { apply vm_add_fail }
      match  m with
      | Some (Num m') => match n with
                         | Some v => ⟨ADD r c, conv v, convE e, h, k, s[r:=VAL m'] ⟩
                         | None => ⟪ h, k, s[r:=VAL m'] ⟫
                         end
      | _ => ⟪ h, k, s ⟫
      end.
  <|= { apply IHE2 }
      match  m with
      | Some (Num m') => ⟨comp y (next r) (ADD r c), Num' m', convE e, h, k, s[r:=VAL m'] ⟩
      | _ => ⟪ h, k, s ⟫
      end.
  <== { apply vm_store }
      match  m with
      | Some (Num m') => ⟨STORE r (comp y (next r) (ADD r c)), Num' m', convE e, h, k, s ⟩
      | _ => ⟪ h, k, s ⟫
      end.
  <== { apply vm_store_fail }
      match  m with
      | Some v => ⟨STORE r (comp y (next r) (ADD r c)), conv v, convE e, h, k, s ⟩
      | _ => ⟪ h, k, s ⟫
      end.
  <|= { apply IHE1 }
      ⟨comp x r (STORE r (comp y (next r) (ADD r c))), a, convE e, h, k, s⟩.
  [].

  (** - [Throw ⇓[e] None] *)

    begin
      ⟪h, k, s⟫.
    <== {apply vm_throw}
        ⟨ THROW, a, convE e, h, k, s⟩.
    [].

    begin
      match m with
            | Some v'' => ⟨ c, conv v'', convE e, h, k, s ⟩
            | None => match n with
                      | Some v'' => ⟨ c, conv v'', convE e, h, k, s ⟩
                      | None => ⟪ h, k, s ⟫
                      end
      end.
    <|= {apply IHE2}
      match m with
            | Some v'' => ⟨ c, conv v'', convE e, h, k, s ⟩
            | None => ⟨ comp y r c, Num' 0, convE e, h, k, s ⟩
      end.
    ⊑ {eauto}
      match m with
            | Some v'' => ⟨ c, conv v'', convE e, h, k, s ⟩
            | None => ⟨ comp y r c, Num' 0, convE e, h, k, s[r:= HAN (comp y r c) (convE e) h] ⟩
      end.
    <== {apply vm_fail}
      match m with
            | Some v'' => ⟨ c, conv v'', convE e, h, k, s ⟩
            | None => ⟪ Some r, MARKED :: k, s[r:= HAN (comp y r c) (convE e) h] ⟫
      end.
    ⊑ {eauto}
      match m with
            | Some v'' => ⟨ c, conv v'', convE e, h, k, s[r:= HAN (comp y r c) (convE e) h] ⟩
            | None => ⟪ Some r, MARKED :: k, s[r:= HAN (comp y r c) (convE e) h] ⟫
      end.
    <== {eapply vm_unmark}
      match m with
            | Some v'' => ⟨ UNMARK c, conv v'', convE e, Some r, MARKED :: k, s[r:= HAN (comp y r c) (convE e) h] ⟩
            | None => ⟪ Some r, MARKED :: k, s[r:= HAN (comp y r c) (convE e) h] ⟫
      end.
    <|= {apply IHE1}
        ⟨ comp x (next r) (UNMARK c), a, convE e, Some r, MARKED :: k, s[r:= HAN (comp y r c) (convE e) h] ⟩.
    <== {apply vm_mark}
        ⟨ MARK r (comp y r c) (comp x (next r) (UNMARK c)), a, convE e, h, k, s ⟩.
    [].

(** - [Var i ⇓[e] v] *)

  begin
    match nth e i with
    | Some v' => ⟨c, conv v', convE e, h, k, s⟩
    | None => ⟪ h, k, s ⟫
    end.
  <== {apply vm_lookup_fail; unfold convE; rewrite nth_map; rewr_assumption}
    match nth e i with
    | Some v' => ⟨c, conv v', convE e, h, k, s⟩
    | None => ⟨LOOKUP i c, a , convE e, h, k, s ⟩
    end.
  <== {apply vm_lookup; unfold convE; rewrite nth_map; rewr_assumption}
      ⟨LOOKUP i c, a , convE e, h, k, s ⟩.
   [].

(** - [Abs x ⇓[e] Clo x e] *)

  begin
    ⟨c, Clo' (comp x (next first) RET) (convE e), convE e, h, k, s ⟩.
  <== { apply vm_abs }
    ⟨ABS (comp x (next first) RET) c, a, convE e, h, k, s ⟩.
  [].

(** - [App x y ⇓[e] x''] *)

  begin
    match x'' with
    | Some v' => ⟨ c, conv v', convE e, h, k, s ⟩
    | None => ⟪ h, k, s ⟫
    end.
  <== { apply vm_ret }
      match x'' with
      | Some v' => ⟨RET, conv v', convE (y' :: e'), h, MEM s :: k, empty[first:=CLO c (convE e)]⟩
      | None => ⟪ h, k, s ⟫
      end.
  <== { apply vm_fail_pop }
      match x'' with
      | Some v' => ⟨RET, conv v', convE (y' :: e'), h, MEM s :: k, empty[first:=CLO c (convE e)]⟩
      | None => ⟪ h, MEM s :: k, empty[first:=CLO c (convE e)] ⟫
      end.
  <|= {apply IHE3}
      ⟨comp x' (next first) RET, Num' 0, convE (y' :: e'), h, MEM s :: k, empty[first:=CLO c (convE e)]⟩.
  = {auto}
      ⟨comp x' (next first) RET, Num' 0, conv y' :: convE e', h, MEM s:: k, empty[first:=CLO c (convE e)]⟩.
  <== {apply_eq vm_app;try rewrite truncate_set}
      ⟨APP r c, conv y', convE e, h, k, s[r:=CLO (comp x' (next first) RET) (convE e')]⟩.
  <|= {apply IHE2}
      ⟨comp y (next r) (APP r c), (Clo' (comp x' (next first) RET) (convE e')), convE e, h, k, s[r:=CLO (comp x' (next first) RET) (convE e')]⟩.
  <== { apply vm_stc }
    ⟨STC r (comp y (next r) (APP r c)), (Clo' (comp x' (next first) RET) (convE e')), convE e, h, k, s⟩.
  = {auto}
    ⟨STC r (comp y (next r) (APP r c)), conv (Clo x' e'), convE e, h, k, s ⟩.
  <|= { apply IHE1 }
    ⟨comp x r (STC r (comp y (next r) (APP r c))), a, convE e, h, k, s ⟩.
  [].

  begin
    ⟪ h, k, s ⟫.
  = {auto}
  match x' with
  | Some (Clo x'' e') => match y' with
                         | Some v => ⟨ APP r c, conv v, convE e, h, k, s[ r := CLO (comp x'' (next first) RET) (map conv e')] ⟩
                         | None => ⟪h, k, s ⟫
                         end
  | _ => ⟪h, k, s ⟫
  end.
  ⊑ {auto}
  match x' with
  | Some (Clo x'' e') => match y' with
                         | Some v => ⟨ APP r c, conv v, convE e, h, k, s[ r := CLO (comp x'' (next first) RET) (map conv e')] ⟩
                         | None => ⟪h, k, s[ r := CLO (comp x'' (next first) RET) (map conv e')] ⟫
                         end
  | _ => ⟪h, k, s ⟫
  end.
  <|= {apply IHE2}
  match x' with
  | Some (Clo x'' e') => ⟨comp y (next r) (APP r c), conv (Clo x'' e'), convE e, h, k, s[ r := CLO (comp x'' (next first) RET) (map conv e')] ⟩
  | _ => ⟪h, k, s ⟫
  end.
  = {reflexivity}
    match x' with
    | Some v => match v with
                | Clo x'' e' => ⟨comp y (next r) (APP r c), conv (Clo x'' e'), convE e, h, k,
                                 s[ r := CLO (comp x'' (next first) RET) (map conv e')] ⟩
                | _ => ⟪h, k, s ⟫
                end
    | _ => ⟪h, k, s ⟫
    end.
  <== {apply vm_stc}
    match x' with
    | Some v => match v with
                | Clo x'' e' => ⟨STC r (comp y (next r) (APP r c)), conv (Clo x'' e'), convE e, h, k, s ⟩
                | _ => ⟪h, k, s ⟫
                end
    | _ => ⟪h, k, s ⟫
    end.
  <== {apply vm_stc_fail}
    match x' with
    | Some v => ⟨STC r (comp y (next r) (APP r c)), conv v, convE e, h, k, s ⟩
    | _ => ⟪h, k, s ⟫
    end.
  <|= {apply IHE1}
      ⟨comp x r (STC r (comp y (next r) (APP r c))), a, convE e, h, k, s ⟩.
  [].

Qed.

(** * Soundness *)

Lemma determ_vm : determ VM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst; congruence.
Qed.

Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] Some r.

Theorem sound p a s h C : freeFrom first s -> terminates p -> ⟨compile p, a, nil, h, nil, s⟩ =>>! C ->
                          exists v s', C = ⟨HALT , conv v, nil, h, nil, s'⟩ /\ p ⇓[nil] Some v.
Proof.
  unfold terminates. intros F T M. destruct T as [v T].
  pose (spec p (Some v) nil first HALT a s nil h F T) as H'.
  unfold Reach in *. repeat autodestruct.
  pose (determ_trc determ_vm) as D.
  unfold determ in D. inversion H0.   inversion H5. subst.
  exists v. eexists. split. eapply D. apply M. split.
  unfold compile.
  simpl in *. apply H. intro Contra. destruct Contra.
  inversion H1. assumption.
Qed.

Example test1 := (Catch (App (Abs (Throw)) (Val 2)) (Val 3)).

Example test1_eval : exists v, test1 ⇓[ nil ] v.
unfold test1.
eexists.
apply eval_catch.
eapply eval_app.
eapply eval_abs.
eapply eval_val.
eapply eval_throw.
eapply eval_val.
Qed.

(* Compute (compile test1). *)

Example test1_vm h : exists s a, ⟨(compile (Catch (App (Abs (Throw)) (Val 2)) (Val 3))), a, nil, h, nil, empty⟩
                     =>> ⟨HALT, a, nil, h, nil, s⟩.
Proof.
  eexists. eexists.
  unfold compile. simpl.
  eapply trc_step_trans'.
  eapply vm_mark.
  eapply trc_step_trans'.
  eapply vm_abs.
  eapply trc_step_trans'.
  eapply vm_stc.
  eapply trc_step_trans'.
  eapply vm_load.
  eapply trc_step_trans'.
  eapply vm_app.
  rewrite get_set. reflexivity.
  eapply trc_step_trans'.
  eapply vm_throw.
  eapply trc_step_trans'.
  eapply vm_fail_pop.
  eapply trc_step_trans'.
  eapply vm_fail. rewrite truncate_set. rewrite get_set. reflexivity. apply freeFrom_set. auto with memory.
  eapply trc_step_trans'.
  eapply vm_load.
  eapply trc_refl.
Qed.

End Lambda.


Require Import Coq.Unicode.Utf8_core.
Require Import Coq.Program.Tactics.
Require Export Homotopy.Core.

Set Automatic Introduction.
Set Implicit Arguments.
Set Shrink Obligations.
Set Universe Polymorphism.

(** H-Levels *)

(* h-levels 0..2 *)
Definition is_contractible (A : Type) := {x : A & ∀ y : A, y ~ x}.
Definition is_prop (A : Type) := ∀ (x y : A), is_contractible (x ~ y).
Definition is_set (A : Type)  := ∀ (x y : A), is_prop (x ~ y).

Program Fixpoint is_level (n: nat) (A: Type) : Type :=
  match n with
  | O => is_contractible A
  | S n => ∀ (x y: A), is_level n (paths x y)
  end.

Program Fixpoint n_path (n : nat) (A: Type) : Type :=
  match n with
  | O => ∀ (x y : A), x ~ y
  | S n => ∀ (x y : A), n_path n (paths x y)
  end.

Definition contractible := sigT is_contractible.
Definition prop := sigT is_prop.
Definition set := sigT is_set.
Definition level (n: nat) := sigT (is_level n).

Definition contractible_Type (p : contractible) := p.1.
Coercion contractible_Type : contractible >-> Sortclass.

Definition prop_Type (p : prop) := p.1.
Coercion prop_Type : prop >-> Sortclass.

Definition set_Type (p : set) := p.1.
Coercion set_Type : set >-> Sortclass.

Definition level_Type {n} (p : level n) := p.1.
Coercion level_Type : level >-> Sortclass.

Class is_category1 (C : category) :=
  is_category1_prop : ∀ {x y : C}, is_set (x ~> y).

Class is_thin (C : category) :=
  is_thin_prop : ∀ {x y : C}, is_prop (x ~> y).

Class is_strict (C : category) :=
  is_strict_prop : is_set C.


(**  * Bridge between Hydra-battle's and Gaia's [T1]  (Experimental)
 *)

(* begin snippet Requirements:: no-out  *)
From mathcomp Require Import all_ssreflect zify.
From Coq Require Import Logic.Eqdep_dec.
From hydras Require Import DecPreOrder ON_Generic  T2 Gamma0.

From gaia Require Export ssete9.
Import Gamma0.
(* end snippet Requirements *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* begin snippet hT2gT2 *)

(** Hydra-Battles' type for ordinal terms below [Gamma00] *)
Check Gamma0.T2.T2.
Print Gamma0.T2.T2.
#[global] Notation hT2 := hydras.Gamma0.T2.T2.

(** Gaia's type for ordinal terms below [epsilon0] *)
#[global] Notation T2 := ssete9.Gamma0.T2.
(* end snippet hT2gT2 *)

#[global] Notation hcons := gcons.
#[global] Notation hzero := hydras.Gamma0.T2.zero.

(*
#[global] Notation zero := Gamma0.zero.
#[global] Notation cons := Gamma0.cons.
*)
Fixpoint h2g (alpha : hT2) : T2 :=
  match alpha with
    hzero => zero
  | hcons a b n c => cons (h2g a) (h2g b) n (h2g c)
  end.

Fixpoint g2h (alpha : T2) : hT2 :=
  match alpha with
    zero => hzero
  | cons a b n c => hcons (g2h a)(g2h b)  n (g2h c)
  end.

Lemma h2g_g2hK : cancel g2h h2g.
Proof. elim => // => t Ht t0 Ht0 n t1 Ht1 /=; by rewrite Ht Ht0 Ht1.  Qed.

Lemma g2h_h2gK : cancel h2g g2h.
Proof. elim => // => t Ht t0 Ht0 n t1 Ht1 /=; by rewrite Ht Ht0 Ht1.  Qed.

Lemma g2h_eqE (a b: T2) :  g2h a = g2h b <-> a = b.
Proof.
    split .
    - rewrite -(h2g_g2hK a) -(h2g_g2hK b) !g2h_h2gK
              => // -> //.
    - by move => -> .
Qed.

Lemma h2g_eqE (a b :hT2) :  h2g a = h2g b <-> a = b.
Proof.
  split.
    -  rewrite  -(g2h_h2gK a) -(g2h_h2gK b) !h2g_g2hK  =>  // -> //.
    - move => -> //.
Qed.

(* TODO
  Prove the equivalence of comparison and test for normal form in both
  libraries: import well-foundedness *)

Check (fun a b : hT2 => compare a b).

About T2lt.


Section InductionPrinciple.

(* http://pldev.blogspot.dk/2012/02/proving-strong-induction-principle-for.html *)

Require Export Datatypes.

Lemma le_S :
  forall n m : nat,
    n <= S m -> n <= m \/ n = S m.
Proof.
  intros.
  inversion H.
  right. reflexivity.
  left. assumption.
Qed.

Theorem strongind_aux : forall P: nat -> Prop,
  P 0 ->
  (forall n, (forall m, m <= n -> P m) -> P (S n)) ->
  forall n, (forall m, ((m <= n) -> P m)).
Proof.
  induction n as [ | n' IHn' ].
    intros m H1.
    inversion H1.
    assumption.
    intros.
    assert (m <= n' \/ m = S n'). apply le_S. assumption.
    inversion H2.
    apply IHn'; assumption.
    rewrite H3.
    apply (H0 n'); assumption.
Qed.

Lemma weaken : forall P : nat -> Prop,
  (forall n, (forall m, ((m <= n) -> P m))) -> (forall n, P n).
Proof.
  intros P H n.
  apply (H n n).
  apply le_n.
Qed.

Theorem strongind : forall P : nat -> Prop,
  P 0 ->
  (forall n, (forall m, m <= n -> P m) -> P (S n)) ->
  forall n, P n.
Proof.
  intros.
  apply weaken.
  apply strongind_aux; assumption.
Qed.

End InductionPrinciple.


(** Theory of Commutative Cancelative Monoids (CCMs) *)

Require Import Coq.Logic.Decidable.

From iris Require Export base.
From stdpp Require Export decidable.
From stdpp Require Export gmap.
From stdpp Require Import mapset.
From stdpp Require Import finite.
Require Import bst.gmap_more.

Declare Scope ccm_scope.
Delimit Scope ccm_scope with CCM.

(* Cancelable operations. *)
Class Cancelative {A} (R : relation A) (f : A → A → A) : Prop :=
  cancel x y z : R (f x y) (f x z) → R y z.

(* Partial inverse of a monoid operation. *)
Class PartialInv {A} (R: relation A) (f : A → A → A) (g : A → A → A) : Prop :=
  pinv x y : R (g (f x y) y) x.

Class CcmOp (A : Type) := ccmop : A → A → A.
Hint Mode CcmOp ! : typeclass_instances.
Instance: Params (@ccmop) 2 := {}.
Infix "+" := ccmop (at level 50, left associativity) : ccm_scope.
Notation "(+)" := ccmop (only parsing) : ccm_scope.

Class CcmOpInv (A : Type) := ccmop_inv : A → A → A.
Hint Mode CcmOpInv ! : typeclass_instances.
Instance: Params (@ccmop_inv) 2 := {}.
Infix "-" := ccmop_inv (at level 50, left associativity) : ccm_scope.
Notation "(-)" := ccmop_inv (only parsing) : ccm_scope.

Class CcmUnit (A : Type) := ccmunit : A.
Arguments ccmunit {_ _}.
Notation "0" := ccmunit : ccm_scope.

Open Scope ccm_scope.

(* Definition of CCMs *)
Class CCM (M: Type) :=
  {
    ccm_eq : EqDecision M;
    ccm_unit : CcmUnit M; (* 0 *)
    ccm_op: CcmOp M; (* (+) *)
    ccm_opinv: CcmOpInv M; (* (-) *)
    ccm_assoc : Assoc (=) ((+) : M → M → M);
    ccm_comm : Comm (=) ((+) : M → M → M);
    ccm_left_id : LeftId (=) 0 (+);
    ccm_cancel : Cancelative (=) ((+) : M → M → M);
    ccm_pinv : PartialInv (=) ((+) : M → M → M) (-);
  }.

Arguments ccm_op : simpl never.
Arguments ccm_opinv : simpl never.
(*Arguments ccm_unit : simpl never.*)
Hint Extern 0 (CcmOp _) => eapply (@ccm_op _) : typeclass_instances.
Hint Extern 0 (CcmOpInv _) => eapply (@ccm_opinv _) : typeclass_instances.
Hint Extern 0 (CcmUnit _) => eapply (@ccm_unit _) : typeclass_instances.

(** Auxiliary lemmas and type classes. *)

Instance ccm_eq_eq `{CCM A}: EqDecision A.
Proof.
  apply ccm_eq.
Defined.

Lemma ccm_right_id `{CCM M} : RightId (=) 0 (+).
Proof. intros x. etrans; [apply ccm_comm|apply ccm_left_id]. Qed.

Lemma ccm_pinv_unit `{CCM M} (x: M) : x - 0 = x.
Proof.
  rewrite <- (ccm_right_id x) at 1.
  apply ccm_pinv.
Qed.

Close Scope ccm_scope.

(** The CCM of natural numbers with addition. *)

Instance nat_op : CcmOp nat := plus.

Instance nat_opinv : CcmOpInv nat := λ x y, (x - y)%nat.

Instance nat_unit : CcmUnit nat := 0.

Instance plus_assoc: Assoc (=) nat_op.
Proof.
  unfold Assoc.
  intros.
  unfold nat_op.
  lia.
Qed.

Instance plus_comm: Comm (=) nat_op.
Proof.
  unfold Comm.
  intros.
  unfold nat_op.
  lia.
Qed.

Instance plus_leftid: LeftId (=) 0 nat_op.
Proof.
  unfold LeftId.
  intros.
  unfold nat_op.
  unfold nat_unit.
  lia.
Qed.

Instance plus_cancel: Cancelative (=) nat_op.
Proof.
  unfold Cancelative.
  intros.
  unfold nat_op in H.
  lia.
Qed.

Instance plus_pinv: PartialInv (=) nat_op nat_opinv.
Proof.
  unfold PartialInv.
  intros.
  unfold nat_op, nat_opinv.
  lia.
Qed.

Instance nat_ccm : CCM nat := { }.

(** Products of CCMs are CCMs *)

Section product.
  Context A1 A2 `{CCM A1} `{CCM A2}.

  Open Scope ccm_scope.

  Instance prod_eq: EqDecision (A1 * A2).
  Proof.
    apply prod_eq_dec.
  Defined.

  Instance prod_op : CcmOp (A1 * A2) := λ x y, (x.1 + y.1, x.2 + y.2).

  Instance prod_op_inv : CcmOpInv (A1 * A2) := λ x y, (x.1 - y.1, x.2 - y.2).

  Instance prod_unit: CcmUnit (A1 * A2) := (0, 0).

  Instance prod_comm: Comm (=) prod_op.
  Proof.
    unfold Comm, prod_op.
    intros.
    destruct x as [x1 x2].
    destruct y as [y1 y2].
    f_equal.
    all: apply ccm_comm.
  Defined.

  Instance prod_assoc: Assoc (=) prod_op.
  Proof.
    unfold Assoc, prod_op.
    intros.
    destruct x as [x1 x2].
    destruct y as [y1 y2].
    destruct z as [z1 z2].
    f_equal.
    all: apply ccm_assoc.
  Defined.

  Instance prod_leftid: LeftId (=) 0 prod_op.
  Proof.
    unfold LeftId, prod_op, prod_unit.
    intros.
    destruct x as [x1 x2].
    f_equal.
    all: apply ccm_left_id.
  Defined.

  Instance prod_cancel: Cancelative (=) prod_op.
  Proof.
    unfold Cancelative, prod_op.
    intros.
    destruct x as [x1 x2].
    destruct y as [y1 y2].
    destruct z as [z1 z2].
    inversion H1.
    f_equal.
    - generalize H3.
      apply ccm_cancel.
    - generalize H4.
      apply ccm_cancel.
  Defined.

  Instance prod_pinv: PartialInv (=) prod_op prod_op_inv.
  Proof.
    unfold PartialInv, prod_op, prod_op_inv.
    intros.
    destruct x as [x1 x2].
    destruct y as [y1 y2].
    f_equal.
    all: simpl; apply ccm_pinv.
  Defined.

  Global Instance prod_ccm : CCM (A1 * A2) := { }.

End product.

(** Unique representations of non-zero maps over CCMs *)

Open Scope ccm_scope.

Definition nzmap_wf `{Countable K} `{CCM A} : gmap K A → Prop :=
  map_Forall (λ _ x, ¬ (x = 0)).

Instance nzmap_wf_decision K `{Countable K} `{CCM A} (m: gmap K A) : Decision (nzmap_wf m).
Proof.
  solve_decision.
Qed.

Lemma empty_nzmap_wf `{Countable K} `{CCM A} : nzmap_wf (∅ : gmap K A).
Proof.
  unfold nzmap_wf, map_Forall.
  intros.
  rewrite lookup_empty in H1.
  inversion H1.
Qed.

(* The type of non-zero maps over CCMs *)
Record nzmap K `{Countable K} A `{CCM A} :=
  NZMap {
      nzmap_car : gmap K A;
      nzmap_prf : bool_decide (nzmap_wf nzmap_car)
    }.

Arguments NZMap {_ _ _ _ _} _ _ : assert.
Arguments nzmap_car {_ _ _ _ _} _ : assert.

(* Lift some common operations from gmaps to nzmaps. *)

Instance nzmap_lookup `{Countable K} `{CCM A} : Lookup K A (nzmap K A) :=
  λ i m, let (m, _) := m in m !! i.

Definition nzmap_total_lookup `{Countable K} `{CCM A} i (m : nzmap K A) := default 0 (m !! i).

Notation "m ! i" := (nzmap_total_lookup i m) (at level 20).

Instance nzmap_dom `{Countable K} `{CCM A} : Dom (nzmap K A) (gset K) :=
  λ m, dom (gset K) (nzmap_car m).

Definition nzmap_unit `{Countable K} `{CCM A} := NZMap (∅ : gmap K A) (bool_decide_pack _ empty_nzmap_wf).

Instance nzmap_empty `{Countable K} `{CCM A} : Empty (nzmap K A) := nzmap_unit.

Lemma nzmap_is_wf `{Countable K} `{CCM A} (m : nzmap K A) : nzmap_wf (nzmap_car m).
Proof.
  destruct m.
  simpl.
  unfold bool_decide in nzmap_prf0.
  destruct nzmap_wf_decision eqn:?.
  all: naive_solver.
Qed.

Lemma nzmap_eq `{Countable K} `{CCM A} (m1 m2 : nzmap K A) :
  m1 = m2 ↔ ∀ k, m1 ! k = m2 ! k.
Proof.
  split; [by intros ->|intros].
  assert (nzmap_car m1 = nzmap_car m2).
  { pose proof (nzmap_is_wf m1) as Hm1_wf.
    pose proof (nzmap_is_wf m2) as Hm2_wf.
    destruct m1, m2; simplify_eq/=.
    apply map_eq.
    intros k.
    pose proof (H1 k) as Hk.
    unfold nzmap_wf, map_Forall in Hm1_wf, Hm2_wf.
    pose proof (Hm1_wf k) as Hm1_wf.
    pose proof (Hm2_wf k) as Hm2_wf.
    unfold nzmap_total_lookup, lookup, nzmap_lookup in Hk.
    destruct (nzmap_car0 !! k) eqn:?, (nzmap_car1 !! k) eqn:?; simplify_eq/=;
             try reflexivity.
    - pose proof (Hm1_wf 0) as Hm1_wf.
      naive_solver.
    - pose proof (Hm2_wf 0) as Hm2_wf.
      naive_solver.
  }
  destruct m1, m2; simplify_eq/=.
  f_equal.
  apply proof_irrel.
Qed.

Lemma nzmap_gmap_eq `{Countable K} `{CCM A} (m1 m2 : nzmap K A) :
  m1 = m2 ↔ nzmap_car m1 = nzmap_car m2.
Proof.
  split; [by intros ->|intros]. destruct m1, m2; simplify_eq/=.
  f_equal. apply proof_irrel.
Qed.

Instance nzmap_eq_eq `{Countable K} `{CCM A} : EqDecision (nzmap K A).
Proof.
  refine (λ m1 m2, cast_if (decide (nzmap_car m1 = nzmap_car m2)));
  try abstract (by rewrite nzmap_gmap_eq).
Defined.

Definition nzmap_merge_op `{CCM A} (f : A → A → A) :=
  λ (o1 o2 : option A),
  match o1, o2 with
    None, None => None
  | _, _ =>
    let r := f (default 0 o1) (default 0 o2) in
    if (decide (0 = r)) then None else Some r
  end.

Lemma nzmap_diag_merge_op `{CCM A} (f : A → A → A) :
  nzmap_merge_op f None None = None.
Proof.
  auto.
Qed.

Lemma nzmap_merge_wf `{Countable K} `{CCM A}
      (f : A → A → A) (m1 m2 : gmap K A) :
  nzmap_wf m1 → nzmap_wf m2 → nzmap_wf (merge (nzmap_merge_op f) m1 m2).
Proof.
  unfold nzmap_wf. unfold map_Forall.
  intros Hm1 Hm2 k x Hm.
  rewrite lookup_merge in Hm.
  unfold nzmap_merge_op in Hm.
  unfold diag_None in Hm.
  destruct (m1 !! _), (m2 !! _);
    try destruct (decide (0 = _)) eqn:?;
        naive_solver.
Qed.

Definition nzmap_merge `{Countable K} `{CCM A} :=
  λ (f : A → A → A)  (m1 m2 : nzmap K A),
    let (m1, Hm1) := m1 in
    let (m2, Hm2) := m2 in
    NZMap (merge (nzmap_merge_op f) m1 m2) (bool_decide_pack _ (nzmap_merge_wf f _ _
    (bool_decide_unpack _ Hm1) (bool_decide_unpack _ Hm2))).

Definition nzmap_imerge_op `{Countable K} `{CCM A} (f : K → A → A → A) :=
  λ k (o1 o2 : option A),
  match o1, o2 with
    None, None => None
  | _, _ =>
    let r := f k (default 0 o1) (default 0 o2) in
    if (decide (0 = r)) then None else Some r
  end.

Lemma nzmap_diag_imerge_op `{Countable K} `{CCM A} (k: K) (f : K → A → A → A) :
  nzmap_imerge_op f k None None = None.
Proof.
  auto.
Qed.

Lemma nzmap_imerge_wf `{Countable K} `{CCM A}
      (f : K → A → A → A) (m1 m2 : gmap K A) :
  nzmap_wf m1 → nzmap_wf m2 → nzmap_wf (imerge (nzmap_imerge_op f) m1 m2).
Proof.
  unfold nzmap_wf. unfold map_Forall.
  intros Hm1 Hm2 k x Hm.
  rewrite gmap_imerge_prf in Hm.
  unfold nzmap_imerge_op in Hm.
  destruct (m1 !! _), (m2 !! _);
    try destruct (decide (0 = _)) eqn:?;
        naive_solver.
  intros. apply nzmap_diag_imerge_op.
Qed.

Definition nzmap_imerge `{Countable K} `{CCM A} :=
  λ (f : K → A → A → A)  (m1 m2 : nzmap K A),
    let (m1, Hm1) := m1 in
    let (m2, Hm2) := m2 in
    NZMap (imerge (nzmap_imerge_op f) m1 m2) (bool_decide_pack _ (nzmap_imerge_wf f _ _
    (bool_decide_unpack _ Hm1) (bool_decide_unpack _ Hm2))).

Lemma nzmap_lookup_wf `{Countable K} `{CCM A} (m : gmap K A) i : nzmap_wf m → m !! i <> Some 0.
Proof.
  intros.
  unfold nzmap_wf, map_Forall in H0.
  firstorder.
Qed.

Lemma nzmap_elem_of_dom `{Countable K} `{CCM A} (m : nzmap K A) i : i ∈ dom (gset K) m ↔ is_Some (m !! i).
Proof.
  unfold dom, nzmap_dom.
  rewrite elem_of_dom.
  unfold lookup at 2, nzmap_lookup.
  unfold nzmap_car.
  destruct m.
  naive_solver.
Qed.

Lemma nzmap_elem_of_dom_total `{Countable K} `{CCM A} (m : nzmap K A) i : i ∈ dom (gset K) m ↔ m ! i <> 0.
Proof.
  pose proof (nzmap_is_wf m) as m_wf.
  unfold nzmap_total_lookup, default.
  split.
  - intro.
    apply nzmap_elem_of_dom in H1.
    unfold is_Some in H1.
    destruct H1 as [x ?].
    rewrite H1.
    apply (nzmap_lookup_wf (nzmap_car m) i) in m_wf.
    unfold lookup, nzmap_lookup in H1.
    destruct m. simpl in m_wf.
    unfold id.
    rewrite H1 in m_wf.
    naive_solver.
  - intros.
    rewrite nzmap_elem_of_dom.
    destruct (m !! i).
    naive_solver.
    contradiction.
Qed.

Lemma nzmap_empty_lookup `{Countable K} `{CCM A} (m: nzmap K A) : m <> ∅ ↔ ∃ i, m ! i <> 0.
Proof.
  pose proof (nzmap_is_wf m).
  split.
  - intros.
    destruct m.
    rewrite nzmap_gmap_eq in H2 *; intros; simpl in H1.
    unfold empty in H2.
    unfold nzmap_empty, nzmap_unit in H2.
    simpl in H2.
    apply map_choose in H2.
    destruct H2 as [i [x H2]].
    pose proof (nzmap_lookup_wf nzmap_car0 i).
    apply H3 in H1.
    exists i.
    unfold nzmap_total_lookup.
    unfold default, lookup, nzmap_lookup.
    rewrite H2.
    naive_solver.
  - naive_solver.
Qed.

Lemma nzmap_lookup_empty `{Countable K} `{CCM A} i : (∅ : nzmap K A) ! i = 0.
Proof.
  unfold empty, nzmap_empty, nzmap_unit.
  unfold nzmap_total_lookup, lookup, nzmap_lookup.
  rewrite lookup_empty.
  auto.
Qed.

Class UnitId A `(CCM A) (f : A → A → A) : Prop :=
  unit_id : f 0 0 = 0.

Instance ccm_op_unit_id `{CCM A} : UnitId A _ (+).
Proof.
  unfold UnitId.
    by rewrite ccm_left_id.
Defined.

Instance lift_opinv_unit_id `{CCM A} : UnitId A _ (-).
Proof.
  unfold UnitId.
  rewrite <- (ccm_right_id 0) at 1.
    by rewrite ccm_pinv.
Defined.

Lemma nzmap_lookup_merge `{Countable K} `{UnitId A f} (m1 m2 : nzmap K A) (k : K) :
  nzmap_merge f m1 m2 ! k = f (m1 ! k) (m2 ! k).
Proof.
  unfold nzmap_merge, nzmap_total_lookup, lookup, nzmap_lookup.
  destruct m1, m2.
  unfold nzmap_merge_op.
  rewrite lookup_merge.
  destruct (nzmap_car0 !! _) eqn:?,
           (nzmap_car1 !! _) eqn:?;
           simpl;
    try destruct (decide (0 = _));
    try rewrite <- e;
    simpl;
    try reflexivity.
  unfold UnitId in H1.
  rewrite H1.
  reflexivity.
Qed.

Lemma nzmap_lookup_imerge `{Countable K} `{CCM A} `{∀ k : K, UnitId A _ (f k)} (m1 m2 : nzmap K A) (k : K) :
  nzmap_imerge f m1 m2 ! k = f k (m1 ! k) (m2 ! k).
Proof.
  unfold nzmap_imerge, nzmap_total_lookup, lookup, nzmap_lookup.
  destruct m1, m2.
  unfold nzmap_imerge_op.
  rewrite gmap_imerge_prf.
  destruct (nzmap_car0 !! _) eqn:?,
           (nzmap_car1 !! _) eqn:?;
           simpl;
    try destruct (decide (0 = _));
    try rewrite <- e;
    simpl;
    try reflexivity.
  unfold UnitId in H1.
  rewrite H1.
  reflexivity.
  now intros.
Qed.

Lemma nzmap_imerge_empty {A} `{Countable K} `{CCM A} `{∀ k : K, UnitId A _ (f k)}
      : (∀ i y, f i y 0 = y) -> ∀ m, nzmap_imerge f m ∅ = m.
Proof.
  intros.
  apply nzmap_eq.
  intros.
  rewrite nzmap_lookup_imerge.
  unfold nzmap_total_lookup at 2.
  unfold lookup, nzmap_lookup, empty, nzmap_empty, nzmap_unit.
  rewrite lookup_empty. simpl.
  auto.
Qed.

Close Scope ccm_scope.

(** Lifting any CCM A to functions f: K → A yields a CCM. Here, we assume that f k ≠ 0 for finitely many k. Moreover, K must be countable. *)

Section lifting.
  Context K `{Countable K} A `{CCM A}.

  Open Scope ccm_scope.

  (* To obtain unique representations, we represent functions f: K → A
   * as g: gmap K A where f k = 0 ↔ g !! k = None *)

  Global Instance lift_unit : CcmUnit (nzmap K A) := nzmap_unit.

  (* Lift CCM operations on A to (nzmap K A) *)

  Instance lift_op : CcmOp (nzmap K A) := λ m1 m2,
    nzmap_merge (+) m1 m2.

  Instance lift_opinv : CcmOpInv (nzmap K A) := λ m1 m2,
    nzmap_merge (-) m1 m2.

  (* Prove that this yields again a CCM *)

  Instance lift_comm: Comm (=) lift_op.
  Proof.
    unfold Comm, lift_op.
    intros.
    apply nzmap_eq.
    intros.
    repeat rewrite nzmap_lookup_merge.
    apply ccm_comm.
  Qed.

  Instance lift_assoc: Assoc (=) lift_op.
  Proof.
    unfold Assoc, lift_op.
    intros.
    apply nzmap_eq.
    intros.
    repeat rewrite nzmap_lookup_merge.
    apply ccm_assoc.
  Defined.

  Instance lift_leftid: LeftId (=) 0 lift_op.
  Proof.
    unfold LeftId, lift_op.
    intros.
    rewrite nzmap_eq.
    intros.
    rewrite nzmap_lookup_merge.
    apply ccm_left_id.
  Defined.

  Instance lift_cancel: Cancelative (=) lift_op.
  Proof.
    unfold Cancelative, lift_op.
    intros.
    apply nzmap_eq.
    intros.
    rewrite nzmap_eq in H1 *.
    intros.
    pose proof (H1 k).
    repeat rewrite nzmap_lookup_merge in H2.
    apply ccm_cancel in H2.
    trivial.
  Defined.

  Instance lift_pinv: PartialInv (=) lift_op lift_opinv.
  Proof.
    unfold PartialInv.
    intros.
    apply nzmap_eq.
    intros.
    repeat rewrite nzmap_lookup_merge.
    apply ccm_pinv.
  Defined.

  Global Program Instance lift_ccm : CCM (nzmap K A) := { }.

  Implicit Types m : nzmap K A.

  (* The monoid operation distributes over lookup. *)
  Lemma lookup_op m1 m2 i : (m1 + m2) ! i = m1 ! i + m2 ! i.
  Proof.
    unfold ccm_op,ccmop at 1.
    unfold lift_op.
    apply nzmap_lookup_merge.
  Qed.

  Global Opaque nzmap_empty.
End lifting.

Arguments NZMap {_ _ _ _ _} _ _ : assert.
Arguments nzmap_car {_ _ _ _ _} _ : assert.
Arguments nzmap_total_lookup {_ _ _ _ _} _ _ : assert.

Section fold_right_ccm.

  Context A `{CCM A}.

  Open Scope ccm_scope.

  Lemma accumulate_perm: forall {B} (f: B -> A) init (l1 l2: list B),
      Permutation l1 l2 ->
      fold_right (fun x v => f x + v) init l1 =
      fold_right (fun x v => f x + v) init l2.
  Proof.
    intros. induction H0; simpl; auto.
    - now rewrite IHPermutation.
    - rewrite !ccm_assoc. now rewrite (ccm_comm (f y) (f x)).
    - now transitivity (fold_right (fun x v => f x + v) init l').
  Qed.

  Lemma accumulate_zero: forall {B} (f: B -> A) init (l: list B),
      (forall x, In x l -> f x = 0) ->
      fold_right (fun x v => f x + v) init l = init.
  Proof.
    intros. induction l; intros; simpl; auto. rewrite IHl.
    - rewrite H0; [rewrite ccm_left_id | left]; easy.
    - intros. apply H0. now right.
  Qed.

  Close Scope ccm_scope.

End fold_right_ccm.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*      Initial Version: Frederic Prost, July 1993                          *)
(*      Revised Version: Gilles Kahn, September 1993                        *)
(*      Revised Version: Gilles Kahn, November 1993                         *)
(*      Revised Version: Gilles Kahn, April 1994                            *)
(*                               INRIA Sophia-Antipolis, FRANCE             *)
(*      Revised Version: Jean-Christophe Filliatre, January 1995            *)
(*                               ENS-Lyon, FRANCE                           *)
(*                                                                          *)
(****************************************************************************)
(*                               Ensembles.v                                *)
(****************************************************************************)

Require Import Classical.

Section Ensembles.
   Variable U : Type.

   Definition Ensemble := U -> Prop.

   Definition In (B : Ensemble) (x : U) : Prop := B x.

   Definition Included (B C : Ensemble) : Prop :=
     forall x : U, In B x -> In C x.

   Inductive Empty_set : Ensemble :=.

   Inductive Singleton (x : U) : Ensemble :=
       In_singleton : In (Singleton x) x.

   Inductive Union (B C : Ensemble) : Ensemble :=
     | Union_introl : forall x : U, In B x -> In (Union B C) x
     | Union_intror : forall x : U, In C x -> In (Union B C) x.

   Inductive Intersection (B C : Ensemble) : Ensemble :=
       Intersection_intro :
         forall x : U, In B x -> In C x -> In (Intersection B C) x.

   Inductive Couple (x y : U) : Ensemble :=
     | Couple_l : In (Couple x y) x
     | Couple_r : In (Couple x y) y.

   Inductive Setminus (B C : Ensemble) : Ensemble :=
       Setminus_intro :
         forall x : U, In B x -> ~ In C x -> In (Setminus B C) x.

   Inductive Disjoint (B C : Ensemble) : Prop :=
       Disjoint_intro :
         (forall x : U, ~ In (Intersection B C) x) -> Disjoint B C.

   Inductive Non_empty (B : Ensemble) : Prop :=
       Non_empty_intro : forall x : U, In B x -> Non_empty B.

   Inductive Finite : Ensemble -> Prop :=
     | Empty_is_finite : Finite Empty_set
     | Union_is_finite :
         forall A : Ensemble,
         Finite A -> forall x : U, ~ In A x -> Finite (Union (Singleton x) A).

 (*************************************************************************)
 (*** Initialement, la definition de Same_set etait :

   Inductive Same_set [B,C: Ensemble]: Prop :=
         Same_set_intro: (Included B C) -> (Included C B) -> (Same_set B C).

  *** mais dans le lemme Same_set_equivalence de ps.v (par exemple)
      	(Same_set U)
      n'est plus unifie avec
      	[x,y:(Ensemble U)](and (Included x y) (Included y x))

  *** on redefinit donc Same_set et Same_Set_intro de la maniere
      suivante : ***)
 (*************************************************************************)

   Definition Same_set (B C : Ensemble) : Prop :=
     Included B C /\ Included C B.

   Lemma Same_set_intro :
    forall B C : Ensemble, Included B C -> Included C B -> Same_set B C.
   intros B C H H'.
   unfold Same_set in |- *.
   split; [ exact H | exact H' ].
   Qed.

 (*************************************************************************)

   Axiom
     Extensionality_Ensembles :
       forall A B : Ensemble, Same_set A B -> A = B :>Ensemble.

End Ensembles.
Hint Unfold In.
Hint Unfold Included.
Hint Resolve Same_set_intro.
Hint Resolve Union_introl Union_intror.
Hint Resolve Intersection_intro.
Hint Resolve In_singleton.
Hint Resolve Couple_l Couple_r.
Hint Resolve Setminus_intro.
Hint Resolve Disjoint_intro.
Hint Resolve Empty_is_finite Union_is_finite.
Hint Resolve Extensionality_Ensembles.


From LM Require Import Prelims L.

(** * Encoding Terms as Programs *)

Inductive Tok := varT (n :nat) | appT | lamT | retT.
Notation Pro := (list Tok) (only parsing).

Fixpoint compile (s: L.term) : Pro :=
  match s with
    var x => [varT x]
  | app s t => compile s ++ compile t ++ [appT]
  | lam s => lamT :: compile s ++ [retT]
  end.

Inductive reprP : Pro -> term -> Prop :=
  reprPC s : reprP (compile s) (lam s).

(** ** Program size *)

Fixpoint sum (A:list nat) :=
  match A with
    [] => 0
  | a::A => a + sum A
  end.

Lemma sum_app A B : sum (A++B) = sum A + sum B.
Proof.
  induction A;cbn;omega.
Qed.

Hint Rewrite sum_app : list.

Definition sizeT t :=
  match t with
    varT n => 1 + n
  |  _ => 1
  end.

Definition sizeP (P:Pro) := sum (map sizeT P) + 1.
Hint Unfold sizeP.

Lemma size_geq_1 s: 1<= size s.
Proof.
  induction s;cbn. all:try omega.
Qed.

Lemma sizeP_size' s :size s <= sum (map sizeT (compile s)).
Proof.
  induction s;cbn.
  all:autorewrite with list. all:cbn. all:try omega.
Qed.

Lemma sizeP_size s: sum (map sizeT (compile s)) + 1<= 2*size s.
Proof.
  induction s;cbn.
  all:autorewrite with list. all:cbn. all:try omega.
Qed.

(** ** Programm Decomposition *)

Fixpoint jumpTarget (l:nat) (res:Pro) (P:Pro) : option (Pro*Pro) :=
  match P with
  | retT :: P => match l with
                | 0 => Some (res,P)
                | S l => jumpTarget l (res++[retT]) P
                end
  | lamT :: P => jumpTarget (S l) (res++[lamT])P
  | t :: P    => jumpTarget l (res++[t]) P
  | []        => None
  end.

Lemma jumpTarget_correct s c:
  jumpTarget 0 [] (compile s ++ retT::c) = Some (compile s,c).
Proof.
  change (Some (compile s,c)) with (jumpTarget 0 ([]++compile s) (retT::c)).
  generalize 0.
  generalize (retT::c) as c'. clear c.
  generalize (@nil Tok) as c.
  induction s;intros c' c l.
  -reflexivity.
  -cbn. autorewrite with list. rewrite IHs1,IHs2. cbn. now autorewrite with list.
  -cbn. autorewrite with list. rewrite IHs. cbn. now autorewrite with list.
Qed.

(** ** Program Substitution *)

Fixpoint substP (P:Pro) k Q : Pro :=
  match P with
    [] => []
  | lamT::P => lamT::substP P (S k) Q
  | retT::P => retT::match k with
                      S k => substP P k Q
                    | 0 => [varT 42 (* doesnt matter *)]
                    end
  | varT k'::P => (if Dec (k'=k) then Q else [varT k'])++substP P k Q
  | appT::P => appT::substP P k Q
  end.

Lemma substP_correct' s k c' t:
  substP (compile s++c') k (compile t)
  = compile (subst s k t)++substP c' k (compile t).
Proof.
  induction s in k,c'|-*;cbn.
  -decide _;cbn. all:now autorewrite with list.
  -autorewrite with list. rewrite IHs1,IHs2. reflexivity.
  -autorewrite with list. rewrite IHs. reflexivity.
Qed.

Lemma substP_correct s k t:
  substP (compile s) k (compile t) = compile (subst s k t).
Proof.
  replace (compile s) with (compile s++[]) by now autorewrite with list.
  rewrite substP_correct'. now autorewrite with list.
Qed.

(** ** Injectivity of Programm Encoding *)

Fixpoint decompile l P A : option (list term) :=
  match P with
    retT::P => match l with
                0 => None
              | S l => match A with
                        s::A => decompile l P (lam s::A)
                      | [] => None
                      end
              end
  | varT n::P => decompile l P (var n::A)
  | lamT::P =>  decompile (S l) P A
  | appT::P => match A with
               t::s::A => decompile l P (app s t::A)
             | _ => None
              end
  | [] => Some A
  end.

Lemma decompile_correct' l s P A:
  decompile l (compile s++P) A = decompile l P (s::A).
Proof.
  induction s in l,P,A|-*. all:cbn.
  -congruence.
  -autorewrite with list. rewrite IHs1. cbn. rewrite IHs2. reflexivity.
  -autorewrite with list. rewrite IHs. reflexivity.
Qed.

Lemma compile_inj s s' :
  compile s = compile s' -> s = s'.
Proof.
  intros eq.
  specialize (@decompile_correct' 0 s [] []) as H1.
  specialize (@decompile_correct' 0 s' [] []) as H2.
  rewrite eq in H1. rewrite H1 in H2. now inv H2.
Qed.