(* $Id: CLogic.v,v 1.9 2003/03/12 08:57:44 lcf Exp $ *)

Require Export Compare_dec.
Require Export Basics.
Require Export ZArith.
Require Export ZArithRing.
Require Export Div2.
Require Export Wf_nat.

(* Tex_Prose
\chapter{Extending the {\tt Coq} Logic}
Because notions of apartness and order have computational meaning, we
will have to define logical connectives in \verb!Set!.  In order to
keep a syntactic distinction between types of terms, we define \verb!CProp!
as an alias for \verb!Set!, to be used as type of (computationally meaningful)
propositions.

Falsehood and negation will tipically not be needed in \verb!CProp!, as they are used to refer
to negative statements, which carry no computational meaning.  Therefore, we will
simply define a negation operator from \verb!Set! to \verb!Prop! .

Conjunction, disjunction and existential quantification will have to come in
multiple varieties.  For conjunction, we will need four operators of type
$s_1\rightarrow s_2\rightarrow s_3$, where $s_3$ is \verb!Prop! if both $s_1$ and $s_2$
are \verb!Prop! and \verb!CProp! otherwise.

Disjunction is slightly different, as it will always return a value in \verb!CProp! even
if both arguments are propositions.  This is because in general
it may be computationally important to know which of the two branches of the disjunction actually holds.

Existential quantification will similarly always return a value in \verb!CProp!.

\begin{notation}
\begin{itemize}
\item \verb!CProp!-valued conjuction will be denoted as {\tt *};
\item \verb!CProp!-valued conjuction will be denoted as \verb!+!;
\item in both preceding cases, objects of type \verb!Prop! will be enclosed in curly braces;
\item Existential quantification will be written as \verb!{x:A & B}! or \verb!{x:A | B}!,
according to whether \verb!B! is respectively of type \verb!CProp! or \verb!Prop!.
\end{itemize}
\end{notation}

In a few specific situations we {\em do} need truth, false and negation in \verb!CProp!, so we will
also introduce them; this should be a temporary option\ldots

Finally, for other formulae that might occur in our \verb!CProp!-valued
propositions, such as \verb!(le m n)!, we have to introduce a \verb!CProp!-valued
version.
*)

Definition CProp := Set.

Section Basics.
(* Tex_Prose
\section{Basics}
Here we treat conversion from \verb!Prop! to \verb!CProp! and vice versa,
and some basic connectives in \verb!CProp!.
*)

(* Begin_Tex_Verb *)
Definition Not := [P:CProp](P->False).
Definition Iff [A,B:CProp] : CProp := (A->B)*(B->A).
Inductive CFalse : CProp :=.
Inductive CTrue : CProp := CI : CTrue.

Inductive sig2P [A:Set;P:A->Prop;Q:A->CProp] : CProp
      := exist2P : (x:A)(P x) -> (Q x) -> (sig2P A P Q).

Inductive sigS2P [A:Set;P:A->CProp;Q:A->Prop] : CProp
      := existS2P : (x:A)(P x) -> (Q x) -> (sigS2P A P Q).

  Definition proj1_sig2 [A:Set;P,Q:A->Prop]:=
   [e:(sig2 A P Q)]Cases e of (exist2 a b c) => a  end.

  Definition proj2a_sig2 [A:Set;P,Q:A->Prop]:=
   [e:(sig2 A P Q)]
     <[e:(sig2 A P Q)](P (proj1_sig2 A P Q e))>Cases e of (exist2 a b c) => b  end.

  Definition proj2b_sig2 [A:Set;P,Q:A->Prop]:=
   [e:(sig2 A P Q)]
     <[e:(sig2 A P Q)](Q (proj1_sig2 A P Q e))>Cases e of (exist2 a b c) => c  end.

  Definition proj1_sig2P [A:Set;P,Q:A->?]:=
   [e:(sig2P A P Q)]Cases e of (exist2P a b c) => a  end.

  Definition proj2a_sig2P [A:Set;P,Q:A->?]:=
   [e:(sig2P A P Q)]
     <[e:(sig2P A P Q)](P (proj1_sig2P A P Q e))>Cases e of (exist2P a b c) => b  end.

  Definition proj2b_sig2P [A:Set;P,Q:A->?]:=
   [e:(sig2P A P Q)]
     <[e:(sig2P A P Q)](Q (proj1_sig2P A P Q e))>Cases e of (exist2P a b c) => c  end.

  Definition proj1_sigS2P [A:Set;P,Q:A->?]:=
   [e:(sigS2P A P Q)]Cases e of (existS2P a b c) => a  end.

  Definition proj2a_sigS2P [A:Set;P,Q:A->?]:=
   [e:(sigS2P A P Q)]
     <[e:(sigS2P A P Q)](P (proj1_sigS2P A P Q e))>Cases e of (existS2P a b c) => b  end.

  Definition proj2b_sigS2P [A:Set;P,Q:A->?]:=
   [e:(sigS2P A P Q)]
     <[e:(sigS2P A P Q)](Q (proj1_sigS2P A P Q e))>Cases e of (existS2P a b c) => c  end.

Inductive toCProp [A:Prop] : CProp := ts : A->(toCProp A).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma toCProp_e : (A:Prop)(toCProp A)->(P:Prop)(A->P)->P.
(* End_Tex_Verb *)
Intros A H P H0.
Elim H.
Intros H1.
Apply H0.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Definition CNot := [A:Prop]A->CFalse.

Lemma Ccontrapos':(A,phi:Prop)(A->phi)->(~phi)->(CNot A).
(* End_Tex_Verb *)
Proof.
 Intros A phi H H0.
 Intro H1.
 Elim H0.
 Auto.
Qed.

(* Begin_Tex_Verb *)
Inductive andl [A:CProp][B:Prop] : CProp := conjl : A->B->(andl A B).
Inductive andr [A:Prop][B:CProp] : CProp := conjr : A->B->(andr A B).
Inductive andps [A,B:Prop] : CProp := conjps : A->B->(andps A B).

Inductive sumorr [A:Prop;B:CProp] : CProp :=
    inleft'  : A -> (sumorr A B)
  | inright' : B -> (sumorr A B).
(* End_Tex_Verb *)

End Basics.

(* Syntax and pretty printing:
  - disjunction will be written as P+Q;
  - conjunction will be written as P*Q;
  - arguments of type Prop should be enclosed in {curly braces}.
*)

Arguments Scope sumbool [type_scope type_scope].
Arguments Scope sumor [type_scope type_scope].
Arguments Scope sumorr [type_scope type_scope].
Arguments Scope sum [type_scope type_scope].

Notation "{ A } + { B }" := ((sumbool A B) :: CProp) (at level 1).
Notation "A + { B }" := ((sumor A B) :: CProp) (at level 4).
Notation "{ A } + B" := (sumorr A B) (at level 1).
Notation "A + B" := ((sum A B) :: CProp) (at level 4).

Arguments Scope andps [type_scope type_scope].
Arguments Scope andl [type_scope type_scope].
Arguments Scope andr [type_scope type_scope].
Arguments Scope prod [type_scope type_scope].

Notation "{ A } * { B }" := (andps A B) (at level 1).
Notation "A * { B }" := (andl A B) (at level 3).
Notation "{ A } * B" := (andr A B) (at level 1).
Notation "A * B" := ((prod A B) :: CProp) (at level 3).

Arguments Scope sig [type_scope type_scope].
Arguments Scope sig2 [type_scope type_scope type_scope].

Notation "{ x : A  |  P }"       := ((sig A [x:A]P) :: CProp)         (at level 1).
Notation "{ x : A  |  P  |  Q }" := ((sig2 A [x:A]P [x:A]Q) :: CProp) (at level 1).

Arguments Scope sigS [type_scope type_scope].
Arguments Scope sigS2 [type_scope type_scope type_scope].

Notation "{ x : A  &  P }"       := ((sigS A [x:A]P) :: CProp)         (at level 1).
Notation "{ x : A  &  P  &  Q }" := ((sigS2 A [x:A]P [x:A]Q) :: CProp) (at level 1).

Arguments Scope sig2P [type_scope type_scope type_scope].
Arguments Scope sigS2P [type_scope type_scope type_scope].

Notation "{ x : A  |  P  &  Q }" := (sig2P A [x:A]P [x:A]Q) (at level 1).
Notation "{ x : A  &  P  |  Q }" := (sigS2P A [x:A]P [x:A]Q) (at level 1).

Syntax constr level 5:
  sig_print [ (sig $c1 [$c2:$c1]$c3) ] -> [ "{" $c2 ":" $c1 " | " $c3 "}" ].

Syntax constr level 5:
  sigS_print [ (sigS $c1 [$c2:$c1]$c3) ] -> [ "{" $c2 ":" $c1 " & " $c3 "}" ].

Syntax constr level 5:
  sig2_print [ (sig2 $c1 [$c2:$c1]$c3 [$c2:$c1]$c4) ] -> [ "{" $c2 ":" $c1 " | (" $c3 ") | (" $c4 ")}" ].

Syntax constr level 5:
  sigS2_print [ (sigS2 $c1 [$c2:$c1]$c3 [$c2:$c1]$c4) ] -> [ "{" $c2 ":" $c1 " & (" $c3 ") & (" $c4 ")}" ].

Syntax constr level 5:
  cprop_hide [ (($c1) :: CProp) ] -> [ $c1:L ].

(*
Section teste.

Variable A:Set.
Variables P,Q:A->Prop.
Variables X,Y:A->CProp.

Check {x:A | (P x)}.
Check {x:A & (X x)}.
Check {x:A & (X x) & (Y x)}.
Check {x:A | (P x) | (Q x)}.
Check {x:A | (P x) & (X x)}.
Check {x:A & (X x) | (P x)}.

End teste.
*)

Hints Resolve CI : core.

Section Logical_Remarks.

(* Tex_Prose
We prove a few logical results which are helpful to have as lemmas when {\tt A}, {\tt B} and
{\tt C} are non trivial.
*)

(* Begin_Tex_Verb *)
Lemma CNot_Not_or : (A,B,C:CProp)(A->(Not C))->(B->(Not C))->~(Not A+B)->(Not C).
(* End_Tex_Verb *)
Intros.
Intro.
Apply H1.
Intro.
Elim H3.
Intro; Apply H; Auto.
Intro; Apply H0; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Cnot_not_or : (A,B:Prop;C:CProp)(A->(Not C))->(B->(Not C))->~(Not {A}+{B})->(Not C).
(* End_Tex_Verb *)
Intros.
Intro.
Apply H1.
Intro.
Elim H3.
Intro; Apply H; Auto.
Intro; Apply H0; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Cnot_Not_or : (A:Prop;B,C:CProp)(A->(Not C))->(B->(Not C))->~(Not {A}+B)->(Not C).
(* End_Tex_Verb *)
Intros.
Intro.
Apply H1.
Intro.
Elim H3.
Intro; Apply H; Auto.
Intro; Apply H0; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma CNot_not_or : (A:CProp;B:Prop;C:CProp)(A->(Not C))->(B->(Not C))->~(Not A+{B})->(Not C).
(* End_Tex_Verb *)
Intros.
Intro.
Apply H1.
Intro.
Elim H3.
Intro; Apply H; Auto.
Intro; Apply H0; Auto.
Qed.

End Logical_Remarks.

Section CRelation_Definition.
(* Tex_Prose
\section{CProp-valued Relations}
Similar to \verb!Relations.v! in Coq's standard library.
*)

(* Begin_Tex_Verb *)
Variable A: Set.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Crelation :=  A -> A -> CProp.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Variable R: Crelation.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Creflexive : CProp :=  (x: A) (R x x).
Definition Ctransitive : CProp := (x,y,z: A)(R x y)->(R y z)->(R x z).
Definition Csymmetric : CProp :=  (x,y: A) (R x y) -> (R y x).
Definition Cequiv : CProp := Creflexive *
                                   (Ctransitive * Csymmetric).
(* End_Tex_Verb *)

End CRelation_Definition.

(* Begin_Tex_Verb *)
Inductive eqs [A : Set; x: A] :A->CProp := Crefl_equal :(eqs A x x).
(* End_Tex_Verb *)

(*
Section Set_equality.

* Tex_Prose
\begin{convention} Let \verb!A! be a set and \verb!x,y:A!.
\end{convention}
*

 Variable A: Set.
 Variable x,y: A.

* Begin_Tex_Verb *
Lemma toCProp_eq:(x=y)->(eqs ? x y).
* End_Tex_Verb *
Proof.
 Intros.
 Apply (eq_rec A x [a:A](eqs ? x a)).
 Apply Crefl_equal.
 Assumption.
Qed.

* Begin_Tex_Verb *
Lemma Set_eq_to:(eqs ? x y)->(x=y).
* End_Tex_Verb *
Proof.
 Intros.
 Apply (eqs_ind A x [a:A;H:(eqs A x a)](x=a)).
 Apply refl_equal.
 Assumption.
Qed.

End Set_equality.

* Begin_Tex_Verb *
Theorem Set_sym_equal:(A:Set;x,y:A)(eqs ? x y)->(eqs ? y x).
* End_Tex_Verb *
Proof.
 Intros.
 Apply toCProp_eq.
 Apply sym_equal.
 Apply Set_eq_to.
 Assumption.
Qed.

* Begin_Tex_Verb *
Theorem Set_trans_equal:(A:Set; x,y,z:A)(eqs ? x y)->(eqs ? y z)->(eqs ? x z).
* End_Tex_Verb *
Proof.
 Intros.
 Apply toCProp_eq.
 Apply trans_equal with y.
 Apply Set_eq_to.
 Assumption.
 Apply Set_eq_to.
 Assumption.
Qed.
*)

Section le_odd.

(* Tex_Prose
\section{The relation {\tt le}, {\tt lt}, {\tt odd} and {\tt even}}
*)

(* Begin_Tex_Verb *)
Inductive Cle [n:nat] : nat -> CProp
    := Cle_n : (Cle n n)
     | Cle_S : (m:nat)(Cle n m)->(Cle n (S m)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Theorem Cnat_double_ind : (R:nat->nat->CProp)
     ((n:nat)(R O n)) -> ((n:nat)(R (S n) O))
     -> ((n,m:nat)(R n m)->(R (S n) (S m)))
     -> (n,m:nat)(R n m).
(* End_Tex_Verb *)
Proof.
  Induction n; Auto.
  Induction m; Auto.
Qed.

(* Begin_Tex_Verb *)
Theorem my_Cle_ind : (n:nat; P:(nat->CProp))
        (P n)
        ->((m:nat)(Cle n m)->(P m)->(P (S m)))
        ->(n0:nat)(Cle n n0)->(P n0).
(* End_Tex_Verb *)
Intros n P.
Generalize (Cle_rec n [n0:nat][H:(Cle n n0)](P n0)); Intro.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Theorem Cle_n_S : (n,m:nat)(Cle n m)->(Cle (S n) (S m)).
(* End_Tex_Verb *)
Intros n m H.
Pattern m.
Apply (my_Cle_ind n).

Apply Cle_n.

Intros.
Apply Cle_S.
Assumption.

Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma toCle : (m,n:nat)(le m n)->(Cle m n).
(* End_Tex_Verb *)
Intros m.
Induction m.

Induction n.

Intro H.
Apply Cle_n.

Intros n0 H H0.
Apply Cle_S.
Apply H.
Apply le_O_n.

Induction n.

Intro.
ElimType False.
Inversion H.

Intros n0 H H0.
Generalize (le_S_n ?? H0); Intro H1.
Generalize (Hrecm ? H1); Intro H2.
Apply Cle_n_S.
Assumption.
Qed.

Hints Resolve toCle.

(* Begin_Tex_Verb *)
Lemma Cle_to : (m,n:nat)(Cle m n)->(le m n).
(* End_Tex_Verb *)
Intros m n H.
Elim H.

Apply le_n.

Intros m0 s H0.
Apply le_S.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Definition Clt [m,n:nat] := (Cle (S m) n) : CProp.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma toCProp_lt : (m,n:nat)(lt m n)->(Clt m n).
(* End_Tex_Verb *)
Unfold lt.
Unfold Clt.
Intros m n H.
Apply toCle.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Clt_to : (m,n:nat)(Clt m n)->(lt m n).
(* End_Tex_Verb *)
Unfold lt.
Unfold Clt.
Intros m n H.
Apply Cle_to.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Cle_le_S_eq : (p,q:nat)(le p q)->{le (S p) q}+{p=q}.
(* End_Tex_Verb *)
Intros p q H.
Elim (gt_eq_gt_dec p q); Intro H0.

Elim H0; Auto.

ElimType False.
Apply lt_not_le with q p; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Cnat_total_order : (m,n: nat) ~ m=n -> {lt m n} + {lt n m}.
(* End_Tex_Verb *)
Intros m n H.
Elim (gt_eq_gt_dec m n).
Intro H0.

Elim H0; Intros.

Left; Auto.

ElimType False.
Auto.

Auto.
Qed.

(* Begin_Tex_Verb *)
Mutual Inductive
      Codd : nat->CProp :=
                Codd_S : (n:nat)(Ceven n)->(Codd (S n))
  with
      Ceven : nat->CProp :=
        Ceven_O : (Ceven (0)) |
        Ceven_S : (n:nat)(Codd n)->(Ceven (S n)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Codd_even_to :
             (n:nat)((Codd n)->(odd n)) /\ ((Ceven n) -> (even n)).
(* End_Tex_Verb *)
Induction n.

Split.

Intro H.
Inversion H.

Intro.
Apply even_O.

Intros n0 H.
Elim H; Intros H0 H1.
Split.

Intro H2.
Inversion H2.
Apply odd_S.
Apply H1.
Assumption.

Intro H2.
Inversion H2.
Apply even_S.
Apply H0.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Codd_to : (n:nat)(Codd n)->(odd n).
(* End_Tex_Verb *)
Intros n H.
Elim (Codd_even_to n); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Ceven_to : (n:nat)(Ceven n) -> (even n).
(* End_Tex_Verb *)
Intros n H.
Elim (Codd_even_to n); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma to_Codd_even :
             (n:nat)((odd n)->(Codd n)) * ((even n)->(Ceven n)).
(* End_Tex_Verb *)
Induction n.

Split.

Intro H.
ElimType False.
Inversion H.

Intro H.
Apply Ceven_O.

Intros n0 H.
Elim H; Intros H0 H1.
Split.

Intro H2.
Apply Codd_S.
Apply H1.
Inversion H2.
Assumption.

Intro H2.
Apply Ceven_S.
Apply H0.
Inversion H2.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma to_Codd : (n:nat)(odd n)->(Codd n).
(* End_Tex_Verb *)
Intros.
Elim (to_Codd_even n); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma to_Ceven : (n:nat)(even n)->(Ceven n).
(* End_Tex_Verb *)
Intros.
Elim (to_Codd_even n); Auto.
Qed.

End le_odd.

Section Misc.

(* Tex_Prose
\section{Miscellaneous}
*)

(* Begin_Tex_Verb *)
Lemma CZ_exh : (z:Z){n:nat | z=n} + {n:nat | z=`-n`}.
(* End_Tex_Verb *)
Intro z.
Elim z.

Left.
Exists O.
Auto.

Intro p.
Left.
Exists (convert p).
Rewrite convert_is_POS.
Reflexivity.

Intro p.
Right.
Exists (convert p).
Rewrite min_convert_is_NEG.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma Cnats_Z_ind :
              (P:Z->CProp)((n:nat)(P n)) -> ((n:nat)(P `-n`)) -> (z:Z)(P z).
(* End_Tex_Verb *)
Intros P H H0 z.
Elim (CZ_exh z); Intros H1.

Elim H1; Intros n H2.
Rewrite H2.
Apply H.

Elim H1; Intros n H2.
Rewrite H2.
Apply H0.
Qed.

(* Begin_Tex_Verb *)
Lemma Cdiff_Z_ind : (P:Z->CProp)((m,n:nat)(P `m-n`)) -> ((z:Z)(P z)).
(* End_Tex_Verb *)
Intros P H z.
Apply Cnats_Z_ind.

Intro n.
Replace (inject_nat `n`) with `n-O`.
Apply H.
Simpl.
Auto with zarith.

Intro n.
Replace `-n` with `O-n`.
Apply H.
Simpl.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma Cpred_succ_Z_ind : (P:Z->CProp)(P `0`) ->
                                   ((n:Z)(P n)->(P `n+1`)) ->
                                   ((n:Z)(P n)->(P `n-1`)) ->
                                   (z:Z)(P z).
(* End_Tex_Verb *)
Intros P H H0 H1 z.
Apply Cnats_Z_ind.

Intro n.
Elim n.

Exact H.

Intros n0 H2.
Replace ((S n0)::Z) with `n0+1`.

Apply H0.
Assumption.

Rewrite inj_S.
Reflexivity.

Intro n.
Elim n.

Exact H.

Intros n0 H2.
Replace `-(S n0)` with `-n0-1`.

Apply H1.
Assumption.

Rewrite inj_S.
Unfold Zs.
Rewrite Zopp_Zplus.
Reflexivity.
Qed.

(*
* Begin_Tex_Verb *
Lemma sum_rec_or : (A,B:Set)(S:Set)(l,r:S)(s:A+B)
                  (sum_rec A B [_:A+B]S [x:A]l [x:B]r s) = l \/
                  (sum_rec A B [_:A+B]S [x:A]l [x:B]r s) = r.
* End_Tex_Verb *
Intros. Elim s.
Intros. Left. Reflexivity.
Intros. Right. Reflexivity.
Qed.
*)

(* Begin_Tex_Verb *)
Lemma not_r_sum_rec : (A,B:Set)(S:Set)(l,r:S)(Not B)->(H:A+B)
                  (sum_rec A B [_:A+B]S [x:A]l [x:B]r H) = l.
(* End_Tex_Verb *)
Intros A B S l r H H0. Elim H0.
Intro a. Reflexivity.
Intro b. Elim H. Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma not_l_sum_rec : (A,B:Set)(S:Set)(l,r:S)(Not A)->(H:A+B)
                          (sum_rec A B [_:A+B]S [x:A]l [x:B]r H) = r.
(* End_Tex_Verb *)
Intros A B S l r H H0. Elim H0.
Intro a. Elim H. Assumption.
Intros. Reflexivity.
Qed.

End Misc.

(* Tex_Prose
\section{Results about the natural numbers}

We now define a class of predicates on a finite subset of natural numbers that will be important throughout all our work.  Essentially, these are simply setoid predicates, but for clearness we will never write them in that form but we will single out the preservation of the setoid equality.
*)

(* Begin_Tex_Verb *)
Definition nat_less_n_pred [n:nat][P:(i:nat)(lt i n)->CProp] :=
  (i,j:nat)(i=j)->(H:(lt i n))(H':(lt j n))(P i H)->(P j H').
Definition nat_less_n_pred' [n:nat][P:(i:nat)(le i n)->CProp] :=
  (i,j:nat)(i=j)->(H:(le i n))(H':(le j n))(P i H)->(P j H').
(* End_Tex_Verb *)

Section Odd_and_Even.

(* Tex_Prose
\subsection*{Odd and Even}

For our work we will many times need to distinguish cases between even or odd numbers.  We begin by proving that this case distinction is decidable:
*)

(* Tex_Prose
Next, we prove the usual results about sums of even and odd numbers:
*)

(* Begin_Tex_Verb *)
Lemma even_plus_n_n : (n:nat)(even (plus n n)).
(* End_Tex_Verb *)
Intro n; Induction n.

Auto with arith.

Replace (plus (S n) (S n)) with (S (S (plus n n))).

Apply even_S; Apply odd_S; Apply Hrecn.

Rewrite plus_n_Sm; Simpl; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma even_or_odd_plus : (k:nat)
  {j:nat & {k=(plus j j)}+{k=(S (plus j j))}}.
(* End_Tex_Verb *)
Intro k.
Elim (even_odd_dec k); Intro H.

Elim (even_2n k H); Intros j Hj; Exists j; Auto.

Elim (odd_S2n k H); Intros j Hj; Exists j; Auto.
Qed.

(* Tex_Prose
Finally, we prove that an arbitrary natural number can be written in some canonical way.
*)

(* Begin_Tex_Verb *)
Lemma even_or_odd_plus_gt : (i,j:nat)(le i j)->
  {k:nat & {j=(plus i (plus k k))}
         + {j=(plus i (S (plus k k)))}}.
(* End_Tex_Verb *)
Intros i j H.
Elim (even_or_odd_plus (minus j i)).
Intros k Hk.
Elim Hk; Intro H0.

Exists k; Left; Rewrite <- H0; Auto with arith.

Exists k; Right; Rewrite <- H0; Auto with arith.
Qed.

End Odd_and_Even.

Hints Resolve even_plus_n_n : arith.
Hints Resolve toCle : core.

Section Natural_Numbers.

(* Tex_Prose
\subsection*{Algebraic Properties}

We now present a series of trivial things proved with \verb!Omega! that are stated as lemmas to make proofs shorter and to aid in auxiliary definitions.  Giving a name to these results allows us to use them in definitions keeping conciseness.
*)

(* Begin_Tex_Verb *)
Lemma Clt_le_weak : (i,j:nat)(Clt i j)->(Cle i j).
(* End_Tex_Verb *)
Intros.
Apply toCle; Apply lt_le_weak; Apply Clt_to; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma lt_5 : (i,n:nat)(lt i n)->(lt (pred i) n).
(* End_Tex_Verb *)
Intros; Apply le_lt_trans with (pred n).
Apply le_pred; Auto with arith.
Apply lt_pred_n_n; Apply le_lt_trans with i; Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma lt_8 : (m,n:nat)(lt m (pred n))->(lt m n).
(* End_Tex_Verb *)
Intros; Apply lt_le_trans with (pred n); Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma pred_lt : (m,n:nat)(lt m (pred n))->(lt (S m) n).
(* End_Tex_Verb *)
Intros; Apply le_lt_trans with (pred n); Auto with arith.
Apply lt_pred_n_n; Apply le_lt_trans with m.
Auto with arith.
Apply lt_le_trans with (pred n); Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma lt_10 : (i,m,n:nat)(lt O i)->(lt i (pred (plus m n)))->
  (lt (pred i) (plus (pred m) (pred n))).
(* End_Tex_Verb *)
Intros; Omega.
Qed.

(* Begin_Tex_Verb *)
Lemma lt_pred' : (m,n:nat)(lt O m)->(lt m n)->
  (lt (pred m) (pred n)).
(* End_Tex_Verb *)
Intros m n H H0; Red.
NewDestruct n.

Inversion H0.

Rewrite <- (S_pred m O); Auto.
Simpl.
Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma le_1 : (m,n:nat)(Cle m n)->(le (pred m) n).
(* End_Tex_Verb *)
Intros.
Cut (le m n); [Intro | Apply Cle_to; Assumption].
Apply le_trans with (pred n); Auto with arith.
Apply le_pred; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma le_2 : (i,j:nat)(lt i j)->(le i (pred j)).
(* End_Tex_Verb *)
Intros; Omega.
Qed.

(* Begin_Tex_Verb *)
Lemma plus_eq_one_imp_eq_zero :
  (m,n:nat)(le (plus m n) (1))->{m=O}+{n=O}.
(* End_Tex_Verb *)
Intros m n H.
Elim (le_lt_dec m O); Intro.
Left; Auto with arith.
Right; Omega.
Qed.

(* Tex_Prose
We now prove some properties of functions on the natural numbers.
*)

(* Begin_Tex_Verb *)
Variable h:nat->nat.
(* End_Tex_Verb *)

(* Tex_Prose
First we characterize monotonicity by a local condition: if $h(n)<h(n+1)$ for every natural number $n$ then $h$ is monotonous.  An analogous result holds for weak monotonicity.
*)

(* Begin_Tex_Verb *)
Lemma nat_local_mon_imp_mon : ((i:nat)(lt (h i) (h (S i))))->
  (i,j:nat)(lt i j)->(lt (h i) (h j)).
(* End_Tex_Verb *)
Intros H i j H0.
Induction j.

ElimType False; Omega.

Cut (le i j); [Intro H1 | Auto with arith].
Elim (le_lt_eq_dec ?? H1); Intro H2.

Cut (lt (h i) (h j)); [Intro | Apply Hrecj; Assumption].
Cut (lt (h j) (h (S j))); [Intro | Apply H].
Apply lt_trans with (h j); Auto.

Rewrite H2; Apply H.
Qed.

(* Begin_Tex_Verb *)
Lemma nat_local_mon_imp_mon_le : ((i:nat)(le (h i) (h (S i))))->
  (i,j:nat)(le i j)->(le (h i) (h j)).
(* End_Tex_Verb *)
Intros H i j H0.
Induction j.

Cut i=O; [Intro H1 | Auto with arith].
Rewrite H1; Apply le_n.

Elim (le_lt_eq_dec ?? H0); Intro H1.

Cut (le (h i) (h j)); [Intro | Apply Hrecj; Auto with arith].
Cut (le (h j) (h (S j))); [Intro | Apply H].
Apply le_trans with (h j); Auto.

Rewrite H1; Apply le_n.
Qed.

(* Tex_Prose
A strictly increasing function is injective:
*)

(* Begin_Tex_Verb *)
Lemma nat_mon_imp_inj : ((i,j:nat)(lt i j)->(lt (h i) (h j)))->
  (i,j:nat)((h i)=(h j))->i=j.
(* End_Tex_Verb *)
Intros H i j H0.
Cut ~~i=j; [Omega | Intro H1].
Cut (lt i j)\/(lt j i); [Intro H2 | Omega].
Inversion_clear H2.

Cut (lt (h i) (h j)); [Rewrite H0; Apply lt_n_n | Apply H; Assumption].

Cut (lt (h j) (h i)); [Rewrite H0; Apply lt_n_n | Apply H; Assumption].
Qed.

(* Tex_Prose
And (not completely trivial) a function that preserves $<$ also preserves $\leq$.
*)

(* Begin_Tex_Verb *)
Lemma nat_mon_imp_mon' : ((i,j:nat)(lt i j)->(lt (h i) (h j)))->
  (i,j:nat)(le i j)->(le (h i) (h j)).
(* End_Tex_Verb *)
Intros H i j H0.
Elim (le_lt_eq_dec ?? H0); Intro H1.

Apply lt_le_weak; Apply H; Assumption.

Rewrite H1; Apply le_n.
Qed.

(* Tex_Prose
The last lemma in this section states that a monotonous function in the natural numbers completely covers the natural numbers, that is, for every $n\in\NN$ there is an $i$ such that \[h(i)\leq n<(n+1)\leq h(i+1)\]
*)

(* Begin_Tex_Verb *)
Lemma mon_fun_covers :
  ((i,j:nat)(lt i j)->(lt (h i) (h j)))->(h O)=O->
  (n:nat){k:nat | (le (S n) (h k))}->
    {i:nat | (le (h i) n) | (le (S n) (h (S i)))}.
(* End_Tex_Verb *)
Intros H H0 n H1.
Elim H1; Intros k Hk.
Induction k.

Exists O.

Rewrite H0; Auto with arith.

Cut (lt (h O) (h (1))); [Intro; Apply le_trans with (h O); Auto with arith | Apply H; Apply lt_n_Sn].

Cut (lt (h k) (h (S k))); [Intro H2 | Apply H; Apply lt_n_Sn].
Elim (le_lt_dec (S n) (h k)); Intro H3.

Elim (Hreck H3); Intros i Hi.
Exists i; Assumption.

Exists k; Auto with arith.
Qed.

End Natural_Numbers.

Section Predicates_to_CProp.

(* Tex_Prose
\subsection*{Logical Properties}

This section contains lemmas that aid in logical reasoning with natural numbers.  First, we present some principles of induction, both for \verb!CProp!- and \verb!Prop!-valued predicates.  We begin by presenting the results for \verb!CProp!-valued predicates:
*)

(* Begin_Tex_Verb *)
Lemma even_induction : (P:nat->CProp)(P O)->
  ((n:nat)(even n)->(P n)->(P (S (S n))))->
  (n:nat)(even n)->(P n).
(* End_Tex_Verb *)
Intros P H H0 n.
Pattern n; Apply lt_wf_rec.
Clear n.
Intros n H1 H2.
Induction n.

Auto.

Induction n.

ElimType False; Inversion H2; Inversion H4.

Apply H0.

Inversion H2; Inversion H4; Auto.

Apply H1.

Auto with arith.

Inversion H2; Inversion H4; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma odd_induction : (P:nat->CProp)(P (1))->
  ((n:nat)(odd n)->(P n)->(P (S (S n))))->
  (n:nat)(odd n)->(P n).
(* End_Tex_Verb *)
Intros P H H0 n; Case n.

Intro H1; ElimType False; Inversion H1.

Clear n; Intros n H1.
Pattern n; Apply even_induction; Auto.

Intros n0 H2 H3; Auto with arith.

Inversion H1; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma four_induction : (P:nat->CProp)
  (P (0))->(P (1))->(P (2))->(P (3))->
  ((n:nat)(P n)->(P (S (S (S (S n))))))->(n:nat)(P n).
(* End_Tex_Verb *)
Intros.
Apply lt_wf_rec.
Intro m.
Case m; Auto.
Clear m; Intro m.
Case m; Auto.
Clear m; Intro m.
Case m; Auto.
Clear m; Intro m.
Case m; Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma nat_complete_double_induction : (P:nat->nat->CProp)
  ((m,n:nat)
    ((m',n':nat)(lt m' m)->(lt n' n)->(P m' n'))->(P m n))->
  (m,n:nat)(P m n).
(* End_Tex_Verb *)
Intros P H m.
Pattern m; Apply lt_wf_rec; Auto with arith.
Qed.

(* Tex_Prose
For subsetoid predicates in the natural numbers we can eliminate disjunction (and existential quantification) as follows.
*)

(* Begin_Tex_Verb *)
Lemma finite_or_elim : (n:nat)(P,Q:(i:nat)(le i n)->CProp)
  (nat_less_n_pred' n P)->(nat_less_n_pred' n Q)->
  ((i:nat)(H:(le i n))((P i H)+(Q i H)))->
    ({m:nat & {Hm:(Cle m n) &
      (P m (Cle_to ?? Hm))}}+(i:nat)(H:(le i n))(Q i H)).
(* End_Tex_Verb *)
Intro n; Induction n.

Intros P Q HP HQ H.
Elim (H ? (Cle_to ?? (toCle ?? (le_n O)))); Intro H0.

Left; Exists O; Exists (toCle ?? (le_n O)); Assumption.

Right; Intros i H1.
Apply HQ with H:=(Cle_to ?? (toCle ?? (le_n O))); Auto with arith.

Intros P Q H H0 H1.
Elim (H1 ? (Cle_to ?? (toCle ?? (le_n (S n))))); Intro H2.

Left; Exists (S n); Exists (toCle ?? (le_n (S n))); Assumption.

LetTac P':=[i:nat][H:(le i n)](P i (le_S ?? H)).
LetTac Q':=[i:nat][H:(le i n)](Q i (le_S ?? H)).
Cut {m:nat & {Hm:(Cle m n) & (P' m (Cle_to m n Hm))}}+(i:nat)(H:(le i n))(Q' i H).

Intro H3; Elim H3; Intro H4.

Left.
Elim H4; Intros m Hm; Elim Hm; Clear H4 Hm; Intros Hm Hm'.
Exists m.
Unfold P' in Hm'.
Exists (Cle_S ?? Hm).
EApply H with i:=m; [Omega | Apply Hm'].

Right.
Intros i H5.
Unfold Q' in H4.
Elim (le_lt_eq_dec ?? H5); Intro H6.

Cut (le i n); [Intro | Auto with arith].
EApply H0 with i:=i; [Auto with arith | Apply (H4 i H7)].

EApply H0 with i:=(S n); [Auto with arith | Apply H2].

Apply Hrecn.
Intro i; Intros j H3 H4 H5 H6.
Unfold P'.
Exact (H ?? H3 ?? H6).

Intro i; Intros j H3 H4 H5 H6.
Unfold Q'.
Exact (H0 ?? H3 ?? H6).

Intros i H3.
Unfold P' Q'; Apply H1.
Qed.

(* Begin_Tex_Verb *)
Lemma str_finite_or_elim : (n:nat)(P,Q:(i:nat)(le i n)->CProp)
  (nat_less_n_pred' ? P)->(nat_less_n_pred' ? Q)->
  ((i:nat)(H:(le i n))((P i H)+(Q i H)))->
  {j:nat & {Hj:(Cle j n) &
    (P j (Cle_to ?? Hj))*(j':nat)
      (Hj':(le j' n))(lt j' j)->(Q j' Hj')}}+
    (i:nat)(H:(le i n))(Q i H).
(* End_Tex_Verb *)
Intro n; Induction n.
Intros P Q H H0 H1.
Elim (H1 O (le_n O)); Intro HPQ.

Left.
Exists O; Exists (toCle ?? (le_n O)).
Split.

Apply H with H:=(le_n O); Auto.
Intros; ElimType False; Inversion H2.

Right; Intros.
Apply H0 with H:=(le_n O); Auto with arith.

Intros P Q H H0 H1.
LetTac P':=[i:nat][H:(le i n)](P i (le_S ?? H)).
LetTac Q':=[i:nat][H:(le i n)](Q i (le_S ?? H)).
Elim (Hrecn P' Q').

Intro H2.
Left.
Elim H2; Intros m Hm; Elim Hm; Clear H2 Hm; Intros Hm Hm'.
Exists m.
Unfold P' in Hm'.
Exists (Cle_S ?? Hm).
Elim Hm'; Clear Hm'; Intros Hm' Hj.
Split.

EApply H with i:=m; [Auto with arith | Apply Hm'].

Unfold Q' in Hj; Intros j' Hj' H2.
Cut (le m n); [Intro H3 | Exact (Cle_to ?? Hm)].
Cut (le j' n); [Intro H4 | Apply le_trans with m; Auto with arith].
Apply H0 with H:=(le_S ?? H4); [Auto | Apply Hj; Assumption].

Elim (H1 (S n) (Cle_to ?? (toCle ?? (le_n (S n))))); Intro H1'.

Intro H2.
Left; Exists (S n); Exists (toCle ?? (le_n (S n))); Split.

Assumption.

Intros j' Hj' H3; Unfold Q' in H1'.
Cut (le j' n); [Intro H4 | Auto with arith].
Unfold Q' in H2.
Apply H0 with H:=(le_S ?? H4); Auto.

Intro H2.
Right; Intros i H3.
Unfold Q' in H1'.
Elim (le_lt_eq_dec ?? H3); Intro H4.

Cut (le i n); [Intro H5 | Auto with arith].
Unfold Q' in H2.
Apply H0 with H:=(le_S ?? H5); Auto.

Apply H0 with H:=(Cle_to ?? (toCle ?? (le_n (S n)))); Auto.

Intro i; Intros j H2 H3 H4 H5.
Unfold P'.
Exact (H ?? H2 ?? H5).

Intro i; Intros j H2 H3 H4 H5.
Unfold Q'.
Exact (H0 ?? H2 ?? H5).

Intros i H2.
Unfold P' Q'.
Apply H1.
Qed.

End Predicates_to_CProp.

Section Predicates_to_Prop.

(* Tex_Prose
Finally, analogous results for \verb!Prop!-valued predicates are presented for completeness' sake.
*)

(* Begin_Tex_Verb *)
Lemma even_ind : (P:nat->Prop)(P O)->
  ((n:nat)(even n)->(P n)->(P (S (S n))))->
  (n:nat)(even n)->(P n).
(* End_Tex_Verb *)
Intros P H H0 n.
Pattern n; Apply lt_wf_ind.
Clear n.
Intros n H1 H2.
Induction n.

Auto.

Induction n.

ElimType False; Inversion H2; Inversion H4.

Apply H0.

Inversion H2; Inversion H4; Auto.

Apply H1.

Auto with arith.
Inversion H2; Inversion H4; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma odd_ind : (P:nat->Prop)(P (1))->
  ((n:nat)(P n)->(P (S (S n))))->
  (n:nat)(odd n)->(P n).
(* End_Tex_Verb *)
Intros P H H0 n; Case n.

Intro H1; ElimType False; Inversion H1.

Clear n; Intros n H1.
Pattern n; Apply even_ind; Auto.
Inversion H1; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma nat_complete_double_ind : (P:nat->nat->Prop)
  ((m,n:nat)
    ((m',n':nat)(lt m' m)->(lt n' n)->(P m' n'))->(P m n))->
  (m,n:nat)(P m n).
(* End_Tex_Verb *)
Intros P H m.
Pattern m; Apply lt_wf_ind; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma four_ind : (P:nat->Prop)
  (P (0))->(P (1))->(P (2))->(P (3))->
  ((n:nat)(P n)->(P (S (S (S (S n))))))->(n:nat)(P n).
(* End_Tex_Verb *)
Intros.
Apply lt_wf_ind.
Intro m.
Case m; Auto.
Clear m; Intro m.
Case m; Auto.
Clear m; Intro m.
Case m; Auto.
Clear m; Intro m.
Case m; Auto with arith.
Qed.

End Predicates_to_Prop.

(* Tex_Prose
\section{Integers}

Similar results for integers.
*)

(* FIXME *)
Grammar tactic simple_tactic : tactic :=
  elimcompare
  [ "ElimCompare" constrarg($c) constrarg($d) ] -> [ (ElimCompare $c $d) ].

(* Begin_Tex_Verb *)
Definition Zlts:=[x,y:Z](eqs fast_integer.relation (Zcompare x y) INFERIEUR).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma toCProp_Zlt:(x,y:Z)`x < y`->(Zlts x y).
(* End_Tex_Verb *)
Proof.
 Intros x y H.
 Unfold Zlts.
 Unfold Zlt in H.
 Rewrite H.
 Apply Crefl_equal.
Qed.

(* Begin_Tex_Verb *)
Lemma CZlt_to:(x,y:Z)(Zlts x y)->`x<y`.
(* End_Tex_Verb *)
Proof.
 Intros x y H.
 Unfold Zlt.
 Inversion H.
 Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Zsgn_1:(x:Z){`(Zsgn x)=0`}+{`(Zsgn x)=1`}+{`(Zsgn x)=(-1)`}.
(* End_Tex_Verb *)
Proof.
Intro x.
Case x.

Left.
Left.
Unfold Zsgn.
Reflexivity.

Intro p.
Simpl.
Left.
Right.
Reflexivity.

Intro p.
Right.
Simpl.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma Zsgn_2:(x:Z)`(Zsgn x)=0`->`x=0`.
(* End_Tex_Verb *)
Proof.
 Intro x.
 Case x.

 Intro H.
 Reflexivity.

 Intros p H.
 Inversion H.

 Intros p H.
 Inversion H.
Qed.

(* Begin_Tex_Verb *)
Lemma Zsgn_3:(x:Z)`x<>0`->`(Zsgn x)<>0`.
(* End_Tex_Verb *)
Proof.
 Intro x.
 Case x.

 Intro H.
 Elim H.
 Reflexivity.

 Intros p H.
 Simpl.
 Discriminate.

 Intros p H.
 Simpl.
 Discriminate.
Qed.

(* Tex_Prose
The following have unusual names, in line with the series of ZLn lemmata in {\tt fast\_integers.v}.
*)

(* Begin_Tex_Verb *)
Lemma  ZL9: (p:positive)(inject_nat (convert p))=(POS p).
(* End_Tex_Verb *)
Proof.
Intro p.
Elim (ZL4 p).
Intros x H0.
Rewrite H0.
Unfold inject_nat.
Apply f_equal with A:=positive B:=Z f:=POS.
Cut ((anti_convert (convert p))=(anti_convert (S x))).

Intro H1.
Rewrite bij2 in H1.
Cut ((sub_un  (add_un p))=(sub_un (anti_convert (S x)))).

Intro H2.
Rewrite sub_add_one in H2.
Simpl in H2.
Rewrite sub_add_one in H2.
Auto.

Apply f_equal with A:=positive B:=positive f:=sub_un.
Assumption.

Apply f_equal with f:=anti_convert.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Theorem Zsgn_4:(a:Z)`a=(Zsgn a)*(absolu a)`.
(* End_Tex_Verb *)
Proof.
 Intro a.
 Case a.

 Simpl.
 Reflexivity.

 Intro p.
 Unfold Zsgn.
 Unfold absolu.
 Rewrite Zmult_1_n.
 Symmetry.
 Apply ZL9.

 Intro p.
 Unfold Zsgn.
 Unfold absolu.
 Rewrite ZL9.
 Constructor.
Qed.

(* Begin_Tex_Verb *)
Theorem Zsgn_5: (a,b,x,y:Z)`x<>0`->`y<>0`->
                 `(Zsgn a)*x=(Zsgn b)*y`->`(Zsgn a)*y=(Zsgn b)*x`.
(* End_Tex_Verb *)
Proof.
 Intros a b x y H H0.
 Case a.

 Case b.

  Simpl.
  Trivial.

  Intro p.
  Unfold Zsgn.
  Intro H1.
  Rewrite Zmult_1_n in H1.
  Simpl in H1.
  Elim H0.
  Auto.

  Intro p.
  Unfold Zsgn.
  Intro H1.
  Elim H0.
  Apply Zopp_intro.
  Simpl.
  Transitivity `(-1)*y`; Auto.

 Intro p.
 Unfold 1 Zsgn.
 Unfold 2 Zsgn.
 Intro H1.
 Transitivity y.

 Rewrite Zmult_1_n.
 Reflexivity.

 Transitivity `(Zsgn b)*((Zsgn b)*y)`.

 Case (Zsgn_1 b).

  Intro H2.
  Case H2.

  Intro H3.
  Elim H.
  Rewrite H3 in H1.
  Change `1*x=0` in H1.
  Rewrite Zmult_1_n in H1.
  Assumption.

  Intro H3.
  Rewrite H3.
  Rewrite Zmult_1_n.
  Rewrite Zmult_1_n.
  Reflexivity.

  Intro H2.
  Rewrite H2.
  Ring.

 Rewrite Zmult_1_n in H1.
 Rewrite H1.
 Reflexivity.

 Intro p.
 Unfold 1 Zsgn.
 Unfold 2 Zsgn.
 Intro H1.
 Transitivity `(Zsgn b)*((-1)*((Zsgn b)*y))`.

 Case (Zsgn_1 b).
  Intro H2.
  Case H2.

  Intro H3.
  Elim H.
  Apply Zopp_intro.
  Transitivity `(-1)*x`.

  Ring.
  Unfold Zopp.
  Rewrite H3 in H1.
  Transitivity `0*y`; Auto.

  Intro H3.
  Rewrite H3.
  Ring.

 Intro H2.
 Rewrite H2.
 Ring.

 Rewrite <- H1.
 Ring.
Qed.

(* Begin_Tex_Verb *)
Lemma nat_nat_pos:(m,n:nat)`(m+1)*(n+1)>0`.
(* End_Tex_Verb *)
Proof.
Intros m n.
Apply Zlt_gt.
Cut (`(inject_nat m)+1>0`).

Intro H.
Cut(`0<(inject_nat n)+1`).

Intro H0.
Cut (`(((inject_nat m)+1)*0) < ((inject_nat m)+1)*((inject_nat n)+1)`).

Rewrite Zero_mult_right.
Auto.

Apply Zlt_reg_mult_l; Auto.

Change (`0<(Zs (inject_nat n))`).
Apply Zle_lt_n_Sm.
Change (`(inject_nat O) <= (inject_nat n)`).
Apply inj_le.
Apply le_O_n.

Apply Zlt_gt.
Change (`0<(Zs (inject_nat m))`).
Apply Zle_lt_n_Sm.
Change (`(inject_nat O) <= (inject_nat m)`).
Apply inj_le.
Apply le_O_n.
Qed.

(* Begin_Tex_Verb *)
Theorem S_predn:(m:nat)(~(m=O))->(S (pred m))=m.
(* End_Tex_Verb *)
Proof.
Intros m H.
Symmetry.
Apply S_pred with O.
Omega.
Qed.

(* Begin_Tex_Verb *)
Lemma absolu_1:(x:Z)((absolu x)=O)->(`x=0`).
(* End_Tex_Verb *)
Proof.
Intros x H.
Case (dec_eq x `0`).

Auto.

Intro H0.
Apply False_ind.

ElimCompare x `0`.

Intro H2.
Apply H0.
Elim (Zcompare_EGAL x O).
Intros H3 H4.
Auto.

Intro H2.
Cut ((EX h:nat| (absolu x)=(S h))).

Intro H3.
Case H3.
Rewrite H.
Exact O_S.

Change (`x<0`) in H2.
LetTac H3:=(Zlt_gt ?? H2).
Elim (SUPERIEUR_POS ?? H3).
Intros x0 H5.
Cut (EX q:positive |x=(NEG q)).

Intro H6.
Case H6.
Intros x1 H7.
Rewrite H7.
Unfold absolu.
Generalize x1.
Exact ZL4.

Cut (x=(Zopp (POS x0))).

Simpl.
Intro H6.
Exists x0.
Assumption.
Rewrite <- (Zopp_Zopp x).
Exact (f_equal Z Z Zopp `-x` (POS x0) H5).

Intro H2.
Cut ((EX h:nat| (absolu x)=(S h))).

Intro H3.
Case H3.
Rewrite H.
Exact O_S.

Elim (SUPERIEUR_POS ?? H2).
Simpl.
Rewrite Zero_right.
Intros x0 H4.
Rewrite H4.
Unfold absolu.
Generalize x0.
Exact ZL4.
Qed.

(* Begin_Tex_Verb *)
Lemma absolu_2: (x:Z)(`x<>0`)->(~((absolu x)=O)).
(* End_Tex_Verb *)
Proof.
Intros x H.
Intro H0.
Apply H.
Apply absolu_1.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Zgt_mult_conv_absorb_l: (a,x,y:Z)`a<0`->`a*x>a*y`->`x<y`.
(* End_Tex_Verb *)
Proof.
Intros a x y H H0.
Case (dec_eq x y).

Intro H1.
Apply False_ind.
Rewrite H1 in H0.
Cut (`a*y=a*y`).

Change (`a*y<>a*y`).
Apply Zgt_not_eq.
Assumption.

Trivial.

Intro H1.
Case (not_Zeq x y H1).

Trivial.

Intro H2.
Apply False_ind.
Cut (`a*y>a*x`).

Apply Zgt_not_sym with m:=`a*y` n:=`a*x`.
Assumption.

Apply Zlt_conv_mult_l.
Assumption.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Zgt_mult_reg_absorb_l:(a,x,y:Z)`a>0`->`a*x>a*y`->`x>y`.
(* End_Tex_Verb *)
Proof.
Intros a x y H H0.
Cut (`(-a)<(Zopp 0)`).

Rewrite <- (Zopp_Zopp a) in H.
Rewrite <- (Zopp_Zopp `0`) in H.

Simpl.
Intro H1.
Rewrite <- (Zopp_Zopp x).
Rewrite <- (Zopp_Zopp y).
Apply Zlt_opp.
Apply Zgt_mult_conv_absorb_l with a:=`-a` x:=`-x`.

Assumption.

Rewrite Zopp_Zmult.
Rewrite Zopp_Zmult.
Apply Zlt_opp.
Rewrite <- Zopp_Zmult_r.
Rewrite <- Zopp_Zmult_r.
Apply Zgt_lt.
Apply Zlt_opp.
Apply Zgt_lt.
Assumption.

Omega.
Qed.

(* Begin_Tex_Verb *)
Lemma Zmult_Sm_Sn:(m,n:Z)`(m+1)*(n+1)=m*n+(m+n)+1`.
(* End_Tex_Verb *)
Proof.
Intros.
Ring.
Qed.


(** * [HLevel(n)] is of hlevel n+1 *)

(**
   Authors: Benedikt Ahrens, Chris Kapulkin
   Title: HLevel(n) is of hlevel n+1
   Date: December 2012
*)

(**
   In this file we prove the main result of this work:
   the type of types of hlevel n is itself of hlevel n+1.
*)

Require Import Foundations.hlevel1.hProp.
Require Import Foundations.Proof_of_Extensionality.funextfun.

Require Import RezkCompletion.auxiliary_lemmas_HoTT.

(** As before, we use an infix notation for the path space. *)
Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.

(** ** Weak equivalence between identity types in [HLevel] and [U] *)

(** To show that HLevel(n) is of hlevel n + 1, we need to show that
    its path spaces are of hlevel n.

    First, we show that each of its path spaces equivalent to the
     path space of the underlying types.

    More generally, we prove this for any predicate [P : UU -> hProp]
    which we later instantiate with [P := isofhlevel n].
*)

(** Overview of the proof:
   Identity of Sigmas <~> Sigma of Identities <~> Identities in [U] ,
   where the first equivalence is called [weq1] and the second one
   is called [weq2].
*)

Lemma weq1  (P : UU -> hProp) (X X' : UU) (pX : P X) (pX' : P X') :
   weq (tpair _ X pX == tpair (fun x => P x) X' pX')
       (total2 (fun w : X == X' => transportf (fun x => P x) w pX == pX')).
Proof.
  apply total_paths_equiv.
Defined.

(** This helper lemma is needed to show that our fibration
    is indeed a predicate, so that we can instantiate
    the hProposition [P] with this fibration.
*)

Lemma ident_is_prop : forall (P : UU -> hProp) (X X' : UU)
      (pX : P X) (pX' : P X') (w : X == X'),
   isaprop (transportf (fun X => P X) w pX == pX').
Proof.
  intros P X X' pX pX' w.
  apply isapropifcontr.
  apply (pr2 (P X')).
Defined.

(** We construct the equivalence [weq2] as a projection
    from a total space, which, by the previous lemma, is
    a weak equivalence.
*)

Lemma weq2 (P : UU -> hProp) (X X' : UU)
      (pX : P X) (pX' : P X') :
  weq (total2 (fun w : X == X' =>
              transportf (fun x => P x) w pX == pX'))
      (X == X').
Proof.
  exists (@pr1 (X == X') (fun w : X == X' =>
            (transportf (fun x : UU => P x) w pX)  == pX' )).
  set (H' := isweqpr1_UU X X'
        (fun w : X == X' =>
      (transportf (fun X => P X) w pX == pX') )).
  simpl in H'.
  apply H'.
  intro z.
  apply (pr2 (P X')).
Defined.

(**  Composing [weq1] and [weq2] yields the desired
     weak equivalence.
*)

Lemma Id_p_weq_Id (P : UU -> hProp) (X X' : UU)
      (pX : P X) (pX' : P X') :
 weq ((tpair _ X pX) == (tpair (fun x => P x) X' pX')) (X == X').
Proof.
  set (f := weq1 P X X' pX pX').
  set (g := weq2 P X X' pX pX').
  set (fg := weqcomp f g).
  exact fg.
Defined.

(** ** Hlevel of path spaces *)

(**  We show that if [X] and [X'] are of hlevel [n], then so is their
      identity type [X == X'].
*)
(** The proof works differently for [n == 0] and [n == S n'],
    so we treat these two cases in separate lemmas
    [isofhlevel0pathspace] and [isofhlevelSnpathspace] and put them
    together in the lemma [isofhlevelpathspace].
*)

(** *** The case [n == 0] *)

Lemma isofhlevel0weq (X Y : UU) :
    iscontr X -> iscontr Y -> weq X Y.
Proof.
  intros pX pY.
  set (wX := wequnittocontr pX).
  set (wY := wequnittocontr pY).
  exact (weqcomp (invweq wX) wY).
Defined.

Lemma isofhlevel0pathspace (X Y : UU) :
    iscontr X -> iscontr Y -> iscontr (X == Y).
Proof.
  intros pX pY.
  set (H := isofhlevelweqb 0 (tpair _ _ (univalenceaxiom X Y))).
  apply H.
  exists (isofhlevel0weq _ _ pX pY ).
  intro f.
  assert (H' : pr1 f == pr1 (isofhlevel0weq X Y pX pY)).
    apply funextfun.
    simpl. intro x.
    apply (pr2 pY).
  apply (total2_paths H').
  apply proofirrelevance.
  apply isapropisweq.
Defined.

(** *** The case [n == S n'] *)

Lemma isofhlevelSnpathspace : forall n : nat, forall X Y : UU,
      isofhlevel (S n) Y -> isofhlevel (S n) (X == Y).
Proof.
  intros n X Y pY.
  set (H:=isofhlevelweqb (S n) (tpair _ _ (univalenceaxiom X Y))).
  apply H.
  assert (H' : isofhlevel (S n) (X -> Y)).
    apply impred.
    intro x. assumption.
  assert (H2 : isincl (@pr1 (X -> Y) (fun f => isweq f))).
    apply isofhlevelfpr1.
    intro f. apply isapropisweq.
  apply (isofhlevelsninclb _ _ H2).
  assumption.
Defined.

(** ** The lemma itself *)

Lemma isofhlevelpathspace : forall n : nat, forall X Y : UU,
      isofhlevel n X -> isofhlevel n Y -> isofhlevel n (X == Y).
Proof.
  intros n.
  case n.
    intros X Y pX pY.
    apply isofhlevel0pathspace;
    assumption.
    intros.
    apply isofhlevelSnpathspace;
    assumption.
Defined.

(** ** HLevel *)

(** We define the type [HLevel n] of types of hlevel n. *)

Definition HLevel n := total2 (fun X : UU => isofhlevel n X).

(** * Main theorem: [HLevel n] is of hlevel [S n] *)

Lemma hlevel_of_hlevels : forall n,
      isofhlevel (S n) (HLevel n).
Proof.
  intro n.
  simpl.
  intros [X pX] [X' pX'].
  set (H := isofhlevelweqb n
       (Id_p_weq_Id (fun X => tpair (fun X => isaprop X) (isofhlevel n X)
                               (isapropisofhlevel _ _)) X X' pX pX')).
  apply H.
  apply isofhlevelpathspace;
  assumption.
Defined.

(** ** Aside: Univalence for predicates and hlevels *)

(** As a corollary from [Id_p_weq_Id],
    we obtain a version of the Univalence Axiom for
    predicates on the universe [U].
    In particular, we can instantiate this predicate with
    [isofhlevel n].
*)

Lemma UA_for_Predicates (P : UU -> hProp) (X X' : UU)
     (pX : P X) (pX' : P X') :
  weq ((tpair _ X pX) == (tpair (fun x => P x) X' pX')) (weq X X').
Proof.
  set (f := Id_p_weq_Id P X X' pX pX').
  set (g := tpair _ _ (univalenceaxiom X X')).
  exact (weqcomp f g).
Defined.

Corollary UA_for_HLevels : forall (n : nat)
      (X X' : HLevel n),
     weq (X == X') (weq (pr1 X) (pr1 X')).
Proof.
  intros n [X pX] [X' pX'].
  simpl.
  apply (UA_for_Predicates
       (fun X => tpair (fun X => isaprop X) (isofhlevel n X)
                                      (isapropisofhlevel _ _))).
Defined.


From iris.algebra Require Export ofe.
From iris.prelude Require Import options.

Section language_mixin.
  Context {expr val state observation : Type}.
  Context (of_val : val → expr).
  Context (to_val : expr → option val).
  (** We annotate the reduction relation with observations [κ], which we will
     use in the definition of weakest preconditions to predict future
     observations and assert correctness of the predictions. *)
  Context (prim_step : expr → state → list observation → expr → state → list expr → Prop).

  Record LanguageMixin := {
    mixin_to_of_val v : to_val (of_val v) = Some v;
    mixin_of_to_val e v : to_val e = Some v → of_val v = e;
    mixin_val_stuck e σ κ e' σ' efs : prim_step e σ κ e' σ' efs → to_val e = None
  }.
End language_mixin.

Structure language := Language {
  expr : Type;
  val : Type;
  state : Type;
  observation : Type;
  of_val : val → expr;
  to_val : expr → option val;
  prim_step : expr → state → list observation → expr → state → list expr → Prop;
  language_mixin : LanguageMixin of_val to_val prim_step
}.

Declare Scope expr_scope.
Delimit Scope expr_scope with E.
Bind Scope expr_scope with expr.

Declare Scope val_scope.
Delimit Scope val_scope with V.
Bind Scope val_scope with val.

Global Arguments Language {_ _ _ _ _ _ _} _.
Global Arguments of_val {_} _.
Global Arguments to_val {_} _.
Global Arguments prim_step {_} _ _ _ _ _ _.

Canonical Structure stateO Λ := leibnizO (state Λ).
Canonical Structure valO Λ := leibnizO (val Λ).
Canonical Structure exprO Λ := leibnizO (expr Λ).

Definition cfg (Λ : language) := (list (expr Λ) * state Λ)%type.

Class LanguageCtx {Λ : language} (K : expr Λ → expr Λ) := {
  fill_not_val e :
    to_val e = None → to_val (K e) = None;
  fill_step e1 σ1 κ e2 σ2 efs :
    prim_step e1 σ1 κ e2 σ2 efs →
    prim_step (K e1) σ1 κ (K e2) σ2 efs;
  fill_step_inv e1' σ1 κ e2 σ2 efs :
    to_val e1' = None → prim_step (K e1') σ1 κ e2 σ2 efs →
    ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 κ e2' σ2 efs
}.

Global Instance language_ctx_id Λ : LanguageCtx (@id (expr Λ)).
Proof. constructor; naive_solver. Qed.

Inductive atomicity := StronglyAtomic | WeaklyAtomic.

Section language.
  Context {Λ : language}.
  Implicit Types v : val Λ.
  Implicit Types e : expr Λ.

  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. apply language_mixin. Qed.
  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof. apply language_mixin. Qed.
  Lemma val_stuck e σ κ e' σ' efs : prim_step e σ κ e' σ' efs → to_val e = None.
  Proof. apply language_mixin. Qed.

  Definition reducible (e : expr Λ) (σ : state Λ) :=
    ∃ κ e' σ' efs, prim_step e σ κ e' σ' efs.
  (* Total WP only permits reductions without observations *)
  Definition reducible_no_obs (e : expr Λ) (σ : state Λ) :=
    ∃ e' σ' efs, prim_step e σ [] e' σ' efs.
  Definition irreducible (e : expr Λ) (σ : state Λ) :=
    ∀ κ e' σ' efs, ¬prim_step e σ κ e' σ' efs.
  Definition stuck (e : expr Λ) (σ : state Λ) :=
    to_val e = None ∧ irreducible e σ.
  Definition not_stuck (e : expr Λ) (σ : state Λ) :=
    is_Some (to_val e) ∨ reducible e σ.

  (* [Atomic WeaklyAtomic]: This (weak) form of atomicity is enough to open
     invariants when WP ensures safety, i.e., programs never can get stuck.  We
     have an example in lambdaRust of an expression that is atomic in this
     sense, but not in the stronger sense defined below, and we have to be able
     to open invariants around that expression.  See `CasStuckS` in
     [lambdaRust](https://gitlab.mpi-sws.org/FP/LambdaRust-coq/blob/master/theories/lang/lang.v).

     [Atomic StronglyAtomic]: To open invariants with a WP that does not ensure
     safety, we need a stronger form of atomicity.  With the above definition,
     in case `e` reduces to a stuck non-value, there is no proof that the
     invariants have been established again. *)
  Class Atomic (a : atomicity) (e : expr Λ) : Prop :=
    atomic σ e' κ σ' efs :
      prim_step e σ κ e' σ' efs →
      if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e').

  Inductive step (ρ1 : cfg Λ) (κ : list (observation Λ)) (ρ2 : cfg Λ) : Prop :=
    | step_atomic e1 σ1 e2 σ2 efs t1 t2 :
       ρ1 = (t1 ++ e1 :: t2, σ1) →
       ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) →
       prim_step e1 σ1 κ e2 σ2 efs →
       step ρ1 κ ρ2.
  Local Hint Constructors step : core.

  Inductive nsteps : nat → cfg Λ → list (observation Λ) → cfg Λ → Prop :=
    | nsteps_refl ρ :
       nsteps 0 ρ [] ρ
    | nsteps_l n ρ1 ρ2 ρ3 κ κs :
       step ρ1 κ ρ2 →
       nsteps n ρ2 κs ρ3 →
       nsteps (S n) ρ1 (κ ++ κs) ρ3.
  Local Hint Constructors nsteps : core.

  Definition erased_step (ρ1 ρ2 : cfg Λ) := ∃ κ, step ρ1 κ ρ2.

  (** [rtc erased_step] and [nsteps] encode the same thing, just packaged
      in a different way. *)
  Lemma erased_steps_nsteps ρ1 ρ2 :
    rtc erased_step ρ1 ρ2 ↔ ∃ n κs, nsteps n ρ1 κs ρ2.
  Proof.
    split.
    - induction 1; firstorder eauto. (* FIXME: [naive_solver eauto] should be able to handle this *)
    - intros (n & κs & Hsteps). unfold erased_step.
      induction Hsteps; eauto using rtc_refl, rtc_l.
  Qed.

  Lemma of_to_val_flip v e : of_val v = e → to_val e = Some v.
  Proof. intros <-. by rewrite to_of_val. Qed.

  Lemma not_reducible e σ : ¬reducible e σ ↔ irreducible e σ.
  Proof. unfold reducible, irreducible. naive_solver. Qed.
  Lemma reducible_not_val e σ : reducible e σ → to_val e = None.
  Proof. intros (?&?&?&?&?); eauto using val_stuck. Qed.
  Lemma reducible_no_obs_reducible e σ : reducible_no_obs e σ → reducible e σ.
  Proof. intros (?&?&?&?); eexists; eauto. Qed.
  Lemma val_irreducible e σ : is_Some (to_val e) → irreducible e σ.
  Proof. intros [??] ???? ?%val_stuck. by destruct (to_val e). Qed.
  Global Instance of_val_inj : Inj (=) (=) (@of_val Λ).
  Proof. by intros v v' Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.
  Lemma not_not_stuck e σ : ¬not_stuck e σ ↔ stuck e σ.
  Proof.
    rewrite /stuck /not_stuck -not_eq_None_Some -not_reducible.
    destruct (decide (to_val e = None)); naive_solver.
  Qed.

  Lemma strongly_atomic_atomic e a :
    Atomic StronglyAtomic e → Atomic a e.
  Proof. unfold Atomic. destruct a; eauto using val_irreducible. Qed.

  Lemma reducible_fill `{!@LanguageCtx Λ K} e σ :
    reducible e σ → reducible (K e) σ.
  Proof. unfold reducible in *. naive_solver eauto using fill_step. Qed.
  Lemma reducible_fill_inv `{!@LanguageCtx Λ K} e σ :
    to_val e = None → reducible (K e) σ → reducible e σ.
  Proof.
    intros ? (e'&σ'&k&efs&Hstep); unfold reducible.
    apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto.
  Qed.
  Lemma reducible_no_obs_fill `{!@LanguageCtx Λ K} e σ :
    reducible_no_obs e σ → reducible_no_obs (K e) σ.
  Proof. unfold reducible_no_obs in *. naive_solver eauto using fill_step. Qed.
  Lemma reducible_no_obs_fill_inv `{!@LanguageCtx Λ K} e σ :
    to_val e = None → reducible_no_obs (K e) σ → reducible_no_obs e σ.
  Proof.
    intros ? (e'&σ'&efs&Hstep); unfold reducible_no_obs.
    apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto.
  Qed.
  Lemma irreducible_fill `{!@LanguageCtx Λ K} e σ :
    to_val e = None → irreducible e σ → irreducible (K e) σ.
  Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill_inv. Qed.
  Lemma irreducible_fill_inv `{!@LanguageCtx Λ K} e σ :
    irreducible (K e) σ → irreducible e σ.
  Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill. Qed.

  Lemma not_stuck_fill_inv K `{!@LanguageCtx Λ K} e σ :
    not_stuck (K e) σ → not_stuck e σ.
  Proof.
    rewrite /not_stuck -!not_eq_None_Some. intros [?|?].
    - auto using fill_not_val.
    - destruct (decide (to_val e = None)); eauto using reducible_fill_inv.
  Qed.

  Lemma stuck_fill `{!@LanguageCtx Λ K} e σ :
    stuck e σ → stuck (K e) σ.
  Proof. rewrite -!not_not_stuck. eauto using not_stuck_fill_inv. Qed.

  Lemma step_Permutation (t1 t1' t2 : list (expr Λ)) κ σ1 σ2 :
    t1 ≡ₚ t1' → step (t1,σ1) κ (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ step (t1',σ1) κ (t2',σ2).
  Proof.
    intros Ht [e1 σ1' e2 σ2' efs tl tr ?? Hstep]; simplify_eq/=.
    move: Ht; rewrite -Permutation_middle (symmetry_iff (≡ₚ)).
    intros (tl'&tr'&->&Ht)%Permutation_cons_inv.
    exists (tl' ++ e2 :: tr' ++ efs); split; [|by econstructor].
    by rewrite -!Permutation_middle !assoc_L Ht.
  Qed.

  Lemma step_insert i t2 σ2 e κ e' σ3 efs :
    t2 !! i = Some e →
    prim_step e σ2 κ e' σ3 efs →
    step (t2, σ2) κ (<[i:=e']>t2 ++ efs, σ3).
  Proof.
    intros.
    edestruct (elem_of_list_split_length t2) as (t21&t22&?&?);
      first (by eauto using elem_of_list_lookup_2); simplify_eq.
    econstructor; eauto.
    by rewrite insert_app_r_alt // Nat.sub_diag /= -assoc_L.
  Qed.

  Lemma erased_step_Permutation (t1 t1' t2 : list (expr Λ)) σ1 σ2 :
    t1 ≡ₚ t1' → erased_step (t1,σ1) (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ erased_step (t1',σ1) (t2',σ2).
  Proof.
    intros Heq [? Hs]. pose proof (step_Permutation _ _ _ _ _ _ Heq Hs). firstorder.
     (* FIXME: [naive_solver] should be able to handle this *)
  Qed.

  Record pure_step (e1 e2 : expr Λ) := {
    pure_step_safe σ1 : reducible_no_obs e1 σ1;
    pure_step_det σ1 κ e2' σ2 efs :
      prim_step e1 σ1 κ e2' σ2 efs → κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs = []
  }.

  Notation pure_steps_tp := (Forall2 (rtc pure_step)).

  (* TODO: Exclude the case of [n=0], either here, or in [wp_pure] to avoid it
  succeeding when it did not actually do anything. *)
  Class PureExec (φ : Prop) (n : nat) (e1 e2 : expr Λ) :=
    pure_exec : φ → relations.nsteps pure_step n e1 e2.

  Lemma pure_step_ctx K `{!@LanguageCtx Λ K} e1 e2 :
    pure_step e1 e2 →
    pure_step (K e1) (K e2).
  Proof.
    intros [Hred Hstep]. split.
    - unfold reducible_no_obs in *. naive_solver eauto using fill_step.
    - intros σ1 κ e2' σ2 efs Hpstep.
      destruct (fill_step_inv e1 σ1 κ e2' σ2 efs) as (e2'' & -> & ?); [|exact Hpstep|].
      + destruct (Hred σ1) as (? & ? & ? & ?); eauto using val_stuck.
      + edestruct (Hstep σ1 κ e2'' σ2 efs) as (? & -> & -> & ->); auto.
  Qed.

  Lemma pure_step_nsteps_ctx K `{!@LanguageCtx Λ K} n e1 e2 :
    relations.nsteps pure_step n e1 e2 →
    relations.nsteps pure_step n (K e1) (K e2).
  Proof. eauto using nsteps_congruence, pure_step_ctx. Qed.

  Lemma rtc_pure_step_ctx K `{!@LanguageCtx Λ K} e1 e2 :
    rtc pure_step e1 e2 → rtc pure_step (K e1) (K e2).
  Proof. eauto using rtc_congruence, pure_step_ctx. Qed.

  (* We do not make this an instance because it is awfully general. *)
  Lemma pure_exec_ctx K `{!@LanguageCtx Λ K} φ n e1 e2 :
    PureExec φ n e1 e2 →
    PureExec φ n (K e1) (K e2).
  Proof. rewrite /PureExec; eauto using pure_step_nsteps_ctx. Qed.

  (* This is a family of frequent assumptions for PureExec *)
  Class IntoVal (e : expr Λ) (v : val Λ) :=
    into_val : of_val v = e.

  Class AsVal (e : expr Λ) := as_val : ∃ v, of_val v = e.
  (* There is no instance [IntoVal → AsVal] as often one can solve [AsVal] more
  efficiently since no witness has to be computed. *)
  Global Instance as_vals_of_val vs : TCForall AsVal (of_val <$> vs).
  Proof.
    apply TCForall_Forall, Forall_fmap, Forall_true=> v.
    rewrite /AsVal /=; eauto.
  Qed.

  Lemma as_val_is_Some e :
    (∃ v, of_val v = e) → is_Some (to_val e).
  Proof. intros [v <-]. rewrite to_of_val. eauto. Qed.

  Lemma prim_step_not_stuck e σ κ e' σ' efs :
    prim_step e σ κ e' σ' efs → not_stuck e σ.
  Proof. rewrite /not_stuck /reducible. eauto 10. Qed.

  Lemma rtc_pure_step_val `{!Inhabited (state Λ)} v e :
    rtc pure_step (of_val v) e → to_val e = Some v.
  Proof.
    intros ?; rewrite <- to_of_val.
    f_equal; symmetry; eapply rtc_nf; first done.
    intros [e' [Hstep _]].
    destruct (Hstep inhabitant) as (?&?&?&Hval%val_stuck).
    by rewrite to_of_val in Hval.
  Qed.

  (** Let thread pools [t1] and [t3] be such that each thread in [t1] makes
   (zero or more) pure steps to the corresponding thread in [t3]. Furthermore,
   let [t2] be a thread pool such that [t1] under state [σ1] makes a (single)
   step to thread pool [t2] and state [σ2]. In this situation, either the step
   from [t1] to [t2] corresponds to one of the pure steps between [t1] and [t3],
   or, there is an [i] such that [i]th thread does not participate in the
   pure steps between [t1] and [t3] and [t2] corresponds to taking a step in
   the [i]th thread starting from [t1]. *)
  Lemma erased_step_pure_step_tp t1 σ1 t2 σ2 t3 :
    erased_step (t1, σ1) (t2, σ2) →
    pure_steps_tp t1 t3 →
    (σ1 = σ2 ∧ pure_steps_tp t2 t3) ∨
    (∃ i e efs e' κ,
      t1 !! i = Some e ∧ t3 !! i = Some e ∧
      t2 = <[i:=e']>t1 ++ efs ∧
      prim_step e σ1 κ e' σ2 efs).
  Proof.
    intros [κ [e σ e' σ' efs t11 t12 ?? Hstep]] Hps; simplify_eq/=.
    apply Forall2_app_inv_l in Hps
      as (t31&?&Hpsteps&(e''&t32&Hps&?&->)%Forall2_cons_inv_l&->).
    destruct Hps as [e|e1 e2 e3 [_ Hprs]].
    - right.
      exists (length t11), e, efs, e', κ; split_and!; last done.
      + by rewrite lookup_app_r // Nat.sub_diag.
      + apply Forall2_length in Hpsteps.
        by rewrite lookup_app_r Hpsteps // Nat.sub_diag.
      + by rewrite insert_app_r_alt // Nat.sub_diag /= -assoc_L.
    - edestruct Hprs as (?&?&?&?); first done; simplify_eq.
      left; split; first done.
      rewrite right_id_L.
      eauto using Forall2_app.
  Qed.

End language.

Global Arguments step_atomic {Λ ρ1 κ ρ2}.

Notation pure_steps_tp := (Forall2 (rtc pure_step)).


Require Export Trace.
Require Export ConcurProc.
Require Export ExecSemantics.
Require Export Spec.ThreadsState.

Require Import ProofAutomation.
Require Import Helpers.ListStuff.
Require Import Helpers.Instances.

Require Import Relations.Relation_Operators.
Require Import RelationClasses.
Require Import Morphisms.
Require Import FunctionalExtensionality.
Require Import Omega.
Require Import Bool.

Section Execution.

  Variable Op:Type -> Type.
  Variable State: Type.
  Variable op_step: OpSemantics Op State.

  Inductive exec_till : nat -> State -> threads_state Op -> trace -> Prop :=

  | ExecTillOne : forall T tid tid' (ts : threads_state Op) trace p s s' evs result spawned n,
    ts tid = @Proc Op T p ->
    ts tid' = NoProc ->
    exec_tid op_step tid s p s' result spawned evs ->
    exec_till n s' (thread_upd (thread_upd ts tid' spawned) tid
              match result with
              | inl _ => NoProc
              | inr p' => Proc p'
              end) trace ->
    exec_till (S n) s ts (prepend tid evs trace)

  | ExecTillStop : forall (ts : threads_state Op) s,
    exec_till 0 s ts TraceEmpty.

  Theorem exec_to_counter : forall s ts tr,
      exec op_step s ts tr ->
      exists n, exec_till n s ts tr.
  Proof.
    induction 1; propositional;
      eauto using ExecTillOne, ExecTillStop.
  Qed.

  Theorem exec_till_to_exec : forall n s ts tr,
      exec_till n s ts tr ->
      exec op_step s ts tr.
  Proof.
    induction 1; propositional;
      eauto using ExecOne, ExecStop.
  Qed.

  Inductive exec_any (tid : nat) (s : State) :
    forall T (p : proc Op T) (r : T) (s' : State), Prop :=
  | ExecAnyOther :
    forall T (p : proc Op T) (r : T) (s' : State)
           T' (op' : Op T') tid' s0 r0 evs,
    tid <> tid' ->
    op_step op' tid' s r0 s0 evs ->
    exec_any tid s0 p r s' ->
    exec_any tid s p r s'
  | ExecAnyThisDone :
    forall T (p : proc Op T) (r : T) (s' : State) spawned evs,
    exec_tid op_step tid s p s' (inl r) spawned evs ->
    exec_any tid s p r s'
  | ExecAnyThisMore :
    forall T (p p' : proc Op T) (s' s0 : State) r spawned evs,
    exec_tid op_step tid s p s0 (inr p') spawned evs ->
    exec_any tid s0 p' r s' ->
    exec_any tid s p r s'
  .

  Definition exec_others (tid : nat) (s s' : State) : Prop :=
    clos_refl_trans_1n _
      (fun s0 s1 =>
        exists tid' `(op' : Op T') r' evs,
          tid' <> tid /\
          op_step op' tid' s0 r' s1 evs)
      s s'.

  Global Instance exec_others_pre tid : PreOrder (exec_others tid).
  Proof.
    unfold exec_others.
    constructor; hnf; intros.
    reflexivity.
    etransitivity; eauto.
  Qed.

  Lemma exec_others_one : forall tid s s' tid' T (op: Op T) r evs,
      tid <> tid' ->
      op_step op tid' s r s' evs ->
      exec_others tid s s'.
  Proof.
    unfold exec_others; intros.
    econstructor; [ | reflexivity ].
    eauto 10.
  Qed.

  Lemma exec_any_op : forall `(op : Op T) tid r s s',
    exec_any tid s (Call op) r s' ->
      exists s0 evs,
        exec_others tid s s0 /\
        op_step op tid s0 r s' evs.
  Proof.
    intros.
    remember (Call op).
    induct H;
      repeat match goal with
             | [ H: forall _, Call _ = Call _ -> _ |- _ ] =>
               specialize (H _ eq_refl)
             end;
      propositional.
    - descend; split; [ | eauto ].
      etransitivity; eauto using exec_others_one.
    - invert H.
      descend; split; [ reflexivity | eauto ].
    - invert H.
  Qed.

  Lemma exec_others_trans :
    forall tid s0 s1 s2,
      exec_others tid s0 s1 ->
      exec_others tid s1 s2 ->
      exec_others tid s0 s2.
  Proof.
    etransitivity; eauto.
  Qed.

  Lemma exec_tid_exec_others :
    forall tid tid' `(p : proc Op T) s s' result spawned evs,
      tid <> tid' ->
      exec_tid op_step tid' s p s' result spawned evs ->
      exec_others tid s s'.
  Proof.
    induction 2; propositional; eauto;
      try reflexivity.
    - econstructor; eauto 10.
      reflexivity.
    - induct H0; eauto 10; try reflexivity.
      eapply exec_others_trans; eauto.
      econstructor; eauto 10.
      constructor.
  Qed.

  Lemma exec_others_exec_any :
    forall tid s s' s'' `(p : proc Op T) v,
      exec_others tid s s' ->
      exec_any tid s' p v s'' ->
      exec_any tid s p v s''.
  Proof.
    induction 1; propositional; eauto using ExecAnyOther.
  Qed.

End Execution.

Hint Constructors exec_any.
Hint Resolve exec_tid_exec_others.
Hint Resolve exec_others_exec_any.
Hint Resolve exec_others_trans.

Section StepImpl.

  Hint Constructors exec_tid.
  Hint Constructors atomic_exec.

  Variable Op : Type -> Type.
  Variable State : Type.
  Variable op_step1 : OpSemantics Op State.
  Variable op_step2 : OpSemantics Op State.

  Variable StepImpl :
    forall `(op : Op TT) tid s r s' evs,
      op_step1 op tid s r s' evs ->
      op_step2 op tid s r s' evs.

  Theorem atomic_exec_step_impl :
    forall tid s `(p : proc _ T) s' r evs,
      atomic_exec op_step1 p tid s s' r evs ->
      atomic_exec op_step2 p tid s s' r evs.
  Proof.
    intros.
    induction H; eauto.
  Qed.

  Theorem exec_tid_step_impl :
    forall tid s `(p : proc _ T) s' r spawned evs,
      exec_tid op_step1 tid s p s' r spawned evs ->
      exec_tid op_step2 tid s p s' r spawned evs.
  Proof.
    intros.
    induct H; eauto.
    eapply atomic_exec_step_impl in H; eauto.
  Qed.

  Theorem exec_any_impl :
    forall tid s `(p : proc _ T) s' r,
      exec_any op_step1 tid s p r s' ->
      exec_any op_step2 tid s p r s'.
  Proof.
    intros.
    induct H; eauto.
    eapply exec_tid_step_impl in H; eauto.
    eapply exec_tid_step_impl in H; eauto.
  Unshelve.
    all: intros; eauto.
    exact (Ret r0).
  Qed.

End StepImpl.

Lemma thread_empty_inv : forall Op T (p' : proc Op T) tid,
  thread_empty [[ tid ]] = Proc p' ->
  False.
Proof.
  intros.
  rewrite empty_is_empty in H; congruence.
Qed.

Hint Extern 1 (exec_tid _ _ _ _ _ _ _) => econstructor.
Hint Extern 1 (atomic_exec _ _ _ _ _ _ _) => econstructor.

Hint Resolve ExecOne.
Hint Extern 1 (exec _ _ _ TraceEmpty) => simple apply ExecStop.

Ltac maybe_proc_inv := match goal with
  | H : Proc _ = NoProc |- _ =>
    solve [ exfalso; inversion H ]
  | H : NoProc = Proc _ |- _ =>
    solve [ exfalso; inversion H ]
  | H : ?a = ?a |- _ =>
    clear H
  | H : Proc _ = Proc _ |- _ =>
    inversion H; clear H; subst
  | H : existT _ _ _ = existT _ _ _ |- _ =>
    sigT_eq
  | H : existT _ _ _ = existT _ _ _ |- _ =>
    inversion H; clear H; subst
  end.

Ltac exec_tid_inv :=
  match goal with
  | H : exec_tid _ _ _ _ _ _ _ _ |- _ =>
    inversion H; clear H; subst; repeat maybe_proc_inv
  end;
  autorewrite with t in *.

(* for performance reasons, we define this safely repeated version of
  exec_tid_inv *)
Local Notation exec_p p := (exec_tid _ _ _ p _ _ _ _) (only parsing).
Ltac exec_tid_simpl :=
  let execinv H := inversion H; clear H; subst in
  repeat (match goal with
          | [ H: exec_p (Ret _) |- _ ] => execinv H
          | [ H: exec_p (Atomic _) |- _ ] => execinv H
          | [ H: exec_p (Call _) |- _ ] => execinv H
          | [ H: exec_p (Bind _ _) |- _ ] => execinv H
          | [ H: exec_p (Until _ _ _) |- _ ] => execinv H
          | [ H: exec_p (Spawn _) |- _ ] => execinv H
          end || maybe_proc_inv);
  autorewrite with t in *.

(* former unoptimized implementation *)
(* Ltac exec_tid_simpl := repeat (exec_tid_inv; is_one_goal). *)

Ltac atomic_exec_inv :=
  match goal with
  | H : atomic_exec _ (if ?expr then _ else _) _ _ _ _ _ |- _ =>
    destruct expr
  | H : atomic_exec _ _ _ _ _ _ _ |- _ =>
    inversion H; clear H; subst; repeat maybe_proc_inv
  end;
  autorewrite with t in *.

(* compare thread ids and perform cleanup *)
Ltac cmp_ts tid1 tid2 :=
  destruct (tid1 == tid2); subst;
  try congruence;
  autorewrite with t in *.

Local Lemma exec_ts_eq : forall Op State (op_step: OpSemantics Op State) s ts ts' tr,
    exec op_step s ts' tr ->
    ts = ts' ->
    exec op_step s ts tr.
Proof.
  propositional.
Qed.

Local Lemma exec_till_ts_eq : forall n Op State (op_step: OpSemantics Op State) s ts ts' tr,
    exec_till op_step n s ts' tr ->
    ts = ts' ->
    exec_till op_step n s ts tr.
Proof.
  propositional.
Qed.

(* abstract the thread state in an exec goal (to deal with different update
forms) *)
Ltac abstract_ts :=
  match goal with
  | |- exec _ _ ?ts _ => eapply exec_ts_eq
  | |- exec_till _ _ _ ?ts _ => eapply exec_till_ts_eq
  end.

Local Lemma exec_tr_eq : forall Op State (op_step: OpSemantics Op State) s ts tr tr',
    exec op_step s ts tr' ->
    tr = tr' ->
    exec op_step s ts tr.
Proof.
  propositional.
Qed.

(* abstract the trace in an exec goal (to deal with different calls to
prepend/list append) *)
Ltac abstract_tr :=
  match goal with
  | |- exec _ _ _ ?tr => eapply exec_tr_eq
  end.

Ltac NoProc_upd :=
  repeat lazymatch goal with
         | [ H: thread_get (thread_upd _ ?tid (Proc _)) ?tid' = NoProc |- _ ] =>
           cmp_ts tid tid';
           [ solve [ maybe_proc_inv ] | ]
         end.

Ltac remove_redundant_upds :=
  repeat match goal with
         | [ Heq: thread_get ?ts ?tid = ?p,
                  H: context[thread_upd ?ts ?tid ?p] |- _ ] =>
           rewrite (thread_upd_same_eq _ _ Heq) in H
         | [ Heq: thread_get ?ts ?tid = ?p
             |- context[thread_upd ?ts ?tid ?p] ] =>
           rewrite (thread_upd_same_eq _ _ Heq) in |- *
         end.

(* the ExecPrefix tactic solves exec goals by splitting them into one
execution step and leaving the exec for [auto] *)

(* copy some basic hints from core *)
Hint Extern 2 (_ <> _) => simple apply not_eq_sym; trivial : exec.
Hint Extern 2 (_ = _) => simple apply eq_sym : exec.
Hint Resolve eq_refl : exec.

Local Lemma thread_upd_aba :
  forall Op (ts: threads_state Op) tid1 tid2 p1 p2 p3,
    tid1 <> tid2 ->
    ts [[tid1 := p1]] [[tid2 := p2]] [[tid1 := p3]] =
    ts [[tid2 := p2]] [[tid1 := p3]].
Proof.
  intros.
  rewrite ?thread_upd_ne_comm with (tid:=tid2) (tid':=tid1) by auto.
  f_equal.
  autorewrite with t; auto.
Qed.

Local Lemma thread_upd_abc_to_cab :
  forall Op (ts: threads_state Op) tid1 tid2 tid3 p1 p2 p3,
    tid1 <> tid2 ->
    tid1 <> tid3 ->
    ts [[tid1 := p1]] [[tid2 := p2]] [[tid3 := p3]] =
    ts [[tid2 := p2]] [[tid3 := p3]] [[tid1 := p1]].
Proof.
  intros.
  rewrite thread_upd_ne_comm with (tid := tid1) (tid' := tid2) by congruence.
  rewrite thread_upd_ne_comm with (tid := tid1) (tid' := tid3) by congruence.
  auto.
Qed.

Local Lemma thread_upd_other_eq : forall Op (ts:threads_state Op)
                              tid T (p: proc _ T) tid' T' (p': proc _ T'),
    tid' <> tid ->
    ts tid' = Proc p ->
    ts [[tid := Proc p']] tid' = Proc p.
Proof.
  intros.
  autorewrite with t.
  auto.
Qed.

Local Lemma thread_upd_spawn_delay :
  forall Op (ts: threads_state Op) tid T (p: proc _ T) tid' spawned tid'' p',
    tid'' <> tid ->
    tid <> tid' ->
    ts [[tid := Proc p]] [[tid' := spawned]] [[tid'' := p']] =
    ts [[tid' := spawned]] [[tid'' := p']] [[tid := Proc p]].
Proof.
  intros.
  apply thread_upd_abc_to_cab; auto.
Qed.

Local Lemma thread_spawn_none :
  forall Op (ts: threads_state Op) T (p: proc Op T) tid tid' ,
    tid <> tid' ->
    ts tid' = NoProc ->
    ts [[tid := Proc p]] [[tid' := NoProc]] =
    ts [[tid := Proc p]].
Proof.
  intros.
  rewrite thread_upd_same_eq; auto.
  autorewrite with t; auto.
Qed.

Hint Resolve thread_upd_other_eq : exec.
Hint Resolve thread_upd_spawn_delay : exec.
Hint Resolve thread_upd_ne_comm : exec.
Hint Resolve thread_upd_abc_to_cab : exec.
Hint Constructors exec_tid atomic_exec : exec.

Hint Extern 1 (exec _ _ _ _) =>
match goal with
| |- exec _ _ ?ts _ => first [ is_evar ts; fail 1 | eapply exec_ts_eq ]
end : exec.

(* basically the same as ExecPrefix, but applies [ExecTillOne] instead of
[ExecOne] *)
Ltac ExecOne tid_arg tid'_arg :=
  eapply ExecTillOne with (tid:=tid_arg) (tid':=tid'_arg);
  autorewrite with t;
  (* need to exclude core for performance reasons *)
  eauto 7 with nocore exec;
  remove_redundant_upds;
  cbv beta iota.

Hint Rewrite thread_spawn_none using congruence : t.
Hint Rewrite thread_upd_aba using congruence : t.

Ltac ExecPrefix tid_arg tid'_arg :=
  eapply ExecOne with (tid:=tid_arg) (tid':=tid'_arg);
  autorewrite with t;
  (* need to exclude core for performance reasons *)
  eauto 7 with nocore exec;
  remove_redundant_upds;
  cbv beta iota.

Module Examples.

  Theorem ret_exec_example : forall Op State (op_step: OpSemantics Op State)
                               (ts: threads_state Op) tid tid' T (v:T) s tr,
    tid <> tid' ->
    ts tid' = NoProc ->
    ts tid = NoProc ->
    exec op_step s ts tr ->
    exec op_step s (ts [[tid := Proc (Ret v)]]) tr.
  Proof.
    intros.
    abstract_tr.
    ExecPrefix tid tid'.
    eassumption.
    reflexivity.
  Qed.

End Examples.

(* TODO: stuck this here for lack of a better place to put it *)
Fixpoint SpawnN {Op T} (n:nat) (p:proc Op T) : proc Op unit :=
  match n with
  | 0 => Ret tt
  | S n' => Bind (Spawn p) (fun _ => SpawnN n' p)
  end.