(**************************************************************************
* TLC: A library for Coq                                                  *
* Well-founded relations                                                  *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic
 LibProd LibSum LibRelation LibNat LibInt.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Compatibility *)

(** Coq's stdlib Prelude defines:

 Inductive Acc A (R:A->A->Prop) (x:A) : Prop :=
   | Acc_intro : (forall (y:A), R y x -> Acc y) -> Acc x.

 Definition well_founded A (R:A->A->Prop) :=
    forall (x:A), Acc x.

*)

(** TLC introduces [wf] as a shorter name for [well_founded], both
    for conciseness and for tactics to specifically recognize
    this symbol. *)

Definition wf := well_founded.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics *)

(** [auto with wf] attempts to unfold the names of
    the relations given as argument to [wf]. *)

Hint Extern 1 (wf ?R) => progress (unfold R) : wf.

(** [solve_wf] is a shorthand for solving goals using
    [auto with wf], aimed to prove goals of the form [wf R]. *)

Tactic Notation "solve_wf" :=
  solve [ auto with wf ].

(* ********************************************************************** *)
(* ################################################################# *)
(* * Measures *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition *)

(** [measure f] is a well-founded binary relation which
    relates [x] to [y] when [f x < f y], at type [nat]. *)

Definition measure A (f:A->nat) : binary A :=
  fun x1 x2 => (f x1 < f x2).

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties *)

Section Measure.
Variables (A : Type).
Implicit Type f : A -> nat.

Lemma wf_measure : forall f,
  wf (measure f).
Proof using.
  intros f a. gen_eq n: (f a). gen a. pattern n.
  apply peano_induction. clear n. introv IH Eq.
  apply Acc_intro. introv H. unfolds in H.
  rewrite <- Eq in H. apply* IH.
Qed.

Lemma trans_measure : forall (f : A -> nat),
  trans (measure f).
Proof using. intros. unfold measure, trans. intros. nat_math. Qed.

(* -- LATER: Lemma order_measure *)

End Measure.

Hint Resolve wf_measure : wf.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Measure on pairs *)

Definition measure2 A1 A2 (f : A1 -> A2 -> nat) : binary (A1*A2) :=
  fun p1 p2 => let (x1,y1) := p1 in
               let (x2,y2) := p2 in
               (f x1 y1 < f x2 y2).

Lemma wf_measure2 : forall A1 A2 (f:A1->A2->nat),
  wf (measure2 f).
Proof using.
  intros A1 A2 f [x1 x2]. apply (@measure_induction _ (uncurry2 f)). clear x1 x2.
  intros [x1 x2] H. apply Acc_intro. intros [y1 y2] Lt. apply~ H.
Qed.

Hint Resolve wf_measure2 : wf.

(* ---------------------------------------------------------------------- *)
(** Extension of LibTactic's [induction_wf] tactic for [measure] *)

(** -- LATER: introduce a hook in LibTactics to reduce copy-paste *)

Ltac induction_wf_core_then IH E X cont ::=
  let T := type of E in
  let T := eval hnf in T in
  let clearX tt :=
    first [ clear X | fail 3 "the variable on which the induction is done appears in the hypotheses" ] in
  match T with
  (* To support for [measure] from LibWf, we add the next two lines: *)
  | ?A -> nat =>
     induction_wf_core_then IH (wf_measure E) X cont
  (* End of modification *)
  | ?A -> ?A -> Prop =>
     pattern X;
     first [
       applys well_founded_ind E;
       clearX tt;
       [ (* Support for [wf] from LibWf *)
         change well_founded with wf; auto with wf
       | intros X IH; cont tt ]
     | fail 2 ]
  | _ =>
    pattern X;
    applys well_founded_ind E;
    clearX tt;
    intros X IH;
    cont tt
  end.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Construction of well-founded relations *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Empty relation *)

Lemma wf_empty : forall A,
  wf (@empty A).
Proof using. intros_all. constructor. introv H. false. Qed.

Hint Resolve wf_empty : wf.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inclusion *)

(** Well-foundedness preserved by inclusion *)

Lemma wf_of_rel_incl : forall A (R1 R2 : binary A),
  wf R1 ->
  rel_incl R2 R1 ->
  wf R2.
Proof using.
  introv W1 Inc. intros x.
  pattern x. apply (well_founded_ind W1). clear x.
  intros x IH. constructor. intros. apply IH. apply~ Inc.
Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(* * Classic well-founded relations on [nat] *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [Peano.lt] on [nat] *)

(** The relation "less than" on natural numbers is well_founded. *)

Lemma wf_peano_lt : wf Peano.lt.
Proof using.
  intros x.
  induction x using peano_induction. apply~ Acc_intro.
    intros. applys H. math.
Qed.

Hint Resolve wf_peano_lt : wf.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [lt] on [nat] *)

(** The relation "less than" on natural numbers is well_founded. *)

Lemma wf_lt : @wf nat lt.
Proof using.
  intros x.
  induction x using peano_induction. apply~ Acc_intro.
Qed.

Hint Resolve wf_lt : wf.

(* ---------------------------------------------------------------------- *)
(** ** The relation "greater than" on the set of
       natural number lower than a fixed upper bound. *)

Definition nat_upto (b:nat) :=
  fun (n m:nat) => (n <= b)%nat /\ (m < n)%nat.

Lemma nat_upto_eq : forall (b n m:nat),
  nat_upto b n m = ((n <= b)%nat /\ (m < n)%nat).
Proof using. auto. Qed.

Lemma wf_nat_upto : forall (b:nat),
  wf (nat_upto b).
Proof using.
  intros b n.
  induction_wf: (wf_measure (fun n => (b-n)%nat)) n.
  apply Acc_intro. introv [H1 H2]. apply IH.
  hnf. nat_math.
Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(* * Classic well-founded relations on [int] *)

(* ---------------------------------------------------------------------- *)
(** ** The relation "less than" on the set of
       integers greater than a fixed lower bound. *)

Definition downto (b:int) :=
  fun (n m:int) => (b <= n) /\ (n < m).

Lemma downto_eq : forall (b n m:int),
  downto b n m = (b <= n /\ n < m).
Proof using. auto. Qed.

Lemma downto_intro : forall (b n m:int),
  b <= n ->
  n < m ->
  downto b n m.
Proof using. split~. Qed.

Lemma wf_downto : forall (b:int),
  wf (downto b).
Proof using.
  intros b n.
  induction_wf: (wf_measure (fun n => Zabs_nat (n-b))) n.
  apply Acc_intro. introv [H1 H2]. apply IH.
  unfolds. applys lt_abs_abs; math.
Qed.

Hint Resolve wf_downto : wf.
Hint Unfold downto.
Hint Extern 1 (downto _ _ _) => math : maths.

(* ---------------------------------------------------------------------- *)
(** ** The relation "greater than" on the set of
       integers lower than a fixed upper bound. *)

Definition upto (b:int) :=
  fun (n m:int) => (n <= b) /\ (m < n).

Lemma upto_eq : forall b n m,
  upto b n m = ((n <= b) /\ (m < n)).
Proof using. auto. Qed.

Lemma upto_intro : forall b n m,
  n <= b ->
  m < n ->
  upto b n m.
Proof using. split~. Qed.

Lemma wf_upto : forall n,
  wf (upto n).
Proof using.
  intros b n.
  induction_wf: (wf_measure (fun n => Zabs_nat (b-n))) n.
  apply Acc_intro. introv [H1 H2]. apply IH.
  applys lt_abs_abs; math.
Qed.

Hint Resolve wf_upto : wf.
Hint Unfold upto.
Hint Extern 1 (upto _ _ _) => math : maths.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Inverse projections *)

Section UnprojWf.
Variables (A1 A2 A3 A4 A5 : Type).

Lemma wf_unproj21 : forall (R:binary A1),
  wf R ->
  wf (unproj21 A2 R).
Proof using.
  intros R H [x1 x2]. gen x2.
  induction_wf IH: H x1. constructor. intros [y1 y2]. auto.
Qed.

Lemma wf_unproj22 : forall (R:binary A2),
  wf R ->
  wf (unproj22 A1 R).
Proof using.
  intros R H [x1 x2]. gen x1.
  induction_wf IH: H x2. constructor. intros [y1 y2]. auto.
Qed.

Lemma wf_unproj31 : forall (R:binary A1),
  wf R ->
  wf (unproj31 A2 A3 R).
Proof using.
  intros R H [[x1 x2] x3]. gen x2 x3.
  induction_wf IH: H x1. constructor. intros [[y1 y2] y3]. auto.
Qed.

Lemma wf_unproj32 : forall (R:binary A2),
  wf R ->
  wf (unproj32 A1 A3 R).
Proof using.
  intros R H [[x1 x2] x3]. gen x1 x3.
  induction_wf IH: H x2. constructor. intros [[y1 y2] y3]. auto.
Qed.

Lemma wf_unproj33 : forall (R:binary A3),
  wf R ->
  wf (unproj33 A1 A2 R).
Proof using.
  intros R H [[x1 x2] x3]. gen x1 x2.
  induction_wf IH: H x3. constructor. intros [[y1 y2] y3]. auto.
Qed.

Lemma wf_unproj41 : forall (R:binary A1),
  wf R ->
  wf (unproj41 A2 A3 A4 R).
Proof using.
  intros R H [[[x1 x2] x3] x4]. gen x2 x3 x4.
  induction_wf IH: H x1. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma wf_unproj42 : forall (R:binary A2),
  wf R ->
  wf (unproj42 A1 A3 A4 R).
Proof using.
  intros R H [[[x1 x2] x3] x4]. gen x1 x3 x4.
  induction_wf IH: H x2. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma wf_unproj43 : forall (R:binary A3),
  wf R ->
  wf (unproj43 A1 A2 A4 R).
Proof using.
  intros R H [[[x1 x2] x3] x4]. gen x1 x2 x4.
  induction_wf IH: H x3. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma wf_unproj44 : forall (R:binary A4),
  wf R ->
  wf (unproj44 A1 A2 A3 R).
Proof using.
  intros R H [[[x1 x2] x3] x4]. gen x1 x2 x3.
  induction_wf IH: H x4. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma wf_unproj51 : forall (R:binary A1),
  wf R ->
  wf (unproj51 A2 A3 A4 A5 R).
Proof using.
  intros R H [[[[x1 x2] x3] x4] x5]. gen x2 x3 x4 x5.
  induction_wf IH: H x1. constructor. intros [[[[y1 y2] y3] y4] y5]. auto.
Qed.

End UnprojWf.

Hint Resolve
  wf_unproj21 wf_unproj22
  wf_unproj31 wf_unproj32 wf_unproj33
  wf_unproj41 wf_unproj42 wf_unproj43 wf_unproj44
  wf_unproj51 : wf.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Lexicographical product *)

Lemma wf_lexico2 : forall A1 A2
 (R1:binary A1) (R2:binary A2),
  wf R1 ->
  wf R2 ->
  wf (lexico2 R1 R2).
Proof using.
  introv W1 W2. intros [x1 x2]. gen x2.
  induction_wf IH1: W1 x1. intros.
  induction_wf IH2: W2 x2. constructor. intros [y1 y2] H.
  simpls. destruct H as [H1|[H1 H2]].
  apply~ IH1. rewrite H1. apply~ IH2.
Qed.

Lemma wf_lexico3 : forall A1 A2 A3
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R1 ->
  wf R2 ->
  wf R3 ->
  wf (lexico3 R1 R2 R3).
Proof using.
  intros. apply~ wf_lexico2. apply~ wf_lexico2.
Qed.

Lemma wf_lexico4 : forall A1 A2 A3 A4
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R1 ->
  wf R2 ->
  wf R3 ->
  wf R4 ->
  wf (lexico4 R1 R2 R3 R4).
Proof using.
  intros. apply~ wf_lexico3. apply~ wf_lexico2.
Qed.

Hint Resolve wf_lexico2 wf_lexico3 wf_lexico4 : wf.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Symmetric product *)

Lemma wf_prod2_of_wf_1 : forall (A1 A2:Type)
 (R1:binary A1) (R2:binary A2),
  wf R1 ->
  wf (prod2 R1 R2).
Proof using.
  introv W1. intros [x1 x2].
  gen x2. induction_wf IH: W1 x1. intros.
  constructor. intros [y1 y2] [E1 E2]. apply~ IH.
Qed.

Lemma wf_prod2_of_wf_2 : forall (A1 A2:Type)
 (R1:binary A1) (R2:binary A2),
  wf R2 ->
  wf (prod2 R1 R2).
Proof using.
  introv W2. intros [x1 x2].
  gen x1. induction_wf IH: W2 x2. intros.
  constructor. intros [y1 y2] [E1 E2]. apply~ IH.
Qed.

Lemma wf_prod3_of_wf_1 : forall (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R1 ->
  wf (prod3 R1 R2 R3).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod2_of_wf_1. Qed.

Lemma wf_prod3_of_wf_2 : forall (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R2 ->
  wf (prod3 R1 R2 R3).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod2_of_wf_2. Qed.

Lemma wf_prod3_of_wf_3 : forall (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R3 ->
  wf (prod3 R1 R2 R3).
Proof using. intros. apply~ wf_prod2_of_wf_2. Qed.

Lemma wf_prod4_of_wf_1 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R1 ->
  wf (prod4 R1 R2 R3 R4).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod3_of_wf_1. Qed.

Lemma wf_prod4_of_wf_2 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R2 ->
  wf (prod4 R1 R2 R3 R4).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod3_of_wf_2. Qed.

Lemma wf_prod4_of_wf_3 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R3 ->
  wf (prod4 R1 R2 R3 R4).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod3_of_wf_3. Qed.

Lemma wf_prod4_of_wf_4 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R4 ->
  wf (prod4 R1 R2 R3 R4).
Proof using. intros. apply~ wf_prod2_of_wf_2. Qed.

Hint Resolve
  wf_prod2_of_wf_1 wf_prod2_of_wf_2
  wf_prod3_of_wf_1 wf_prod3_of_wf_2 wf_prod3_of_wf_3
  wf_prod4_of_wf_1 wf_prod4_of_wf_2 wf_prod4_of_wf_3 wf_prod4_of_wf_4 : wf.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Well-foundedness of a function image *)

Lemma wf_rel_preimage : forall A B (R:binary B) (f:A->B),
  wf R ->
  wf (rel_preimage R f).
Proof using.
  introv W. intros x. gen_eq a: (f x). gen x.
  induction_wf: W a. introv E. constructors.
  intros y Hy. subst a. hnf in Hy. applys* IH.
Qed.

Hint Resolve wf_rel_preimage : wf.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(* TEMPORARY *)

(* begin hide *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Union *)

(* --TODO..

Section WfUnion.
  Variables (A : Type).
  Variables R1 R2 : binary A.

  Notation Union := (union A R1 R2).

  Remark strip_commut :
    commut A R1 R2 ->
    forall x y:A,
      clos_trans A R1 y x ->
      forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & clos_trans A R1 z y'.
  Proof using.
    induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros.
    elim H with y x z; auto with sets; intros x0 H2 H3.
    exists x0; auto with sets.

    elim IH1 with z0; auto with sets; intros.
    elim IH2 with x0; auto with sets; intros.
    exists x1; auto with sets.
    apply t_trans with x0; auto with sets.
  Qed.

  Lemma Acc_union :
    commut A R1 R2 ->
    (forall x:A, Acc R2 x -> Acc R1 x) -> forall a:A, Acc R2 a -> Acc Union a.
  Proof using.
    induction 3 as [x H1 H2].
    apply Acc_intro; intros.
    elim H3; intros; auto with sets.
    cut (clos_trans A R1 y x); auto with sets.
    elimtype (Acc (clos_trans A R1) y); intros.
    apply Acc_intro; intros.
    elim H8; intros.
    apply H6; auto with sets.
    apply t_trans with x0; auto with sets.

    elim strip_commut with x x0 y0; auto with sets; intros.
    apply Acc_inv_trans with x1; auto with sets.
    unfold union in |- *.
    elim H11; auto with sets; intros.
    apply t_trans with y1; auto with sets.

    apply (Acc_clos_trans A).
    apply Acc_inv with x; auto with sets.
    apply H0.
    apply Acc_intro; auto with sets.
  Qed.

  Theorem wf_union :
    commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
  Proof using.
    unfold well_founded in |- *.
    intros.
    apply Acc_union; auto with sets.
  Qed.

End WfUnion.

*)

(* --TODO: Disjoint union, useful? *)

(* end hide *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Transitive closure *)

Lemma wf_tclosure : forall A (R:binary A),
  wf R ->
  wf (tclosure R).
Proof using.
  unfold wf, well_founded.
  introv HAcc. intro a. specializes HAcc a. generalize dependent a.
  induction 1 as [ a _ IH ].
  constructor. intros b Hba.
  generalize a b Hba IH. clear a b Hba IH.
  induction 1; eauto using Acc_inv.
Qed.


MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section predicate_calculus.

Coq < Variable D : Set.
D is assumed

Coq < Variable R : D -> D -> Prop.
R is assumed

Coq < Section R_sym_trans.

Coq < Hypothesis R_symmetric : forall x y:D, R x y -> R y x.
R_symmetric is assumed

Coq < Hypothesis R_transitive : forall x y z:D, R x y -> R y z -> R x z.
R_transitive is assumed

Coq < Lemma refl_if : forall x:D, (exists y, R x y) -> R x x.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  ============================
   forall x : D, (exists y : D, R x y) -> R x x

refl_if < Check ex.
ex
     : forall A : Type, (A -> Prop) -> Prop

refl_if < intros x x_Rlinked.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  ============================
   R x x

refl_if < elim x_Rlinked.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  ============================
   forall x0 : D, R x x0 -> R x x

refl_if < intros y Rxy.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  y : D
  Rxy : R x y
  ============================
   R x x

refl_if < apply R_transitive with y.
2 subgoals

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  y : D
  Rxy : R x y
  ============================
   R x y

subgoal 2 is:
 R y x

refl_if < assumption.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  y : D
  Rxy : R x y
  ============================
   R y x

refl_if < apply R_symmetric; assumption.
No more subgoals.

refl_if < Qed.
intros x x_Rlinked.
elim x_Rlinked.
intros y Rxy.
apply R_transitive with y.
 assumption.

 apply R_symmetric; assumption.

refl_if is defined

Coq <


Require Import Vector.

Fixpoint vector_nth {A:Type}(n:nat)(p:nat)(v:t A p){struct v}
                  : option A :=
  match n,v  with
    _   , nil _ => None
  | 0   , cons _ b  _ _ => Some b
  | S n', cons _ _  p' v' => vector_nth  n'  p' v'
  end.

(* examples *)

Arguments cons {A} h {n}  _ .
Arguments nil {A}.
Arguments vector_nth {A} n {p} v.

Definition v0 := cons true  (cons false  (cons false  nil)).

Lemma test0 : vector_nth 2 v0  = Some false.
Proof. trivial. Qed.

Lemma test1 : vector_nth 7 v0  = None.
Proof. trivial. Qed.

Theorem nth_size : forall {A:Type}(p:nat)(v:t A p)(n:nat),
  vector_nth n v  = None <-> p <= n.
Proof.
 induction v;simpl; auto.
 - intro n; case n; simpl; split; auto with arith.
 - intro n0;case n0;simpl;split.
   +  discriminate.
   +  inversion 1.
   +  case (IHv n1);auto with arith.
   +  case (IHv n1);auto with arith.
Qed.


(** Transparent versions of wf_incl and wf_inverse_image
*)

Require Export Relation_Definitions.

Lemma wf_incl_transparent  :
forall (A : Type) (R1 R2 : A -> A -> Prop),
Relation_Definitions.inclusion A R1 R2 -> well_founded R2 -> well_founded R1.
Proof.
 intros A R1 R2 H H0 a;  induction (H0 a).
 split;  auto.
Defined.

Section Inverse_Image_transp. (* adapted from S.L. *)

  Variables A B : Type.
  Variable R : B -> B -> Prop.
  Variable f : A -> B.

  Let Rof (x y:A) : Prop := R (f x) (f y).

  Remark Acc_lemma : forall y:B, Acc R y -> forall x:A, y = f x -> Acc Rof x.
  Proof.
    induction 1 as [y _ IHAcc]; intros x H.
    apply Acc_intro; intros y0 H1.
    apply (IHAcc (f y0)); try trivial.
    rewrite H; trivial.
   Defined.

  Lemma Acc_inverse_image : forall x:A, Acc R (f x) -> Acc Rof x.
  Proof.
    intros; apply (Acc_lemma (f x)); trivial.
  Defined.

  Theorem wf_inverse_image_transparent : well_founded R -> well_founded Rof.
  Proof.
    red; intros; apply Acc_inverse_image; auto.
  Defined.

End Inverse_Image_transp.


(* Chap 12 Imp *)
(* SIMPLE IMPERATIVE PROGRAMS *)
Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
Import ListNotations.
From LF Require Import Maps.

(* Chap 12.1 Arithmetic and Boolean Expressions *)
(* Chap 12.1.1 Syntax *)
Module AExp.

Inductive aexp : Type :=
  | ANum (n: nat)
  | APlus (a1 a2: aexp)
  | AMinus (a1 a2: aexp)
  | AMult (a1 a2: aexp).

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2: aexp)
  | BLe (a1 a2: aexp)
  | BNot (b: bexp)
  | BAnd (b1 b2: bexp).

(* Chap 12.1.2 Evaluation *)
Fixpoint aeval (a: aexp) : nat :=
  match a with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2 => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

Example test_aeval1:
  aeval (APlus (ANum 2) (ANum 2)) = 4.
Proof.
  simpl. reflexivity.
Qed.

Fixpoint beval (b: bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (aeval a1) =? (aeval a2)
  | BLe a1 a2 => (aeval a1) <=? (aeval a2)
  | BNot b1 => negb (beval b1)
  | BAnd b1 b2 => andb (beval b1) (beval b2)
  end.

(* Chap 12.1.3 Optimization *)
Fixpoint optimize_0plus (a: aexp) : aexp :=
  match a with
  | ANum n => ANum n
  | APlus (ANum 0) e2 => optimize_0plus e2
  | APlus e1 e2 => APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 => AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 => AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

Example test_optimize_0plus:
  optimize_0plus (APlus (ANum 2) (APlus (ANum 0) (APlus (ANum 0) (ANum 1)))) = APlus (ANum 2) (ANum 1).
Proof.
  simpl. reflexivity.
Qed.

Theorem optimize_0plus_sound: forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros.
  induction a.
  - simpl. reflexivity.
  - destruct a1 eqn: Ea1.
    + destruct n eqn: En.
      * simpl. apply IHa2.
      * simpl. rewrite <- IHa2. reflexivity.
    + simpl in *. rewrite IHa1.
      rewrite <- IHa2. reflexivity.
    + simpl in *. rewrite IHa1. rewrite IHa2. reflexivity.
    + simpl in *. rewrite IHa1. rewrite IHa2. reflexivity.
  - simpl. rewrite <- IHa1, IHa2. reflexivity.
  - simpl. rewrite <- IHa1, IHa2. reflexivity.
Qed.

(* Chap 12.2 Coq Automation *)
(* Chap 12.2.1 Tacticals *)
(* Chap 12.2.1.1 The try Tactical *)
Theorem silly1: forall ae, aeval ae = aeval ae.
Proof. try reflexivity. Qed.

Theorem silly2: forall (P: Prop), P -> P.
Proof.
  intros.
  try reflexivity.
  apply H.
Qed.

(* Chap 12.2.1.2 The ; Tactical (Simple Form) *)
Lemma foo: forall n, 0 <=? n = true.
Proof.
  intros.
  destruct n.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Lemma foo': forall n, 0 <=? n = true.
Proof.
  intros.
  destruct n; simpl; reflexivity.
Qed.

Theorem optimize_0plus_sound': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros.
  induction a;
  try (simpl; rewrite IHa1; rewrite IHa2; reflexivity).
  - reflexivity.
  - destruct a1 eqn: Ea1;
    try (simpl in *; rewrite IHa1; rewrite IHa2; reflexivity).
    + destruct n eqn: En; simpl; rewrite IHa2; reflexivity.
Qed.

Theorem optimize_0plus_sound'': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;
  try (simpl; rewrite IHa1; rewrite IHa2; reflexivity);
  try reflexivity.
  - destruct a1; try (simpl in *; rewrite IHa1; rewrite IHa2; reflexivity).
    + destruct n; simpl; rewrite IHa2; reflexivity.
Qed.

(* Chap 12.2.1.3 The ; Tactical (General Form) *)

(* Chap 12.2.1.4 The repeat Tactical *)
Theorem In10: In 10 [1;2;3;4;5;6;7;8;9;10].
Proof. repeat (try (left; reflexivity); right). Qed.

Theorem In10': In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (left; reflexivity).
  repeat (right; try(left; reflexivity)).
Qed.

(* Exercise optimize_0plus_b_sound *)
Fixpoint optimize_0plus_b (b: bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
  | BNot b1 => BNot b1
  | BAnd b1 b2 => BAnd b1 b2
  end.

Theorem optimize_0plus_b_sound: forall b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  intros.
  induction b; simpl;
  try (rewrite optimize_0plus_sound);
  try (rewrite optimize_0plus_sound);
  reflexivity.
Qed.

(* Exercise optimize *)
Fixpoint optimize_and_false (b: bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
  | BNot b1 => BNot (optimize_and_false b1)
  | BAnd b1 b2 =>
    match b1 with
    | BTrue => b2
    | BFalse => BFalse
    | _ => BAnd (optimize_and_false b1) (optimize_and_false b2)
    end
  end.

Theorem optimize_and_false_sound: forall b,
  beval (optimize_and_false b) = beval b.
Proof.
  intros.
  induction b; simpl;
  try (rewrite optimize_0plus_sound);
  try (rewrite optimize_0plus_sound);
  try (rewrite IHb);
  try (reflexivity).
  - destruct b1; simpl in *;
    try (rewrite IHb1);
    try (rewrite IHb2);
    try (rewrite optimize_0plus_sound);
    try (rewrite optimize_0plus_sound);
    try (reflexivity).
Qed.

(* Chap 12.2.2 Defining New Tactic Notations *)
Tactic Notation "simpl_and_try" tactic(c) :=
  simpl; try c.

(* Chap 12.2.3 The omega Tactic *)
Example silly_presburger_example: forall m n o p,
  m + n <= n + o /\ o + 3 = p + 3 -> m <= p.
Proof.
  intros.
  omega.
Qed.

(* Chap 12.2.4 A Few More Handy Tactics *)
(*
  clear H: Delete hypothesis H from the context.
  subst x: For a variable x, find an assumption x = e or e = x in the context,
    replace x with e throughout the context and current goal, and clear the
    assumption.
  subst: Substitute away all assumptions of the form x = e or e = x (where x is
    a variable).
  rename... into...: Change the name of a hypothesis in the proof context. For
    example, if the context includes a variable named x, then rename x into y
    will change all occurrences of x to y.
  assumption: Try to find a hypothesis H in the context that exactly matches the
    goal; if one is found, behave like apply H.
  contradiction: Try to find a hypothesis H in the current context that is logically
    equivalent to False. If one is found, solve the goal.
  constructor: Try to find a constructor c (from some Inductive definition in the
    current environment) that can be applied to solve the current goal. If one is
    found, behave like apply c.
*)

(* Chap 12.3 Evaluation as a Relation *)
Module aevalR_first_try.
Inductive aevalR: aexp -> nat -> Prop :=
  | E_ANum n: aevalR (ANum n) n
  | E_APlus (e1 e2: aexp) (n1 n2: nat): aevalR e1 n1 -> aevalR e2 n2 -> aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat): aevalR e1 n1 -> aevalR e2 n2 -> aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat): aevalR e1 n1 -> aevalR e2 n2 -> aevalR (AMult e1 e2) (n1 * n2).

Module TooHardToRead.
Inductive aevalR: aexp -> nat -> Prop :=
  | E_ANum n: aevalR (ANum n) n
  | E_APlus (e1 e2: aexp) (n1 n2: nat) (H1: aevalR e1 n1) (H2: aevalR e2 n2):
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat) (H1: aevalR e1 n1) (H2: aevalR e2 n2):
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat) (H1: aevalR e1 n1) (H2: aevalR e2 n2):
      aevalR (AMult e1 e2) (n1 * n2).
End TooHardToRead.

Notation "e ‘\\' n" := (aevalR e n)
  (at level 50, left associativity) : type_scope.

End aevalR_first_try.

Reserved Notation "e '\\' n" (at level 90, left associativity).

Inductive aevalR: aexp -> nat -> Prop :=
  | E_ANum (n: nat): (ANum n) \\ n
  | E_APlus (e1 e2: aexp) (n1 n2: nat): (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat): (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat): (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)
where "e '\\' n" := (aevalR e n): type_scope.

(* Chap 12.3.1 Inference Rule Notation *)
(* Exercise beval_rules *)
(* Skipped *)

(* Chap 12.3.2 Equivalence of the Definitions *)
Theorem aeval_iff_aevalR: forall a n,
  (a \\ n) <-> aeval a = n.
Proof.
  intros. split.
  - intros.
    induction H; simpl;
    try (rewrite IHaevalR1, IHaevalR2);
    try (reflexivity).
  - intros.
    generalize dependent n.
    induction a; simpl; intros; subst.
    + apply E_ANum.
    + apply E_APlus.
      apply IHa1; reflexivity.
      apply IHa2; reflexivity.
    + apply E_AMinus.
      apply IHa1; reflexivity.
      apply IHa2; reflexivity.
    + apply E_AMult.
      apply IHa1; reflexivity.
      apply IHa2; reflexivity.
Qed.

Theorem aeval_iff_aevalR': forall a n,
  (a \\ n) <-> aeval a = n.
Proof.
  split.
  - intros H; induction H; subst; reflexivity.
  - generalize dependent n.
    induction a; simpl; intros; subst; constructor;
    try apply IHa1; try apply IHa2; try reflexivity.
Qed.

(* Exercise bevalR *)
Reserved Notation "e '\\\' n" (at level 90, left associativity).

Inductive bevalR: bexp -> bool -> Prop :=
  | E_BTrue: BTrue \\\ true
  | E_BFalse: BFalse \\\ false
  | E_BEq (e1 e2: aexp) (n1 n2: nat):
    (e1 \\ n1) -> (e2 \\ n2) -> (BEq e1 e2) \\\ (n1 =? n2)
  | E_BLe (e1 e2: aexp) (n1 n2: nat):
    (e1 \\ n1) -> (e2 \\ n2) -> (BLe e1 e2) \\\ (n1 <=? n2)
  | E_BNot (e: bexp) (b: bool):
    (e \\\ b) -> (BNot e) \\\ (negb b)
  | E_BAnd (e1 e2: bexp) (b1 b2: bool):
    (e1 \\\ b1) -> (e2 \\\ b2) -> (BAnd e1 e2) \\\ (b1 && b2)
where "e '\\\' n" := (bevalR e n): type_scope.

Lemma beval_iff_bevalR: forall b bv,
  bevalR b bv <-> beval b = bv.
Proof.
  split.
  - intros H; induction H;
    try (apply aeval_iff_aevalR in H; apply aeval_iff_aevalR in H0);
    subst;
    try reflexivity.
  - generalize dependent bv.
    induction b; intros; subst; constructor;
    try apply aeval_iff_aevalR;
    try apply IHb;
    try apply IHb1;
    try apply IHb2;
    reflexivity.
Qed.

End AExp.

(* Chap 12.3.3 Computational vs. Relational Definitions *)
Module aevalR_division.

Inductive aexp: Type :=
  | ANum (n: nat)
  | APlus (a1 a2: aexp)
  | AMinus (a1 a2: aexp)
  | AMult (a1 a2: aexp)
  | ADiv (a1 a2: aexp).

Reserved Notation "e '\\' n"
  (at level 90, left associativity).

Inductive aevalR: aexp -> nat -> Prop :=
  | E_ANum (n: nat): (ANum n) \\ n
  | E_APlus (e1 e2: aexp) (n1 n2: nat): (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat): (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat): (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)
  | E_ADiv (e1 e2: aexp) (n1 n2 n3: nat): (e1 \\ n1) -> (e2 \\ n2) -> (n2 > 0) -> (mult n2 n3 = n1) -> (ADiv e1 e2) \\ n3
where "e '\\' n" := (aevalR e n): type_scope.

End aevalR_division.

Module aevalR_extended.

Reserved Notation "e '\\' n" (at level 90, left associativity).

Inductive aexp: Type :=
  | AAny
  | ANum (n: nat)
  | APlus (a1 a2: aexp)
  | AMinus (a1 a2: aexp)
  | AMult (a1 a2: aexp).

Inductive aevalR: aexp -> nat -> Prop :=
  | E_Any (n: nat) : AAny \\ n
  | E_ANum (n: nat): (ANum n) \\ n
  | E_APlus (e1 e2: aexp) (n1 n2: nat): (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat): (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat): (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)
where "e '\\' n" := (aevalR e n): type_scope.

End aevalR_extended.

(* Chap 12.4 Expressions With Variables *)
(* Chap 12.4.1 State *)
Definition state := total_map nat.

(* Chap 12.4.2 Syntax *)
Inductive aexp: Type :=
  | ANum (n: nat)
  | AId (x: string)
  | APlus (a1 a2: aexp)
  | AMinus (a1 a2: aexp)
  | AMult (a1 a2: aexp).

Definition W: string := "W".
Definition X: string := "X".
Definition Y: string := "Y".
Definition Z: string := "Z".

Inductive bexp: Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2: aexp)
  | BLe (a1 a2: aexp)
  | BNot (b: bexp)
  | BAnd (b1 b2: bexp).

(* Chap 12.4.3 Notations *)
Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.

Definition bool_to_bexp (b : bool) : bexp :=
  if b then BTrue else BFalse.
Coercion bool_to_bexp : bool >-> bexp.

Bind Scope imp_scope with aexp.
Bind Scope imp_scope with bexp.

Delimit Scope imp_scope with imp.
Notation "x + y" := (APlus x y) (at level 50, left associativity) : imp_scope.
Notation "x - y" := (AMinus x y) (at level 50, left associativity) : imp_scope.
Notation "x * y" := (AMult x y) (at level 40, left associativity) : imp_scope.
Notation "x <= y" := (BLe x y) (at level 70, no associativity) : imp_scope.
Notation "x = y" := (BEq x y) (at level 70, no associativity) : imp_scope.
Notation "x && y" := (BAnd x y) (at level 40, left associativity) : imp_scope.
Notation "'~' b" := (BNot b) (at level 75, right associativity) : imp_scope.

Definition example_aexp := (3 + (X * 2)) % imp : aexp.
Definition example_bexp := (true && ~ (X <= 4)) % imp : bexp.

Set Printing Coercions.
Print example_bexp.
Unset Printing Coercions.

(* Chap 12.4.4 Evaluation *)
Fixpoint aeval (st: state) (a: aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2 => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st: state) (b: bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (aeval st a1) =? (aeval st a2)
  | BLe a1 a2 => (aeval st a1) <=? (aeval st a2)
  | BNot b1 => negb (beval st b1)
  | BAnd b1 b2 => andb (beval st b1) (beval st b2)
  end.

Definition empty_st := (_ !-> 0).

Notation "a '!->' x" := (t_update empty_st a x) (at level 100).

Example aexp1: aeval (X !-> 5) (3 + (X * 2)) % imp = 13.
Proof. reflexivity. Qed.

Example bexp1: beval (X !-> 5) (true && ~(X <= 4)) % imp = true.
Proof. reflexivity. Qed.

(* Chap 12.5 Commands *)
(* Chap 12.5.1 Syntax *)
Inductive com: Type :=
  | CSkip
  | CAss (x: string) (a: aexp)
  | CSeq (c1 c2: com)
  | CIf (b: bexp) (c1 c2: com)
  | CWhile (b: bexp) (c: com).

Bind Scope imp_scope with com.
Notation "'SKIP'" := CSkip : imp_scope.
Notation "x '::=' a" := (CAss x a) (at level 60) : imp_scope.
Notation "c1 ;; c2" := (CSeq c1 c2) (at level 80, right associativity) : imp_scope.
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity) : imp_scope.
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity) : imp_scope.

Definition fact_in_coq: com :=
 (Z ::= X;;
  Y ::= 1;;
  WHILE ~(Z = 0) DO
    Y ::= Y * Z;;
    Z ::= Z - 1
  END) % imp.

(* Chap 12.5.2 Desugaring notations *)
Unset Printing Notations.
Print fact_in_coq.
Set Printing Notations.

Set Printing Coercions.
Print fact_in_coq.
Unset Printing Coercions.

(* Chap 12.5.3 The Locate command *)
Locate "&&".
Locate ";;".
Locate "WHILE".
Locate aexp.

(* Chap 12.5.4 More Examples *)
Definition plus2: com :=
  X ::= X + 2.

Definition XtimesYinZ : com :=
  Z ::= X * Y.

Definition subtract_slowly_body : com :=
  Z ::= Z - 1 ;;
  X ::= X - 1.

Definition subtract_slowly : com :=
 (WHILE ~(X = 0) DO
    subtract_slowly_body
  END) % imp.

Definition loop : com :=
  WHILE true DO SKIP END.

(* Chap 12.6 Evaluating Commands *)
(* Chap 12.6.1 Evaluation as a Function (Failed Attempt) *)
Open Scope imp_scope.
Fixpoint ceval_fun_no_while (st: state) (c: com) : state :=
  match c with
  | SKIP => st
  | x ::= a1 => (x !-> (aeval st a1); st)
  | c1 ;; c2 => let st' := ceval_fun_no_while st c1 in
                ceval_fun_no_while st' c2
  | TEST b THEN c1 ELSE c2 FI =>
      if (beval st b) then ceval_fun_no_while st c1
      else ceval_fun_no_while st c2
  | WHILE b DO c END => st
  end.

Close Scope imp_scope.

(* Chap 12.6.2 Evaluation as a Relation *)
Reserved Notation "st '=[' c ']=>' st'" (at level 40).

Inductive ceval: com -> state -> state -> Prop :=
  | E_Skip: forall st, st =[ SKIP ]=> st
  | E_Ass: forall st a1 n x, aeval st a1 = n -> st =[ x ::= a1 ]=> (x !-> n; st)
  | E_Seq: forall c1 c2 st st' st'', st =[ c1 ]=> st' -> st' =[ c2 ]=> st'' -> st =[ c1;; c2 ]=> st''
  | E_IfTrue: forall st st' b c1 c2, beval st b = true -> st =[ c1 ]=> st' -> st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_IfFalse: forall st st' b c1 c2, beval st b = false -> st =[ c2 ]=> st' -> st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_WhileFalse: forall b st c, beval st b = false -> st =[ WHILE b DO c END ]=> st
  | E_WhileTrue: forall st st' st'' b c, beval st b = true -> st =[ c ]=> st' -> st' =[ WHILE b DO c END ]=> st'' -> st =[ WHILE b DO c END ]=> st''
where "st =[ c ]=> st'" := (ceval c st st').

Example ceval_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI]=> (Z !-> 4; X !-> 2).
Proof.
  apply E_Seq with (X !-> 2).
  - apply E_Ass. simpl. reflexivity.
  - apply E_IfFalse. reflexivity.
    apply E_Ass. reflexivity.
Qed.

(* Exercise ceval_example2 *)
Example ceval_example2:
  empty_st =[
    X ::= 0;; Y ::= 1;; Z ::= 2
  ]=> (Z !-> 2; Y !-> 1; X !-> 0).
Proof.
  apply E_Seq with (X !-> 0).
  - apply E_Ass. reflexivity.
  - apply E_Seq with (Y !-> 1; X !-> 0).
    + apply E_Ass. reflexivity.
    + apply E_Ass. reflexivity.
Qed.

(* Example pup_to_n *)
Definition pup_to_n: com :=
  Y ::= 0;;
  WHILE (~ (X = 0)) DO
    Y ::= Y + X;;
    X ::= X - 1
  END.

Theorem pup_to_2_ceval:
  (X !-> 2) =[ pup_to_n ]=> (X !-> 0; Y !-> 3; X !-> 1; Y !-> 2; Y !-> 0; X !-> 2).
Proof.
  apply E_Seq with (Y !-> 0; X !-> 2).
  - apply E_Ass. reflexivity.
  - apply E_WhileTrue with (X !-> 1; Y !-> 2; Y !-> 0; X !-> 2).
    + reflexivity.
    + apply E_Seq with (Y !-> 2; Y !-> 0; X !-> 2).
      * apply E_Ass. reflexivity.
      * apply E_Ass. reflexivity.
    + apply E_WhileTrue with (X !-> 0; Y !-> 3; X !-> 1; Y !-> 2; Y !-> 0; X !-> 2).
      * reflexivity.
      * apply E_Seq with (Y !-> 3; X !-> 1; Y !-> 2; Y !-> 0; X !-> 2); apply E_Ass; reflexivity.
      * apply E_WhileFalse.
        reflexivity.
Qed.

(* Chap 12.6.3 Determinism of Evaluation *)
Theorem ceval_deterministic: forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1; intros st2 E2; inversion E2; subst; try reflexivity.
  - assert (st' = st'0) as EQ1.
    { apply IHE1_1, H1. }
    subst st'0.
    apply IHE1_2, H4.
  - apply IHE1. assumption.
  - rewrite H in H5. discriminate.
  - rewrite H in H5. discriminate.
  - apply IHE1. assumption.
  - rewrite H in H2. discriminate.
  - rewrite H in H4. discriminate.
  - assert (st' = st'0) as EQ1.
    { apply IHE1_1. assumption. }
    subst st'0.
    apply IHE1_2. assumption.
Qed.

(* Chap 12.7 Reasoning About Imp Programs *)
Theorem plus2_spec: forall st n st',
  st X = n -> st =[ plus2 ]=> st' ->
  st' X = n + 2.
Proof.
  intros st n st' HX Heval.
  inversion Heval. subst. clear Heval.
  simpl. apply t_update_eq.
Qed.

(* Exercise XtimesYinZ_spec *)
Theorem XtimesYinZ_spec: forall st n m st',
  st X = n -> st Y = m -> st =[ XtimesYinZ ]=> st' ->
  st' Z = n * m.
Proof.
  intros st n m st' HX HY Heval.
  inversion Heval.
  subst. clear Heval.
  simpl. apply t_update_eq.
Qed.

Print total_map.

(* Exercise loop_never_stops *)
Theorem loop_never_stops: forall st st',
  ~(st =[ loop ]=> st').
Proof.
  intros st st' contra.
  unfold loop in contra.
  remember (WHILE true DO SKIP END) % imp as loopdef eqn: Heqloopdef.
  induction contra; try discriminate.
  - inversion Heqloopdef. subst. simpl in H. discriminate.
  - apply IHcontra2. apply Heqloopdef.
Qed.

(* Exercise no_whiles_eqv *)
Open Scope imp_scope.
Fixpoint no_whiles (c: com) : bool :=
  match c with
  | SKIP => true
  | _ ::= _ => true
  | c1 ;; c2 => andb (no_whiles c1) (no_whiles c2)
  | TEST _ THEN ct ELSE cf FI =>
      andb (no_whiles ct) (no_whiles cf)
  | WHILE _ DO _ END => false
  end.
Close Scope imp_scope.

Inductive no_whilesR: com -> Prop :=
  | no_whiles_Skip: no_whilesR SKIP
  | no_whiles_Ass: forall s n, no_whilesR (s ::= n)
  | no_whiles_Seq: forall e1 e2, no_whilesR e1 -> no_whilesR e2 -> no_whilesR (e1 ;; e2)
  | no_whiles_If: forall e1 e2 b, no_whilesR e1 -> no_whilesR e2 -> no_whilesR (TEST b THEN e1 ELSE e2 FI).

Theorem no_whiles_eqv:
  forall c, no_whiles c = true <-> no_whilesR c.
Proof.
  split.
  - intros.
    induction c;
    try constructor;
    try inversion H;
    try (apply andb_true_iff in H1; destruct H1 as [H2 H3]);
    try apply IHc1; try apply IHc2;
    try apply H2; try apply H3.
  - intros.
    induction H;
    simpl;
    try (apply andb_true_iff; split);
    try apply IHno_whilesR1;
    try apply IHno_whilesR2;
    try reflexivity.
Qed.

(* Exercise no_whiles_terminating *)
Theorem no_whiles_terminating: forall c st,
  no_whilesR c -> exists st', st =[ c ]=> st'.
Proof.
  intros c.
  induction c; intros.
  - exists st. constructor.
  - exists (x !-> (aeval st a); st).
    constructor. reflexivity.
  - inversion H. subst.
    apply IHc1 with (st := st) in H2.
    destruct H2 as [st' H2].
    apply IHc2 with (st := st') in H3.
    destruct H3 as [st'' H3].
    exists st''.
    apply (E_Seq c1 c2 st st' st'').
    apply H2. apply H3.
  - inversion H. subst.
    apply IHc1 with (st := st) in H2.
    apply IHc2 with (st := st) in H4.
    destruct H2 as [st1 H1].
    destruct H4 as [st2 H2].
    destruct (beval st b) eqn: Eb.
    + exists st1. apply E_IfTrue. apply Eb. apply H1.
    + exists st2. apply E_IfFalse. apply Eb. apply H2.
  - inversion H.
Qed.

(*** Additional Exercise ***)
(* Exercise stack_complier *)
Inductive sinstr : Type :=
  | SPush (n: nat)
  | SLoad (x: string)
  | SPlus
  | SMinus
  | SMult.

Fixpoint s_execute (st: state) (stack: list nat) (prog: list sinstr) : list nat :=
  match prog with
  | nil => stack
  | progh :: progt =>
    match progh with
    | SPush n => s_execute st (n :: stack) progt
    | SLoad x => s_execute st ((st x) :: stack) progt
    | SPlus =>
      match stack with
      | h1 :: h2 :: t => s_execute st ((h2 + h1) :: t) progt
      | _ => s_execute st stack progt
      end
    | SMinus =>
      match stack with
      | h1 :: h2 :: t => s_execute st ((h2 - h1) :: t) progt
      | _ => s_execute st stack progt
      end
    | SMult =>
      match stack with
      | h1 :: h2 :: t => s_execute st ((h2 * h1) :: t) progt
      | _ => s_execute st stack progt
      end
    end
  end.

Example s_execute1 :
     s_execute empty_st []
       [SPush 5; SPush 3; SPush 1; SMinus]
   = [2; 5].
Proof. reflexivity. Qed.

Example s_execute2 :
     s_execute (X !-> 3) [3;4]
       [SPush 4; SLoad X; SMult; SPlus]
   = [15; 4].
Proof. reflexivity. Qed.

Fixpoint s_compile (e: aexp): list sinstr :=
  match e with
  | ANum n => [SPush n]
  | AId id => [SLoad id]
  | APlus e1 e2 => (s_compile e1) ++ (s_compile e2) ++ [SPlus]
  | AMinus e1 e2 => (s_compile e1) ++ (s_compile e2) ++ [SMinus]
  | AMult e1 e2 => (s_compile e1) ++ (s_compile e2) ++ [SMult]
  end.

Example s_compile1 :
  s_compile (X - (2 * Y))%imp
  = [SLoad X; SPush 2; SLoad Y; SMult; SMinus].
Proof. reflexivity. Qed.

(* Exercise stack_compiler_correct *)
Lemma s_compile_seq: forall st stack prog1 prog2,
  s_execute st stack (prog1 ++ prog2) = s_execute st (s_execute st stack prog1) prog2.
Proof.
  intros st stack prog1.
  generalize dependent st.
  generalize dependent stack.
  induction prog1; intros; simpl; try reflexivity.
  - intros. simpl.
    destruct a;
    try apply IHprog1;
    try destruct stack;
    try apply IHprog1;
    try destruct stack;
    try apply IHprog1;
    try apply IHprog1.
Qed.

Lemma s_compile_correct_strong: forall st stack e,
  s_execute st stack (s_compile e) = [ aeval st e ] ++ stack.
Proof.
  intros st stack e.
  generalize dependent stack.
  induction e; intros; simpl;
  try (rewrite s_compile_seq;
       rewrite s_compile_seq;
       rewrite IHe1;
       rewrite IHe2);
  try reflexivity.
Qed.

Theorem s_compile_correct: forall (st: state) (e: aexp),
  s_execute st [] (s_compile e) = [ aeval st e ].
Proof.
  intros. apply (s_compile_correct_strong st [] e).
Qed.

(* Exercise short_circuit *)
Fixpoint beval' (st: state) (b: bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (aeval st a1) =? (aeval st a2)
  | BLe a1 a2 => (aeval st a1) <=? (aeval st a2)
  | BNot b1 => negb (beval' st b1)
  | BAnd b1 b2 =>
    if (beval' st b1) then (beval' st b2)
    else false
  end.

Theorem beval'_eq_beval: forall st b,
  beval' st b = beval st b.
Proof.
  intros.
  induction b; try reflexivity.
Qed.

(* Exercise break_imp *)
Module BreakImp.

Inductive com : Type :=
  | CSkip
  | CBreak
  | CAss (x: string) (a: aexp)
  | CSeq (c1 c2: com)
  | CIf (b: bexp) (c1 c2: com)
  | CWhile (b: bexp) (c: com).

Notation "'SKIP'" := CSkip.
Notation "'BREAK'" := CBreak.
Notation "x '::=' a" := (CAss x a) (at level 60).
Notation "c1 ;; c2" := (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" := (CWhile b c) (at level 80, right associativity).
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" := (CIf c1 c2 c3) (at level 80, right associativity).

Inductive result: Type :=
  | SContinue
  | SBreak.

Reserved Notation "st '=[' c ']=>' st' '/' s"
  (at level 40, st' at next level).

Inductive ceval: com -> state -> result -> state -> Prop :=
  | E_Skip: forall st, st =[ CSkip ]=> st / SContinue
  | E_Break: forall st, st =[ CBreak ]=> st / SBreak
  | E_Ass: forall a1 n x st, aeval st a1 = n -> st =[ x ::= a1 ]=> (x !-> n; st) / SContinue
  | E_SeqBreak: forall c1 c2 st st', st =[ c1 ]=> st' / SBreak -> st =[ c1;; c2 ]=> st' / SBreak
  | E_SeqContinue: forall c1 c2 st st' st'' res, st =[ c1 ]=> st' / SContinue -> st =[ c2 ]=> st'' / res -> st =[ c1;; c2 ]=> st'' / res
  | E_IfTrue: forall b c1 c2 st st' res, beval st b = true -> st =[ c1 ]=> st' / res -> st =[ TEST b THEN c1 ELSE c2 FI ]=> st' / res
  | E_IfFalse: forall b c1 c2 st st' res, beval st b = false -> st =[ c2 ]=> st' / res -> st =[ TEST b THEN c1 ELSE c2 FI ]=> st' / res
  | E_WhileFalse: forall b c st, beval st b = false -> st =[ WHILE b DO c END ]=> st / SContinue
  | E_WhileTrue: forall b c st st' st'', beval st b = true -> st =[ c ]=> st' / SContinue -> st' =[ WHILE b DO c END ]=> st'' / SContinue -> st =[ WHILE b DO c END]=> st'' / SContinue
  | E_WhileBreak: forall b c st st', beval st b = true -> st =[ c ]=> st' / SBreak -> st =[ WHILE b DO c END ]=> st' / SContinue
where "st '=[' c ']=>' st' '/' s" := (ceval c st s st').

Theorem break_ignore: forall c st st' s,
  st =[ BREAK;; c ]=> st' / s -> st = st'.
Proof.
  intros.
  inversion H.
  subst. inversion H5. reflexivity.
  subst. inversion H2.
Qed.

Theorem while_continue: forall b c st st' s,
  st =[ WHILE b DO c END ]=> st' / s -> s = SContinue.
Proof.
  intros.
  inversion H; reflexivity.
Qed.

Theorem while_stops_on_break: forall b c st st',
  beval st b = true ->
  st =[ c ]=> st' / SBreak ->
  st =[ WHILE b DO c END ]=> st' / SContinue.
Proof.
  intros.
  constructor.
  apply H.
  apply H0.
Qed.

(* Exercise while_break_true *)
Theorem while_break_true: forall b c st st',
  st =[ WHILE b DO c END ]=> st' / SContinue ->
  beval st' b = true ->
  exists st'', st'' =[ c ]=> st' / SBreak.
Proof.
  intros.
  remember (WHILE b DO c END) as loop.
  induction H; try inversion Heqloop; subst; clear Heqloop; simpl in *.
  - rewrite H in H0. discriminate.
  - apply IHceval2. reflexivity. apply H0.
  - exists st. apply H1.
Qed.

(* Exercise ceval_deterministic *)
Theorem ceval_deterministic: forall (c: com) st st1 st2 s1 s2,
  st =[ c ]=> st1 / s1 ->
  st =[ c ]=> st2 / s2 ->
  st1 = st2 /\ s1 = s2.
Proof.
  intros.
  generalize dependent st2.
  generalize dependent s2.
  induction H; intros.
  - (* E_Skip *) inversion H0. auto.
  - (* E_Break *) inversion H0. auto.
  - (* E_Ass *) inversion H0. subst. auto.
  - (* E_SeqBreak *) inversion H0; subst.
    + (* other E_SeqBreak *) auto.
    + (* other E_SeqContinue *)
      assert (st' = st'0 /\ SBreak = SContinue).
      { apply IHceval. apply H3. }
      inversion H1. discriminate.
  - (* E_SeqContinue *) inversion H1; subst.
    + (* other SeqBreak *)
      assert (st' = st2 /\ SContinue = SBreak).
      { apply IHceval1. apply H7. }
      inversion H2. discriminate.
    + (* other SeqContinue *) subst.
      apply IHceval2, H8.
  - (* E_IfTrue *) inversion H1; subst.
    + (* other E_IfTrue *) apply IHceval, H9.
    + (* other E_IfFalse *) rewrite H8 in H. discriminate.
  - (* E_IfFalse *) inversion H1; subst.
    + (* other E_IfTrue *) rewrite H8 in H. discriminate.
    + (* other E_IfFalse *) apply IHceval, H9.
  - (* E_WhileFalse *) inversion H0; subst; try auto; try (rewrite H3 in H; discriminate).
  - (* E_WhileTrue *) inversion H2; subst.
    + (* other E_WhileFalse *) rewrite H8 in H. discriminate.
    + (* other E_WhileTrue *) apply IHceval2.
      assert (st' = st'0 /\ SContinue = SContinue).
      { apply IHceval1. apply H6. }
      inversion H3. rewrite H4. apply H10.
    + (* other E_WhileBreak *)
      assert (st' = st2 /\ SContinue = SBreak).
      { apply IHceval1. apply H9. }
      inversion H3. discriminate.
  - (* E_WhileBreak *) inversion H1; subst.
    + (* other E_WhileFalse *) rewrite H7 in H. discriminate.
    + (* other E_WhileTrue *)
      assert (st' = st'0 /\ SBreak = SContinue).
      { apply IHceval. apply H5. }
      inversion H2. discriminate.
    + (* other E_WhileBreak *)
      assert (st' = st2 /\ SBreak = SBreak).
      { apply IHceval. apply H8. }
      inversion H2. auto.
Qed.

End BreakImp.

(* Exercise add_for_loop *)

Module ForImp.

Inductive com : Type :=
  | FSkip
  | FAss (x: string) (a: aexp)
  | FSeq (c1 c2: com)
  | FIf (b: bexp) (c1 c2: com)
  | FWhile (b: bexp) (c: com)
  | FFor (c1: com) (b: bexp) (c2: com) (c3: com).

Notation "'SKIP'" := FSkip.
Notation "x '::=' a" := (FAss x a) (at level 60).
Notation "c1 ;; c2" := (FSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" := (FWhile b c) (at level 80, right associativity).
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" := (FIf c1 c2 c3) (at level 80, right associativity).
Notation "'FOR' '(' c1 ';' b ';' c2 ')' 'DO' c3 'END'" := (FFor c1 b c2 c3) (at level 80, right associativity).

Reserved Notation "st '=[' c ']=>' st'" (at level 40, st' at next level).
Inductive cval: state -> com -> state -> Prop :=
  | F_Skip: forall st, st =[ FSkip ]=> st
  | F_Ass: forall x a st, st =[ FAss x a ]=> (x !-> (aeval st a); st)
  | F_Seq: forall c1 c2 st st' st'', st =[ c1 ]=> st' -> st' =[ c2 ]=> st'' -> st =[ c1;; c2 ]=> st''
  | F_IfTrue: forall b c1 c2 st st', beval st b = true -> st =[ c1 ]=> st' -> st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | F_IfFalse: forall b c1 c2 st st', beval st b = false -> st =[ c2 ]=> st' -> st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | F_WhileFalse: forall b c st, beval st b = false -> st =[ WHILE b DO c END ]=> st
  | F_WhileTrue: forall b c st st' st'', beval st b = true -> st =[ c ]=> st' -> st' =[ WHILE b DO c END ]=> st'' -> st =[ WHILE b DO c END ]=> st''
  | F_For: forall b c1 c2 c3 st st', st =[ c1 ;; WHILE b DO c3 ;; c2 END ]=> st' -> st =[ FOR ( c1; b; c2 ) DO c3 END ]=> st'
where "st '=[' c ']=>' st'" := (cval st c st').

Definition for_imp_prog : com :=
  (Y ::= (ANum 0);;
    FOR ( X ::= (ANum 1) ; BNot (BEq (AId X) (ANum 0)) ; X ::= AMinus (AId X) (ANum 1) )
    DO Y ::= APlus (AId X) (AId Y) END).

Example for_imp_ex: empty_st =[ for_imp_prog ]=> (X !-> 0; Y !-> 1; X !-> 1; Y !-> 0).
Proof.
  unfold for_imp_prog.
  apply F_Seq with (Y !-> 0).
  constructor.
  apply F_For.
  apply F_Seq with (X !-> 1; Y !-> 0).
  constructor.
  apply F_WhileTrue with (X !-> 0; Y !-> 1; X !-> 1; Y !-> 0).
  constructor.
  apply F_Seq with (Y !-> 1; X !-> 1; Y !-> 0).
  constructor.
  constructor.
  apply F_WhileFalse.
  constructor.
Qed.

End ForImp.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf2 : natural) (lf1 : natural) : natural :=
  mult (Succ Zero) lf1.


Variable G : Set.
Variable operation : G -> G -> G.
Variable e : G.
Variable inv : G -> G.
Infix "×" := operation (left associativity, at level 50).
Theorem latin_square_property_decl : forall a b : G, exists x : G, a × x = b.
Proof.
  let a : G, b : G.
  take (inv a × b).
  have H1:(a × (inv a × b) = (a × inv a) × b) by associativity.
  have H2:(a × inv a = e) by inverse.
  have (a × (inv a × b) - e × b) by H1, H2.
                                      = b by identity.
  hence thesis.
end proof.
Qed.


(* Pierre Casteran, LaBRI, Univ. Bordeaux *)

Set Implicit Arguments.

From Coq Require Import Relations Ensembles.

(* begin snippet isLubDef *)

Definition upper_bound (M:Type)
                       (D: Ensemble M)
                       (lt: relation M)
                       (X:Ensemble M)
                       (a:M) :=
  forall x, In _ D x ->  In _ X x -> x = a \/ lt  x a.

Definition is_lub (M:Type)
                  (D : Ensemble M)
                  (lt : relation M)
                  (X:Ensemble M)
                  (a:M) :=
   In _ D a  /\ upper_bound  D lt X a  /\
   (forall y, In _ D y ->
              upper_bound  D lt X y  ->
              y = a \/ lt a y).

(* end snippet isLubDef *)


(*|
##################################
Induction on record member in Coq?
##################################

:Link: https://stackoverflow.com/q/48840413
|*)

(*|
Question
********

Consider a simple example of induction on a record member:
|*)

Record Foo : Type := mkFoo { foo: nat }.

Definition double (f: Foo) : Foo :=
  mkFoo (2 * foo f)%nat.

Theorem double_doubles: forall (f: Foo),
    foo (double f) = (2 * foo f)%nat.
Proof.
  intros.
  induction (foo f).
  (* How do I prevent this loss of information? *)
  (* stuck? *)
Abort.

Theorem double_doubles: forall (f: Foo),
    foo (double f) = (2 * foo f)%nat.
Proof.
  intros. destruct f.
  (* destruct is horrible if your record is large / contains many things *)
  induction foo0.
  - simpl. auto.
  - intros. simpl. auto.
Qed.

(*|
At ``induction (foo f)``, I am stuck with the goal ``foo (double f) =
2 * 0``.

I have somehow lost information that I am perform induction on ``foo
f`` (I have no hypothesis stating that ``foo f = 0``).

However, ``destruct f`` is unsatisfying, because I have ~5 member
records that look very ugly in the hypothesis section when expanded
out.
|*)

(*|
Answer
******

You can use the ``remember`` tactic to give a name to an expression,
yielding a variable that you can analyze inductively. The tactic
generates an equation connecting the variable to the remembered
expression, allowing you to keep track of the information you need.

To illustrate, consider the following proof script.
|*)

Reset Initial. (* .none *)
Record Foo : Type := mkFoo { foo: nat }.

Definition double (f: Foo) : Foo :=
  mkFoo (2 * foo f)%nat.

Theorem double_doubles: forall (f: Foo),
    foo (double f) = (2 * foo f)%nat.
Proof.
  intros. remember (foo f) as n eqn:E.
  revert f E. induction n.

(*| After calling ``remember``, the goal becomes: |*)

  Undo 2. (* .none *) Show. (* .unfold .messages *)

(*|
If you do induction on ``n`` directly after ``remember``, it is
possible that you won't be able to complete your proof, because the
induction hypothesis you will get will not be general enough. If you
run into this problem, you might need to generalize some of the
variables that appear in the expression defining ``n``. In the script
above, the call ``revert f E`` puts ``f`` and ``E`` back into the
goal, which solves this problem.

----

**Q:** Thanks! is there a difference between ``revert`` and
``generalize dependent``?

**A:** ``revert`` will give you an error if you try to revert
something that appears in the type of another term or hypothesis in
the context. ``generalize dependent`` will compute all the terms whose
types depend on the generalized one, and will put those back as well.

**Q:** And between ``revert dependent`` and ``generalize dependent``?

**A:** Good question. I do not know.
|*)


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

(*i $Id: Zcomplements.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import ZArithRing.
Require Import ZArith_base.
Require Export Omega.
Require Import Wf_nat.
Open Local Scope Z_scope.

(**********************************************************************)
(** About parity *)

Lemma two_or_two_plus_one :
  forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}.
Proof.
  intro x; destruct x.
  left; split with 0; reflexivity.

  destruct p.
  right; split with (Zpos p); reflexivity.

  left; split with (Zpos p); reflexivity.

  right; split with 0; reflexivity.

  destruct p.
  right; split with (Zneg (1 + p)).
  rewrite BinInt.Zneg_xI.
  rewrite BinInt.Zneg_plus_distr.
  omega.

  left; split with (Zneg p); reflexivity.

  right; split with (-1); reflexivity.
Qed.

(**********************************************************************)
(** The biggest power of 2 that is stricly less than [a]

    Easy to compute: replace all "1" of the binary representation by
    "0", except the first "1" (or the first one :-) *)

Fixpoint floor_pos (a:positive) : positive :=
  match a with
    | xH => 1%positive
    | xO a' => xO (floor_pos a')
    | xI b' => xO (floor_pos b')
  end.

Definition floor (a:positive) := Zpos (floor_pos a).

Lemma floor_gt0 : forall p:positive, floor p > 0.
Proof.
  intro.
  compute in |- *.
  trivial.
Qed.

Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p.
Proof.
  unfold floor in |- *.
  intro a; induction a as [p| p| ].

  simpl in |- *.
  repeat rewrite BinInt.Zpos_xI.
  rewrite (BinInt.Zpos_xO (xO (floor_pos p))).
  rewrite (BinInt.Zpos_xO (floor_pos p)).
  omega.

  simpl in |- *.
  repeat rewrite BinInt.Zpos_xI.
  rewrite (BinInt.Zpos_xO (xO (floor_pos p))).
  rewrite (BinInt.Zpos_xO (floor_pos p)).
  rewrite (BinInt.Zpos_xO p).
  omega.

  simpl in |- *; omega.
Qed.

(**********************************************************************)
(** Two more induction principles over [Z]. *)

Theorem Z_lt_abs_rec :
  forall P:Z -> Set,
    (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
    forall n:Z, P n.
Proof.
  intros P HP p.
  set (Q := fun z => 0 <= z -> P z * P (- z)) in *.
  cut (Q (Zabs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ].
  elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
  unfold Q in |- *; clear Q; intros.
  apply pair; apply HP.
  rewrite Zabs_eq; auto; intros.
  elim (H (Zabs m)); intros; auto with zarith.
  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
  rewrite Zabs_non_eq; auto with zarith.
  rewrite Zopp_involutive; intros.
  elim (H (Zabs m)); intros; auto with zarith.
  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
Qed.

Theorem Z_lt_abs_induction :
  forall P:Z -> Prop,
    (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
    forall n:Z, P n.
Proof.
  intros P HP p.
  set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *.
  cut (Q (Zabs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ].
  elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
  unfold Q in |- *; clear Q; intros.
  split; apply HP.
  rewrite Zabs_eq; auto; intros.
  elim (H (Zabs m)); intros; auto with zarith.
  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
  rewrite Zabs_non_eq; auto with zarith.
  rewrite Zopp_involutive; intros.
  elim (H (Zabs m)); intros; auto with zarith.
  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
Qed.

(** To do case analysis over the sign of [z] *)

Lemma Zcase_sign :
  forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P.
Proof.
  intros x P Hzero Hpos Hneg.
  induction  x as [| p| p].
  apply Hzero; trivial.
  apply Hpos; apply Zorder.Zgt_pos_0.
  apply Hneg; apply Zorder.Zlt_neg_0.
Qed.

Lemma sqr_pos : forall n:Z, n * n >= 0.
Proof.
  intro x.
  apply (Zcase_sign x (x * x >= 0)).
  intros H; rewrite H; omega.
  intros H; replace 0 with (0 * 0).
  apply Zmult_ge_compat; omega.
  omega.
  intros H; replace 0 with (0 * 0).
  replace (x * x) with (- x * - x).
  apply Zmult_ge_compat; omega.
  ring.
  omega.
Qed.

(**********************************************************************)
(** A list length in Z, tail recursive.  *)

Require Import List.

Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z :=
  match l with
    | nil => acc
    | _ :: l => Zlength_aux (Zsucc acc) A l
  end.

Definition Zlength := Zlength_aux 0.
Implicit Arguments Zlength [A].

Section Zlength_properties.

  Variable A : Type.

  Implicit Type l : list A.

  Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l).
  Proof.
    assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)).
    simple induction l.
    simpl in |- *; auto with zarith.
    intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S.
    simpl in |- *; rewrite H; auto with zarith.
    unfold Zlength in |- *; intros; rewrite H; auto.
  Qed.

  Lemma Zlength_nil : Zlength (A:=A) nil = 0.
  Proof.
    auto.
  Qed.

  Lemma Zlength_cons : forall (x:A) l, Zlength (x :: l) = Zsucc (Zlength l).
  Proof.
    intros; do 2 rewrite Zlength_correct.
    simpl (length (x :: l)) in |- *; rewrite Znat.inj_S; auto.
  Qed.

  Lemma Zlength_nil_inv : forall l, Zlength l = 0 -> l = nil.
  Proof.
    intro l; rewrite Zlength_correct.
    case l; auto.
    intros x l'; simpl (length (x :: l')) in |- *.
    rewrite Znat.inj_S.
    intros; exfalso; generalize (Zle_0_nat (length l')); omega.
  Qed.

End Zlength_properties.

Implicit Arguments Zlength_correct [A].
Implicit Arguments Zlength_cons [A].
Implicit Arguments Zlength_nil_inv [A].


(** The definition of Dedekind cuts. *)

Require Import QArith QOrderedType.
Require Import Morphisms SetoidClass.
Require Import MiscLemmas.

(** In the definition below we use disjunction and existence where one might
    expect sums and disjoint sums, in particular in [lower_open], [upper_open],
    and [located].

    See "Extensional constructive real analysis via locators" by Auke Booij,
    https://export.arxiv.org/abs/1805.06781, for a discussion of what happens
    when we replace the disjunction in [located] with a sum (spoiler: we get
    the Cauchy reals!).
*)

(** A Dedekind cut is represented by the predicates [lower] and [upper],
    satisfying a number of conditions. *)
Structure R := {
  (* The cuts are represented as propositional functions, rather than subsets,
     as there are no subsets in type theory. *)
  lower : Q -> Prop;
  upper : Q -> Prop;
  (* The cuts respect equality on Q. *)
  lower_proper : Proper (Qeq ==> iff) lower;
  upper_proper : Proper (Qeq ==> iff) upper;
  (* The cuts are inhabited. *)
  lower_bound : exists q : Q, lower q;
  upper_bound : exists r : Q, upper r;
  (* The lower cut is a lower set. *)
  lower_lower : forall q r, q < r -> lower r -> lower q;
  (* The lower cut is open. *)
  lower_open : forall q, lower q -> exists r, q < r /\ lower r;
  (* The upper cut is an upper set. *)
  upper_upper : forall q r, q < r -> upper q -> upper r;
  (* The upper cut is open. *)
  upper_open : forall r, upper r -> exists q,  q < r /\ upper q;
  (* The cuts are disjoint. *)
  disjoint : forall q, ~ (lower q /\ upper q);
  (* There is no gap between the cuts. *)
  located : forall q r, q < r -> lower q \/ upper r
}.

(** Strict order. *)
Definition Rlt (x y : R) := exists q : Q, upper x q /\ lower y q.

(** Non-strict order. *)
Definition Rle (x y : R) := forall q, lower x q -> lower y q.

(** Non-strict order in terms of upper cuts, and a proof they are
    equivalent. *)

Definition Rle_upper (x y : R) := forall q, upper y q -> upper x q.

Lemma Rle_equiv (x y : R) : Rle x y <-> Rle_upper x y.
Proof.
  split.
  - intros ? q Uyq.
    destruct (upper_open y q Uyq) as [r [G ?]].
    destruct (located x _ _ G) ; auto.
    exfalso ; apply (disjoint y r) ; auto.
  - intros ? q Lxq.
    destruct (lower_open x q Lxq) as [r [G ?]].
    destruct (located y _ _ G) ; auto.
    exfalso ; apply (disjoint x r) ; auto.
Qed.

(* Rle is a negative proposition *)
Lemma Rnot_lt_le : forall r1 r2:R, ~ Rlt r1 r2 <-> Rle r2 r1.
Proof.
  split.
  - intros. intros q l. unfold Rlt in H.
    destruct (lower_open r2 q l), H0.
    assert (~upper r1 x).
    { intro abs. apply H. exists x. split; assumption. }
    destruct (located r1 q x H0). exact H3. contradiction.
  - intros H [r [H0 H1]]. specialize (H r H1).
    apply (disjoint r1 r); split; assumption.
Qed.

(** Equality. *)
Definition Req (x y : R) := Rle x y /\ Rle y x.

(** Equality in terms of upper cuts, and a proof they are equivalent. *)
Definition Req_upper (x y : R) := Rle_upper x y /\ Rle_upper y x.

Lemma Req_equiv (x y : R) : Req x y <-> Req_upper x y.
Proof.
  unfold Req, Req_upper.
  split ; intros [? ?] ; split ; apply Rle_equiv ; assumption.
Qed.

(** We explain to Coq how to derive automatically that [lower] and [upper] are proper.
    This way [lower] and [upper] will behave with respect to [setoid_rewrite]. *)
Instance R_lower_proper : Proper (Req ==> Qeq ==> iff) lower.
Proof.
  intros x y [Exy1 Exy2] q r Eqr ; split ; intro H.
  - apply Exy1, (lower_proper x q r) ; assumption.
  - apply Exy2, (lower_proper y q r) ; assumption.
Qed.

Instance R_upper_proper : Proper (Req ==> Qeq ==> iff) upper.
Proof.
  intros x y [Exy1 Exy2] q r Eqr.
  apply Rle_equiv in Exy1.
  apply Rle_equiv in Exy2.
  split ; intro H.
  - apply Exy2, (upper_proper x q r) ; assumption.
  - apply Exy1, (upper_proper y q r) ; assumption.
Qed.

(** Apartness. *)
Definition Rneq (x y : R) := (Rlt x y \/ Rlt y x)%type.

(** We introduce notation for equality, order and apartness. We put the notation
    in the scope [R_scope] which can then be opened whenever needed. *)
Infix "<=" := Rle : R_scope.
Infix "<" := Rlt : R_scope.
Infix "==" := Req : R_scope.
Infix "##" := Rneq (at level 70, no associativity) : R_scope.

(** This allows us to write [(....)%R] to indicate that notation in a given expression
    should be understood as taking place in R_scope. *)

Delimit Scope R_scope with R.

Local Open Scope R_scope.

(** Equality on R is an equivalence relation. *)
Instance Equivalence_Req : Equivalence Req.
Proof.
  split.
  - intros x ; split ; intro q ; tauto.
  - intros x y [H1 H2] ; split ; intro q.
    + apply H2.
    + apply H1.
  - intros x y z [G1 G2] [H1 H2].
    split ; intro q ;
    pose (H1' := H1 q) ; pose (H2' := H2 q) ;
    pose (G1' := G1 q) ; pose (G2' := G2 q) ;
    tauto.
Qed.

(** This defines Req as the default equality on R. *)
Instance Setoid_R : Setoid R := {| equiv := Req |}.

(** We also prove that < and <= respect equality. *)

Instance Rlt_proper : Proper (Req ==> Req ==> iff) Rlt.
Proof.
  intros x y Exy z w Ezw ; split ; intros [q [H1 H2]].
  - exists q ; split.
    + rewrite <- Exy ; assumption.
    + rewrite <- Ezw ; assumption.
  - exists q ; split.
    + rewrite -> Exy ; assumption.
    + rewrite -> Ezw ; assumption.
Qed.

Instance Rle_proper : Proper (Req ==> Req ==> iff) Rle.
Proof.
  intros x y Exy z w Ezw ; split ; intros H g.
  - setoid_rewrite <- Exy ; setoid_rewrite <- Ezw ; apply H.
  - setoid_rewrite -> Exy ; setoid_rewrite -> Ezw ; apply H.
Qed.

(* A lower bound is smaller than an upper bound. *)
Lemma lower_below_upper (x : R) (q r : Q) : lower x q -> upper x r -> (q < r)%Q.
Proof.
  intros Lq Ur.
  destruct (Q_dec q r) as [[E1 | E2] | E3].
  - assumption.
  - exfalso. apply (disjoint x r).
    auto using (lower_lower x r q).
  - exfalso. apply (disjoint x r).
    split; [idtac | assumption].
    rewrite <- E3; assumption.
Qed.

(* The lower cut is closed for [Rle]. *)
Lemma lower_le (x : R) (q r : Q) : lower x r -> (q <= r)%Q -> lower x q.
Proof.
  intros H G.
  destruct (proj1 (Qle_lteq q r) G) as [E|E].
  + apply (lower_lower x q r) ; assumption.
  + rewrite E ; assumption.
Qed.

(* The upper cut is closed for [Rle]. *)
Lemma upper_le (x : R) (q r : Q) : upper x q -> (q <= r)%Q -> upper x r.
Proof.
  intros H G.
  destruct (proj1 (Qle_lteq q r) G) as [E|E].
  + apply (upper_upper x q r) ; assumption.
  + rewrite <- E ; assumption.
Qed.

(** Injection of rational numbers into reals. *)
Definition R_of_Q : Q -> R.
Proof.
  intro s.
  refine {| lower := (fun q => (q < s)%Q) ; upper := (fun r => (s < r)%Q) |}.
  - intros ? ? E. rewrite E. tauto.
  - intros ? ? E. rewrite E. tauto.
  - exists (s + (-1#1)) ; apply Qlt_minus_1.
  - exists (s + 1) ; apply Qlt_plus_1.
  - intros q r ? ? ; apply (Qlt_trans _ r); assumption.
  - intros q H.
    exists ((q + s) * (1#2)). split.
    + apply (Qmult_lt_r _ _ (2#1)); [reflexivity | idtac].
      apply (Qplus_lt_r _ _ (-q)).
      ring_simplify.
      exact H.
    + apply (Qmult_lt_r _ _ (2#1)); [reflexivity | idtac].
      apply (Qplus_lt_r _ _ (-s)).
      ring_simplify.
      exact H.
  - intros. apply (Qlt_trans _ q); assumption.
  - intros r H.
    exists ((s + r) * (1#2)). split.
    + apply (Qmult_lt_r _ _ (2#1)); [reflexivity | idtac].
      apply (Qplus_lt_r _ _ (-r)).
      ring_simplify.
      exact H.
    + apply (Qmult_lt_r _ _ (2#1)); [reflexivity | idtac].
      apply (Qplus_lt_r _ _ (-s)).
      ring_simplify.
      exact H.
  - intros q [H G].
    apply (Qlt_irrefl q).
    transitivity s; assumption.
  - intros q r H.
    destruct (Qlt_le_dec q s) as [G | G].
    + left; assumption.
    + right. apply (Qle_lt_trans _ q); assumption.
Defined.

(** The injection of Q into R respects equality. *)
Instance R_of_Q_proper : Proper (Qeq ==> Req) R_of_Q.
Proof.
  intros s t E.
  unfold Req, Rle.
  simpl; split; intro; rewrite E; tauto.
Qed.

(** We declare that [R_of_Q] can be used automatically to coerce
    rational numbers to real numbers. *)
Coercion R_of_Q : Q >-> R.

Lemma R_is_Q_iff : forall (x:R) (q:Q),
    x == q <-> (forall r:Q, (Qlt q r -> upper x r) /\ (Qlt r q -> lower x r)).
Proof.
  split.
  - split.
    + intro. apply Req_equiv in H. destruct H.
      apply (H r). simpl. exact H0.
    + intro. destruct H. apply (H1 r). simpl. exact H0.
  - split.
    + intros s H0. simpl. destruct (Qlt_le_dec s q). exact q0.
      exfalso.
      destruct (lower_open x s H0). specialize (H x0) as [H _].
      apply (disjoint x x0). split. apply H1. apply H.
      apply (Qle_lt_trans q s _ q0). apply H1.
    + intros s H0. simpl in H0. pose proof (H s) as [_ H1].
      apply H1. exact H0.
Qed.

(** Definition of common constants. *)
Definition Rzero : R := R_of_Q 0.
Definition Zone : R := R_of_Q 1.

Notation "0" := (Rzero) : R_scope.
Notation "1" := (Zone) : R_scope.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils gcd prime pos vec.

Set Implicit Arguments.
Set Default Goal Selector "!".

#[local] Notation "e #> x" := (vec_pos e x).
#[local] Notation "e [ v / x ]" := (vec_change e x v).

Record godel_coding n := {
  gc_pr : pos n -> nat;
  gc_enc : vec nat n -> nat;
  gc_pr_nz : forall p, 0 < gc_pr p;
  gc_not_div : forall p v, v#>p = 0 -> ~ divides (gc_pr p) (gc_enc v);
  gc_succ : forall p v, gc_pr p * gc_enc v = gc_enc (v[(S (v#>p))/p])
}.

Arguments godel_coding : clear implicits.

Section powers_of_2357_props.

  (* We use prime_bool_spec which is a crude Boolean primility test *)

  Local Fact prime_2 : prime 2.   Proof. apply prime_bool_spec; trivial. Qed.
  Local Fact prime_3 : prime 3.   Proof. apply prime_bool_spec; trivial. Qed.
  Local Fact prime_5 : prime 5.   Proof. apply prime_bool_spec; trivial. Qed.
  Local Fact prime_7 : prime 7.   Proof. apply prime_bool_spec; trivial. Qed.

  Hint Resolve prime_2 prime_3 prime_5 prime_7 : core.

  Ltac does_not_divide_1 := now intros H%divides_pow%prime_divides.

  Local Fact not_divides_2_3 x : ~ divides 2 (3^x).   Proof. does_not_divide_1. Qed.
  Local Fact not_divides_2_5 x : ~ divides 2 (5^x).   Proof. does_not_divide_1. Qed.
  Local Fact not_divides_2_7 x : ~ divides 2 (7^x).   Proof. does_not_divide_1. Qed.

  Local Fact not_divides_3_2 x : ~ divides 3 (2^x).   Proof. does_not_divide_1. Qed.
  Local Fact not_divides_3_5 x : ~ divides 3 (5^x).   Proof. does_not_divide_1. Qed.
  Local Fact not_divides_3_7 x : ~ divides 3 (7^x).   Proof. does_not_divide_1. Qed.

  Local Fact not_divides_5_2 x : ~ divides 5 (2^x).   Proof. does_not_divide_1. Qed.
  Local Fact not_divides_5_3 x : ~ divides 5 (3^x).   Proof. does_not_divide_1. Qed.
  Local Fact not_divides_5_7 x : ~ divides 5 (7^x).   Proof. does_not_divide_1. Qed.

  Local Fact not_divides_7_2 x : ~ divides 7 (2^x).   Proof. does_not_divide_1. Qed.
  Local Fact not_divides_7_3 x : ~ divides 7 (3^x).   Proof. does_not_divide_1. Qed.
  Local Fact not_divides_7_5 x : ~ divides 7 (5^x).   Proof. does_not_divide_1. Qed.

  Hint Resolve not_divides_2_3 not_divides_2_5 not_divides_2_7
               not_divides_3_2 not_divides_3_5 not_divides_3_7
               not_divides_5_2 not_divides_5_3 not_divides_5_7
               not_divides_7_2 not_divides_7_3 not_divides_7_5 : core.

  Local Fact not_divides_5_1 : ~ divides 5 1.
  Proof. apply not_divides_5_3 with (x := 0). Qed.

  Ltac fold_not := match goal with |- ?t -> False => change (~ t) end.
  Ltac does_not_divide_2 :=
    let H := fresh
    in intros [H|H]%prime_div_mult; auto; revert H; fold_not; auto.

  Local Fact not_divides_2_35 x y : ~ divides 2 (3^x*5^y).   Proof. does_not_divide_2. Qed.
  Local Fact not_divides_3_25 x y : ~ divides 3 (2^x*5^y).   Proof. does_not_divide_2. Qed.
  Local Fact not_divides_5_23 x y : ~ divides 5 (2^x*3^y).   Proof. does_not_divide_2. Qed.
  Local Fact not_divides_7_23 x y : ~ divides 7 (2^x*3^y).   Proof. does_not_divide_2. Qed.

  Hint Resolve not_divides_2_35 not_divides_3_5 not_divides_5_1 : core.

  Ltac does_not_divide_3 :=
    let H := fresh
    in intros H; do 2 try apply prime_div_mult in H as [H|H]; auto; revert H; fold_not; auto.

  Local Fact not_divides_2_357 x y z : ~ divides 2 (3^x*5^y*7^z). Proof. does_not_divide_3. Qed.
  Local Fact not_divides_3_257 x y z : ~ divides 3 (2^x*5^y*7^z). Proof. does_not_divide_3. Qed.
  Local Fact not_divides_5_237 x y z : ~ divides 5 (2^x*3^y*7^z). Proof. does_not_divide_3. Qed.
  Local Fact not_divides_7_235 x y z : ~ divides 7 (2^x*3^y*5^z). Proof. does_not_divide_3. Qed.

End powers_of_2357_props.

Section godel_coding_235.

  Definition combi_235 a b c := 2^a*(3^b*5^c).

  Notation "⦉ x , y , z ⦊ " := (combi_235 x y z) (at level 1, format "⦉ x , y , z ⦊ ").

  Ltac combi_235_x_0 := unfold combi_235; rewrite Nat.pow_0_r; ring.

  Local Fact combi_235_2_0 b c : ⦉0,b,c⦊ = 3^b*5^c.   Proof. combi_235_x_0. Qed.
  Local Fact combi_235_3_0 a c : ⦉a,0,c⦊ = 2^a*5^c.   Proof. combi_235_x_0. Qed.
  Local Fact combi_235_5_0 a b : ⦉a,b,0⦊ = 2^a*3^b.   Proof. combi_235_x_0. Qed.

  Ltac combi_235_multx := unfold combi_235; rewrite Nat.pow_succ_r'; ring.

  Local Fact combi_235_mult2 a b c : 2*⦉a,b,c⦊ = ⦉S a,b,c⦊ .   Proof. combi_235_multx. Qed.
  Local Fact combi_235_mult3 a b c : 3*⦉a,b,c⦊ = ⦉a,S b,c⦊ .   Proof. combi_235_multx. Qed.
  Local Fact combi_235_mult5 a b c : 5*⦉a,b,c⦊ = ⦉a,b,S c⦊ .   Proof. combi_235_multx. Qed.

  Local Definition pos3_235 : pos 3 -> nat.
  Proof.
    intro p; repeat invert pos p.
    + exact 2.
    + exact 3.
    + exact 5.
  Defined.

  Local Fact pos3_235_gt_0 x : 0 < pos3_235 x.
  Proof. repeat invert pos x; cbn; lia. Qed.

  Theorem godel_coding_235 : godel_coding 3.
  Proof.
    exists pos3_235 (fun v => ⦉v#>pos0,v#>pos1,v#>pos2⦊).
    + apply pos3_235_gt_0.
    + intros p; repeat invert pos p; intros v ->.
      * rewrite combi_235_2_0; apply not_divides_2_35.
      * rewrite combi_235_3_0; apply not_divides_3_25.
      * rewrite combi_235_5_0; apply not_divides_5_23.
    + intros p; repeat invert pos p; intros v; rew vec.
      * apply combi_235_mult2.
      * apply combi_235_mult3.
      * apply combi_235_mult5.
  Qed.

End godel_coding_235.

Section godel_coding_2357.

  Definition combi_2357 a b c d := 2^a*(3^b*(5^c*7^d)).

  Notation "⦉ x , y , z , u ⦊" := (combi_2357 x y z u) (at level 1, format "⦉ x , y , z , u ⦊").

  Ltac combi_2357_x_0 := unfold combi_2357; rewrite Nat.pow_0_r; ring.

  Local Fact combi_2357_2_0 b c d : ⦉0,b,c,d⦊ = 3^b*5^c*7^d.   Proof. combi_2357_x_0. Qed.
  Local Fact combi_2357_3_0 a c d : ⦉a,0,c,d⦊ = 2^a*5^c*7^d.   Proof. combi_2357_x_0. Qed.
  Local Fact combi_2357_5_0 a b d : ⦉a,b,0,d⦊ = 2^a*3^b*7^d.   Proof. combi_2357_x_0. Qed.
  Local Fact combi_2357_7_0 a b c : ⦉a,b,c,0⦊ = 2^a*3^b*5^c.   Proof. combi_2357_x_0. Qed.

  Ltac combi_2357_multx := unfold combi_2357; rewrite Nat.pow_succ_r'; ring.

  Local Fact combi_2357_mult2 a b c d : 2*⦉a,b,c,d⦊ = ⦉S a,b,c,d⦊.   Proof. combi_2357_multx. Qed.
  Local Fact combi_2357_mult3 a b c d : 3*⦉a,b,c,d⦊ = ⦉a,S b,c,d⦊.   Proof. combi_2357_multx. Qed.
  Local Fact combi_2357_mult5 a b c d : 5*⦉a,b,c,d⦊ = ⦉a,b,S c,d⦊.   Proof. combi_2357_multx. Qed.
  Local Fact combi_2357_mult7 a b c d : 7*⦉a,b,c,d⦊ = ⦉a,b,c,S d⦊.   Proof. combi_2357_multx. Qed.

  Local Definition pos4_2357 : pos 4 -> nat.
  Proof.
    intro p; repeat invert pos p.
    + exact 2.
    + exact 3.
    + exact 5.
    + exact 7.
  Defined.

  Local Fact pos4_2357_gt_0 x : 0 < pos4_2357 x.
  Proof. repeat invert pos x; cbn; lia. Qed.

  Theorem godel_coding_2357 : godel_coding 4.
  Proof.
    exists pos4_2357 (fun v => ⦉v#>pos0,v#>pos1,v#>pos2,v#>pos3⦊).
    + apply pos4_2357_gt_0.
    + intros p; repeat invert pos p; intros v ->.
      * rewrite combi_2357_2_0; apply not_divides_2_357.
      * rewrite combi_2357_3_0; apply not_divides_3_257.
      * rewrite combi_2357_5_0; apply not_divides_5_237.
      * rewrite combi_2357_7_0; apply not_divides_7_235.
    + intros p; repeat invert pos p; intros v; rew vec.
      * apply combi_2357_mult2.
      * apply combi_2357_mult3.
      * apply combi_2357_mult5.
      * apply combi_2357_mult7.
  Qed.

End godel_coding_2357.


(* Codes credit : Yves Bertot https://www-sop.inria.fr/members/Yves.Bertot/  *)
(* Most comments are written by me which may not be accurate nor correct!    *)
(* Mathematical components has an intuitive and consistent naming system:    *)
(* 'A' for associative, 'C' for commutative, 'D' for addition, 'r' for ring  *)
(* For more, see `ssralg.v` file in https://github.com/math-comp/math-comp   *)
(* In this file we will see how to use basic manipulations of an algebraic   *)
(* expression such as  move/collect a term, remove equal terms from the both *)
(* sides of an identity, distribute addition over multiplication, etc        *)

(* ------------------------------- setup ----------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
Require Import QArith.
From Coq Require Extraction.

Import GRing.Theory Num.Theory Num.ExtraDef.

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

Section ab1.

(* The following variables are used to make the code independent of          *)
(* mathematical components.                                                  *)

Open Scope ring_scope.

Variable (R : rcfType).

Definition R' := (R : Type).

Definition mul : R' -> R' -> R' := @GRing.mul _.
Definition add : R' -> R' -> R' := @GRing.add _.
Definition sub : R' -> R' -> R' := (fun x y => x - y).
Definition opp : R' -> R' := @GRing.opp _.
Definition zero : R' := 0.
Definition one : R' := 1.

Definition R2_theory :=
  @mk_rt R' zero one add mul sub opp
   (@eq R')
   (@add0r R) (@addrC R) (@addrA R) (@mul1r R) (@mulrC R)
     (@mulrA R) (@mulrDl R) (fun x y : R => erefl (x - y)) (@addrN R).

Add Ring R2_Ring : R2_theory.

(* This tactic automates proving identities in a ring                        *)
Ltac mc_ring :=
rewrite ?mxE /= ?(expr0, exprS, mulrS, mulr0n) -?[@GRing.add _]/add -?[@GRing.mul _]/mul
   -?[@GRing.opp _]/opp -?[1]/one -?[0]/zero;
match goal with |- @eq ?X _ _ => change X with R' end; try ring.

(* ------------------------------------------------------------------------- *)
(*                                   DEMOS                                   *)

Theorem toto (x : R) :
  sqrtr ((x - 1) ^+ 3) =
  sqrtr (x ^+ 3 - 3%:R * x ^+ 2 + x  + x + x - 1%:R).
Proof.
(* this works too :                                                          *)
(* congr (sqrtr _).
by mc_ring. *)

(* rewrite [expr](_ : _ = expr2) means replace expr with expr2, this         *)
(* replacement needs to be proved                                            *)
rewrite [(x - 1) ^+ 3](_ : _ =
              (x ^+ 3 - 3%:R * x ^+ 2 + x  + x + x - 1%:R)); last by mc_ring.
by [].
Qed.

Theorem toto2 (x : R) :
   (x - 1) ^+ 3 = x ^+ 3 - 3%:R * x ^+ 2 + x  + x + x - 1%:R.
Proof.
(* ! means do it as many as possible, (tac1, tac2, ..., tacn) means apply    *)
(* any of these tactics when it is possible                                  *)
rewrite !(exprS, expr0, mulr1, mulrBl, mulrBr, mul1r, addrA, opprB).
rewrite [1%:R](_ : _ = 1); last by []. (* 1%R and 1 live in different places *)
(* push the 1 to the right. *)
rewrite !(addrAC _ (- 1)).
(* get rid of both ones. *)
 congr (_ + _).
(* push the parentheses in additions to the right. *)
rewrite -!addrA.
(* the first and second terms, that are equal. *)
rewrite !(mulrS, addr0, mulrDl) .
rewrite mulr0n.
rewrite mul0r.
rewrite addr0.
rewrite !mul1r.
rewrite !opprD.
rewrite -!addrA.
congr (_ + (_ + _)).
rewrite (addrC x).
rewrite !addrA.
rewrite !(addrAC _ x).
by [].
Qed.

Theorem toto3 (x : R) :
   (x - 1) ^+ 3 = x ^+ 3 - 3%:R * x ^+ 2 + x  + x + x - 1%:R.
Proof.
by rewrite !(exprS, expr0, mulr1, mulrBl, mulrBr, mul1r, addrA, opprB,
    mulrS, addr0, mulrDl, opprD, mulr0n, subr0,
    (fun y => addrAC y (-1)), (fun y z => addrAC y z (- (x * x)))).
Qed.


(* Software Foundations *)
(* Exercice 3 stars, app_length_cons *)

Require Import Coq.Lists.List.
Import ListNotations.

Theorem app_length_cons : forall (X : Type) (l1 l2 : list X) (x : X) (n : nat),
      length (l1 ++(x :: l2))=n -> S (length (l1 ++ l2)) = n.
Proof.
    intros X l1. induction l1 as [|h1 t1].
    intros. generalize dependent n.
    simpl. intros. apply H.
    simpl. induction n as [|n'].
    intros contra. inversion contra.
    intros H. inversion H. apply IHt1 in H1. rewrite H1. rewrite H. reflexivity.
Qed.


Require Export Utf8.
Require Export Arith.
Require Export Lia.
Require Export Recdef.

Fixpoint Sum (n0 : nat) :=
  match n0 with
  | 0   => 0
  | S n => S (n + Sum n)
  end.

Lemma le_sum : forall n, n <= Sum n.
Proof.
  induction n.
  simpl. lia.
  simpl.
  lia.
Qed.

Definition cpair (n m : nat) : nat := n + Sum (n + m).
Notation "( x ; y )" := (cpair x y) (at level 0).

Lemma le_cpair_fst n m : n <= cpair n m.
Proof.
  unfold cpair.
  lia.
Qed.

Lemma le_cpair_snd n m : m <= cpair n m.
Proof.
  unfold cpair.
  assert(H := le_sum (n + m)).
  lia.
Qed.

(* Sum (summax n) <= n < n + Sum (summax n) *)

Fixpoint summax (n0 : nat) :=
  match n0 with
  | 0 => 0
  | S n =>
    let m := summax n in
    match (le_lt_dec (Sum (S m)) (S n)) with
    | left _  => S m
    | right _ => m
    end
  end.

Definition fst (n : nat) := n - Sum (summax n).
Definition snd (n : nat) := summax n - fst n.

Compute fst 5.
Compute snd 5.

Lemma lt_I_lt_sum_sum : forall n m,
  n < m -> Sum n < Sum m.
Proof.
  assert(forall n m, Sum m < Sum (S n + m)).
  {
    induction n.
    simpl. lia.
    simpl.
    intros.
    specialize (IHn m).
    simpl in IHn.
    lia.
  }
  intros.
  pose (l := m - S n).
  assert (m = S l + n). lia.
  rewrite H1.
  auto.
Qed.

Lemma lt_sum_sum_I_lt : forall n m,
  Sum n < Sum m -> n < m.
Proof.
  assert(forall n m, Sum m <= Sum (n + m)).
  {
    induction n.
    simpl. lia.
    simpl.
    intros.
    specialize (IHn m).
    lia.
  }
  intros.
  destruct(le_lt_dec m n).
  - assert(Sum m <= Sum n).
    pose (s := n - m).
    assert (n = s + m). lia.
    rewrite H1. auto.
    lia.
  - lia.
Qed.

Lemma le_sum_sum_I_le : forall n m,
  Sum n <= Sum m -> n <= m.
Proof.
  intros.
  destruct (le_lt_eq_dec (Sum n) (Sum m) H).
  apply lt_sum_sum_I_lt in l.
  lia.
  destruct(le_lt_dec n m).
  lia.
  apply lt_I_lt_sum_sum in l.
  lia.
Qed.

Lemma le_sum_summax_A_lt_sum_s_summax : forall n,
  Sum (summax n) <= n < Sum (S (summax n)).
Proof.
  induction n.
  - simpl. lia.
  - destruct IHn.
    Opaque Sum.
    simpl.
    Transparent Sum.
    destruct (le_lt_dec (Sum (S (summax n))) (S n)).
    split. lia.
    simpl. simpl in H0. simpl in l.
    lia.
    split.
    lia.
    lia.
Qed.

Lemma summax_cpair_E_plus : forall n m,
  summax (cpair n m) = n + m.
Proof.
  unfold cpair.
  intros.
  assert (H := le_sum_summax_A_lt_sum_s_summax (n + Sum (n + m))).
  destruct H.
  assert (n + Sum (n + m) < Sum (S (n + m))).
  simpl. lia.
  assert (summax (n + Sum (n + m)) < S (n + m)).
  apply lt_sum_sum_I_lt. lia.
  assert (n + m < S (summax (n + Sum (n + m)))).
  apply lt_sum_sum_I_lt. lia.
  lia.
Qed.

Theorem pairing_fst : forall n m, fst (n; m) = n.
Proof.
  unfold fst.
  intros.
  rewrite summax_cpair_E_plus.
  unfold cpair.
  lia.
Qed.

Theorem pairing_snd : forall n m, snd (n; m) = m.
Proof.
  intros.
  unfold snd.
  rewrite pairing_fst.
  rewrite summax_cpair_E_plus.
  lia.
Qed.

Theorem pairing_inj_fst : forall x y u v,
  cpair x y = cpair u v -> x = u.
Proof.
  intros.
  assert(H0 := pairing_fst x y).
  rewrite <- H0.
  rewrite H.
  apply pairing_fst.
Qed.

Theorem pairing_inj_snd : forall x y u v,
  cpair x y = cpair u v -> y = v.
Proof.
  intros.
  assert(H0 := pairing_snd x y).
  rewrite <- H0.
  rewrite H.
  apply pairing_snd.
Qed.

Theorem n_E_cpair_fst_snd : forall n,
  n = (fst n; snd n).
Proof.
  intros.
  unfold cpair, snd, fst.
  assert (H := le_sum_summax_A_lt_sum_s_summax n).
  destruct H.
  simpl in H0.
  assert (n - Sum (summax n) + (summax n - (n - Sum (summax n))) = summax n). lia.
  rewrite H1.
  lia.
Qed.

Lemma fst_descending : forall n,
  fst n < S n.
Proof.
  unfold fst.
  intros.
  lia.
Qed.

Lemma snd_descending : forall n,
  snd n < S n.
Proof.
  intros.
  rewrite (n_E_cpair_fst_snd n) at 2.
  assert (H := le_cpair_snd (fst n) (snd n)).
  lia.
Qed.

Definition cnil := 0.
Definition ccons (n m : nat) := S (n; m).

Notation "`( x ; y ; .. ; z )" := (ccons x (ccons y .. (ccons z cnil) ..)).

Compute `(0;1;0;0).

Fixpoint nth (n0 m0 : nat) : nat :=
  match n0, m0 with
  | 0, S m   => S (fst m)
  | S n, S m => nth n (snd m)
  | _, 0     => 0
  end.

Function lh (n0 : nat) {wf lt n0}: nat :=
  match n0 with
  | 0 => 1
  | S n => S (lh (snd n))
  end.
Proof.
  intros.
  apply snd_descending.
  exact lt_wf.
Qed.


Require Import List.

Inductive binop : Set :=
| Plus  : binop
| Times : binop
.

Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp-> exp -> exp
.

Definition binopDenote (b:binop) : nat -> nat -> nat :=
    match b with
    | Plus  => plus
    | Times => mult
    end.

(* type inference at play *)
Definition binopDenote' := fun b =>
    match b with
    | Plus  => plus
    | Times => mult
    end.

Fixpoint expDenote (e:exp) : nat :=
    match e with
    | Const n       => n
    | Binop b e1 e2 => binopDenote b (expDenote e1) (expDenote e2)
    end.

Inductive instr : Set :=
| iConst : nat   -> instr
| iBinop : binop -> instr
.

Definition prog  : Set := list instr.
Definition stack : Set := list nat.

Definition instrDenote (i:instr) (s:stack) : option stack :=
    match i with
    | iConst n  => Some (n :: s)
    | iBinop b  =>
        match s with
        | x1 :: x2 :: s'    => Some ((binopDenote b) x1 x2 :: s')
        | _                 => None
        end
    end.

Fixpoint progDenote (p:prog) (s:stack) : option stack :=
    match p with
    | nil       => Some s
    | i :: q    =>
        match instrDenote i s with
        | None      => None
        | Some s'   => progDenote q s'
        end
    end.

Fixpoint compile (e:exp) : prog :=
    match e with
    | Const n       => iConst n :: nil
    | Binop b e1 e2 => compile e2 ++ compile e1 ++ iBinop b :: nil
    end.

Definition eval (e:exp) : option nat :=
    match progDenote (compile e) nil with
    | Some (n::nil) => Some n
    | _             => None
    end.

Lemma compile_correct' : forall (e:exp) (p:prog) (s:stack),
    progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
Proof.
    intros e. induction e as [n|b e1 H1 e2 H2]; intros p s; simpl.
    - reflexivity.
    - rewrite app_assoc_reverse. rewrite H2.
      rewrite app_assoc_reverse. rewrite H1.
      reflexivity.
Qed.

Theorem compile_correct : forall (e:exp), eval e = Some (expDenote e).
Proof.
    intros e. unfold eval. rewrite <- (app_nil_r (compile e)).
    rewrite compile_correct'. reflexivity.
Qed.


Require Import Coq.Program.Tactics.
Require Import Coq.Program.Wf.
Require Import Lia.
Require Export Nat.

(* Variables *)
Definition var := nat.

(* Predicate expressions *)
Inductive expr : Type :=
| PNat (n : nat)
| PVar (x : var)
| PAdd (e1 e2 : expr).

(* Change of variables in exprs *)
Fixpoint change_var_expr (e : expr) (from to : var) : expr :=
  match e with
  | PNat _ => e
  | PVar x =>
      if x =? from then PVar to else e
  | PAdd e1 e2 =>
      PAdd (change_var_expr e1 from to) (change_var_expr e2 from to)
  end.

(* Substitute a nat for a var in an expr *)
Fixpoint subst_expr (e : expr) (from : var) (to : nat) : expr :=
  match e with
  | PNat _ => e
  | PVar x =>
      if x =? from then PNat to else e
  | PAdd e1 e2 =>
      PAdd (subst_expr e1 from to) (subst_expr e2 from to)
  end.

(* Simplify an expr *)
Fixpoint simpl_expr (e : expr) : expr :=
  match e with
  | PAdd e1 e2 =>
      let e1' := simpl_expr e1 in
      let e2' := simpl_expr e2 in
      match e1', e2' with
      | PNat n, PNat m => PNat (n + m)
      | _, _ => PAdd e1' e2'
      end
  | _ => e
  end.

(* Predicates *)
Inductive pred : Type :=
| PBool (b : bool)
| PEq (e1 e2 : expr)
| PAnd (p1 p2 : pred)
| POr (p1 p2 : pred).

(* Change of variables in preds *)
Fixpoint change_var_pred (p : pred) (from to : var) : pred :=
  match p with
  | PBool _ => p
  | PEq e1 e2 =>
      PEq (change_var_expr e1 from to) (change_var_expr e2 from to)
  | PAnd p1 p2 =>
      PAnd (change_var_pred p1 from to) (change_var_pred p2 from to)
  | POr p1 p2 =>
      POr (change_var_pred p1 from to) (change_var_pred p2 from to)
  end.

(* Substitute a nat for a var in a pred *)
Fixpoint subst_pred (p : pred) (from : var) (to : nat) : pred :=
  match p with
  | PBool _ => p
  | PEq e1 e2 =>
      PEq (subst_expr e1 from to) (subst_expr e2 from to)
  | PAnd p1 p2 =>
      PAnd (subst_pred p1 from to) (subst_pred p2 from to)
  | POr p1 p2 =>
      POr (subst_pred p1 from to) (subst_pred p2 from to)
  end.

(* Simplify a pred *)
Fixpoint simpl_pred (p : pred) : pred :=
  match p with
  | PBool _ => p
  | PEq e1 e2 =>
      PEq (simpl_expr e1) (simpl_expr e2)
  | PAnd p1 p2 =>
      PAnd (simpl_pred p1) (simpl_pred p2)
  | POr p1 p2 =>
      POr (simpl_pred p1) (simpl_pred p2)
  end.

(* Convert a pred into its equivalent Prop *)
Fixpoint pred_prop (p : pred) : Prop :=
  match p with
  | PBool true => True
  | PBool false => False
  | PEq e1 e2 => e1 = e2
  | PAnd p1 p2 => (pred_prop p1) /\ (pred_prop p2)
  | POr p1 p2 => (pred_prop p1) \/ (pred_prop p2)
  end.

(* Substitution satisfies a simplified predicate *)
Definition sat_pred p x n := pred_prop (simpl_pred (subst_pred p x n)).

(* Constraints *)
Inductive cnst : Type :=
| CPred (p : pred)
| CAnd (c1 c2 : cnst)
| CImpl (x : var) (p : pred) (c : cnst).

(* Substitute a nat for a var in a cnst *)
Fixpoint subst_cnst (c : cnst) (from : var) (to : nat) : cnst :=
  match c with
  | CPred p =>
      CPred (subst_pred p from to)
  | CAnd c1 c2 =>
      CAnd (subst_cnst c1 from to) (subst_cnst c2 from to)
  | CImpl x p c' =>
      if x =? from then
        c
      else
        CImpl x (subst_pred p from to) (subst_cnst c' from to)
  end.

(* Height of a cnst, needed to prove termination below *)
Fixpoint cnst_height (c : cnst) : nat :=
  match c with
  | CPred _ => 1
  | CAnd c1 c2 =>
      1 + max (cnst_height c1) (cnst_height c2)
  | CImpl x p c' => 1 + cnst_height c'
  end.

(* Convert a cnst into its equivalent Prop *)
Program Fixpoint cnst_prop (c : cnst) {measure (cnst_height c)} : Prop :=
  match c with
  | CPred p => pred_prop (simpl_pred p)
  | CAnd c1 c2 =>
      (cnst_prop c1) /\ (cnst_prop c2)
  | CImpl x p c' =>
      forall n, sat_pred p x n -> cnst_prop (subst_cnst c' x n)
  end.
Next Obligation.
  destruct c1; simpl; destruct c2; simpl; lia.
Qed.
Next Obligation.
  destruct c2; simpl; destruct c1; simpl; lia.
Qed.
Next Obligation.
  assert (H: forall c y m, cnst_height (subst_cnst c y m) = cnst_height c).
  {
    intros. induction c; simpl.
    - reflexivity.
    - rewrite IHc1, IHc2. reflexivity.
    - destruct (x0 =? y); simpl.
      + reflexivity.
      + rewrite IHc. reflexivity.
  }
  simpl. rewrite H. lia.
Qed.

(* Useful results *)

Lemma same_var_change_expr : forall e x, change_var_expr e x x = e.
Proof.
  intros. induction e.
  - reflexivity.
  - simpl. destruct (x0 =? x) eqn:E0.
    + apply PeanoNat.Nat.eqb_eq in E0.
      rewrite E0. reflexivity.
    + reflexivity.
  - simpl. rewrite IHe1, IHe2. reflexivity.
Qed.

Lemma same_var_change_pred : forall p x, change_var_pred p x x = p.
Proof.
  intros. induction p.
  - reflexivity.
  - simpl. repeat rewrite same_var_change_expr. reflexivity.
  - simpl. rewrite IHp1, IHp2. reflexivity.
  - simpl. rewrite IHp1, IHp2. reflexivity.
Qed.


Require Import Omega.

(* Submitted by Xavier Urbain 18 Jan 2002 *)

Lemma lem1 :
 forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z.
Proof.
intros x y.
 omega.
Qed.

(* Proposed by Pierre Crégut *)

Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z.
intro.
 omega.
Qed.

(* Proposed by Jean-Christophe Filliâtre *)

Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z.
Proof.
intros.
 omega.
Qed.

(* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *)
(* internal variable and a section variable (June 2001) *)

Section A.
Variable x y : Z.
Hypothesis H : (x > y)%Z.
Lemma lem4 : (x > y)%Z.
 omega.
Qed.
End A.

(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *)
(* May 2002 *)

Section B.
Variable R1 R2 S1 S2 H S : Z.
Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z.
Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z.
Hypothesis K : (R1 >= 0)%Z -> R2 = R1.
Hypothesis L : (R1 >= 0)%Z -> S2 = S1.
Hypothesis M : (H <= 2 * S)%Z.
Hypothesis N : (S < H)%Z.
Lemma lem5 : (H > 0)%Z.
 omega.
Qed.
End B.

(* From Nicolas Oury (BZ#180): handling -> on Set (fixed Oct 2002) *)
Lemma lem6 :
 forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z.
intros.
 omega.
Qed.

(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *)
Require Import Omega.
Section C.
Parameter g : forall m : nat, m <> 0 -> Prop.
Parameter f : forall (m : nat) (H : m <> 0), g m H.
Variable n : nat.
Variable ap_n : n <> 0.
Let delta := f n ap_n.
Lemma lem7 : n = n.
 omega.
Qed.
End C.

(* Problem of dependencies *)
Require Import Omega.
Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0.
intros;  omega.
Qed.

(* Bug that what caused by the use of intro_using in Omega *)
Require Import Omega.
Lemma lem9 :
 forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p.
intros;  omega.
Qed.

(* Check that the interpretation of mult on nat enforces its positivity *)
(* Submitted by Hubert Thierry (BZ#743) *)
(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *)
Lemma lem10 : forall n m:nat, le n (plus n (mult n m)).
Proof.
intros; omega with *.
Qed.