Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From LF Require Export IndProp.

(* a playground module that helps me to recall the refined reflection *)
Module Silly.
  Inductive reflect (P : Prop) : bool -> Set :=
  | ReflectT : P -> reflect P true
  | ReflectF : ~ P -> reflect P false.

  Theorem eqb_natP : forall a b : nat, reflect (a = b) (a =? b).
  Proof.
    intros a b. destruct (a =? b) eqn:E.
    - apply ReflectT. apply eqb_true. apply E.
    - apply ReflectF. intro contra. rewrite contra in E.
      rewrite eqb_refl in E. discriminate E. Qed.

  Theorem silly_refl : forall n : nat, n =? n = true.
  Proof.
    intros n. Show Proof. destruct (eqb_natP n n). Show Proof.
    - reflexivity. Show Proof.
    - exfalso. Show Proof.
      apply n0. Show Proof. reflexivity. Show Proof. Qed.
End Silly.

Theorem ev_4'' : ev 4.
Proof.
  Show Proof. apply ev_SS.
  Show Proof. apply ev_SS.
  Show Proof. apply ev_0.
  Show Proof. Qed.

Theorem ev_8 : ev 8.
Proof.
  apply ev_SS. apply ev_SS. apply ev_SS. apply ev_SS. apply ev_0.
Qed.

Definition ev_8' : ev 8 := (ev_SS 6 (ev_SS 4 (ev_SS 2 (ev_SS 0 ev_0)))).

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n H. apply ev_SS. apply ev_SS.
  apply H. Show Proof. Qed.

Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) (H : ev n) => (ev_SS (S (S n)) (ev_SS n H)).

Definition add1 : nat -> nat.
  intro n. Show Proof.
  apply S. Show Proof.
  apply n. Show Proof.
Defined.

Print add1.

Module Props.
  Module And.
    Inductive and (P Q : Prop) : Prop :=
    | conj : P -> Q -> and P Q.

    Arguments conj [P] [Q].
    Notation "P /\ Q" := (and P Q) : type_scope.

    Theorem proj1' : forall P Q, P /\ Q -> P.
    Proof.
      intros P Q H. destruct H as [HP HQ]. apply HP.
      Show Proof. Qed.

    Lemma and_comm : forall P Q, P /\ Q <-> Q /\ P.
    Proof.
      intros P Q. Show Proof. split. Show Proof.
      - intro H. Show Proof. destruct H as [HP HQ]. Show Proof.
        split. Show Proof.
        + apply HQ. Show Proof.
        + apply HP. Show Proof.
      - intros [HQ HP]. split.
        + apply HP.
        + apply HQ. Show Proof. Qed.
  End And.

  Definition and_comm'_aux (P Q : Prop) (H : P /\ Q) : Q /\ P :=
    match H with
    | conj HP HQ => conj HQ HP
    end.

  Check and_comm'_aux.

  Definition and_comm' : forall (P Q : Prop), P /\ Q <-> Q /\ P.
    split.
    - intro H. apply (and_comm'_aux P Q). apply H.
    - intro H. apply (and_comm'_aux Q P). apply H. Defined.

  Definition and_comm'' : forall (P Q : Prop), P /\ Q <-> Q /\ P :=
    fun (P Q : Prop) => conj (fun H : P /\ Q => and_comm'_aux P Q H)
                        (fun H : Q /\ P => and_comm'_aux Q P H).

  (* Currying is brilliant! *)
  Definition and_comm''' (P Q : Prop) : P /\ Q <-> Q /\ P :=
    conj (and_comm'_aux P Q) (and_comm'_aux Q P).

  Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
    fun P Q R => (fun HPQ : P /\ Q =>
                 match HPQ with
                 | conj HP _ =>
                   (fun HQR : Q /\ R =>
                      match HQR with
                      | conj _ HR => conj HP HR
                      end)
                 end).

  Module Or.
    Inductive or (P Q : Prop) : Prop :=
    | or_introl : P -> or P Q
    | or_intror : Q -> or P Q.

    Arguments or_introl [P] [Q].
    Arguments or_intror [P] [Q].
    Notation "P \/ Q" := (or P Q) : type_scope.

    Definition inj_l : forall P Q : Prop, P -> P \/ Q :=
      fun P Q : Prop => fun HP : P => or_introl HP.

    Theorem inj_j' : forall P Q : Prop, P -> P \/ Q.
    Proof.
      intros P Q HP. Show Proof. left. (* selects the `or_introl` constructor *)
      Show Proof. apply HP. Qed.

    Definition or_elim : forall (P Q R : Prop), P \/ Q -> (P -> R) -> (Q -> R) -> R :=
      fun P Q R (H : P \/ Q) (HPR : P -> R) (HQR : Q -> R) =>
        match H with
        | or_introl HP => HPR HP
        | or_intror HQ => HQR HQ
        end.
  End Or.

  Definition or_commut' : forall P Q, P \/ Q -> Q \/ P :=
    fun P Q (H : P \/ Q) =>
      match H with
      | or_introl HP => (@or_intror Q P) HP
      | or_intror HQ => (@or_introl Q P) HQ
      end.

  Module Ex.
    (* ex: "Show me a witness of the Prop, and I'll know there
            exists something that witnesses the Prop..." *)
    Inductive ex {A : Type} (P : A -> Prop) : Prop :=
    | ex_intro (x : A) : P x -> ex P.

    Notation "'exists' x , p" :=
      (ex (fun x => p)) (at level 200, right associativity) : type_scope.
  End Ex.

  Check @ex.
  Check @ex_intro.

  Check ex (fun n => ev n) : Prop.
  Definition some_nat_is_even : exists n, ev n :=
    ex_intro ev 0 ev_0.

  Definition ex_ev_Sn : ex (fun n => ev (S n)) :=
    ex_intro (fun n => ev (S n)) 1 (ev_SS 0 ev_0).

  Inductive True : Prop :=
  | I : True.

  Definition p_implies_true : forall P : Prop, P -> True :=
    fun P (_ : P) => I.

  Inductive False : Prop :=.

  Definition ex_falso_quodlibet' : forall P, False -> P :=
    fun P (contra : False) =>
      match contra with end.
End Props.

Module MyEquality.
  Inductive eq {X : Type} : X -> X -> Prop :=
  | eq_refl : forall (x : X), eq x x.

  Notation "x == y" := (eq x y) (at level 70, no associativity).

  Definition singleton : forall (X : Type) (x : X), [] ++ [x] == x :: [] :=
    fun X x => eq_refl [x].

  Lemma equality__leibniz_equality : forall (X : Type) (x y : X),
      x == y -> forall (P : X -> Prop), P x -> P y.
  Proof.
    intros X x y [x_y] P HPx. apply HPx. Qed.

  Lemma leibniz_equality__equality : forall (X : Type) (x y : X),
      (forall P : X -> Prop, P x -> P y) -> x == y.
  Proof.
    intros X x y Leib. apply (Leib (eq x)).
    apply (eq_refl x). Qed.

  Theorem try_leibniz_refl : forall (X : Type) (x y : X),
      (forall P : X -> Prop, P x -> P y) -> (forall P : X -> Prop, P y -> P x).
  Proof.
    intros X x y Hxy P.
    apply (Hxy (fun t : X => P t -> P x)).
    intro H. apply H.
  Qed.
End MyEquality.


(*This file contains two theorems: forward and backward error bounds for
  the sum of two floating point lists; the functional model for
  the summation is defined in sum_model.v.*)

Require Import vcfloat.VCFloat.
Require Import List.
Import ListNotations.
Require Import common sum_model float_acc_lems op_defs list_lemmas.

Require Import Reals.
Open Scope R.

Section NAN.
Variable NAN: Nans.

Lemma sum_forward_error :
  forall (t: type) (l: list (ftype t))
  (Hlen: (1 <= length l)%nat)
  (fs : ftype t) (rs rs_abs : R)
  (Hfs: sum_rel_Ft t l fs)
  (Hrs: sum_rel_R (map FT2R l) rs)
  (Hra: sum_rel_R (map Rabs (map FT2R l)) rs_abs)
  (Hin: forall a, In a l ->  Binary.is_finite _ _ a = true)
  (Hfin: Binary.is_finite (fprec t) (femax t) fs = true),
  Rabs (rs - FT2R fs) <= g t (length l -1) * rs_abs.
Proof.
induction l.
{ simpl; intros; pose proof (Nat.nle_succ_0 0); try contradiction. }
(* case a::l *)
intros.
assert (Hl: l = [] \/ l <> []).
destruct l; auto.
right.
eapply hd_error_some_nil; simpl; auto.
destruct Hl.
(* case empty l *)
{ assert (HFINa:
  Binary.is_finite (fprec t) (femax t) a = true) by (apply Hin; simpl; auto).
  assert (HFINfs:
  Binary.is_finite (fprec t) (femax t) fs = true).
  { subst. inversion Hfs. fold (@sum_rel_Ft NAN t) in H2. inversion H2. subst.
  destruct a; simpl; try discriminate; auto. }
  subst; simpl; pose proof (sum_rel_Ft_single t fs a HFINfs Hfs); subst.
  rewrite (sum_rel_R_single (FT2R a) rs Hrs); subst.
  unfold g; simpl; field_simplify_Rabs;
  rewrite Rabs_R0; nra. }
(* case non-empty l *)
inversion Hfs; fold (@sum_rel_Ft NAN t) in H3.
inversion Hrs; fold sum_rel_R in H7.
inversion Hra; fold sum_rel_R in H11.
subst; unfold sum in *.
assert (HFINa:
  Binary.is_finite (fprec t) (femax t) a = true) by (apply Hin; simpl; auto).
(* IHl *)
pose proof (length_not_empty_nat l H) as Hlen1.
assert (Hinl: forall a : ftype t,
       In a l -> Binary.is_finite (fprec t) (femax t) a = true).
{ intros; apply Hin; simpl; auto. }
assert (Hfins: Binary.is_finite (fprec t) (femax t) s = true).
{ destruct a, s; simpl in *; try discriminate; auto. }
specialize (IHl Hlen1 s s0 s1 H3 H7 H11 Hinl Hfins).
(* accuracy rewrites *)
assert (Hov: Bplus_no_overflow t (FT2R a) (FT2R s)).
{ unfold Bplus_no_overflow. pose proof is_finite_sum_no_overflow t.
  simpl in H0; unfold rounded in H0; eapply H0; auto. }
pose proof (BPLUS_accurate t a HFINa s Hfins Hov) as Hplus.
destruct Hplus as (d' & Hd'& Hplus); rewrite Hplus;
  clear Hplus Hov.
(* algebra *)
field_simplify_Rabs.
replace (- FT2R a * d' + s0 - FT2R s * d' - FT2R s) with
  ((s0 - FT2R s) - d' * (FT2R s + FT2R a)) by nra.
eapply Rle_trans;
  [ apply Rabs_triang | eapply Rle_trans; [ apply Rplus_le_compat_r
    | rewrite !Rabs_Ropp] ].
apply IHl.
eapply Rle_trans;
  [apply Rplus_le_compat_l | ].
  rewrite Rabs_mult. apply Rmult_le_compat; try apply Rabs_pos.
  apply Hd'.
  eapply Rle_trans; [apply Rabs_triang | apply Rplus_le_compat_r].
  rewrite Rabs_minus_sym in IHl; apply Rabs_le_minus in IHl. apply IHl.
rewrite !Rmult_plus_distr_l; rewrite <- !Rplus_assoc.
replace (g t (length l - 1) * s1 + default_rel t * (g t (length l - 1) * s1)) with
  ((1+ default_rel t) * g t (length l - 1) * s1) by nra.
eapply Rle_trans; [apply Rplus_le_compat_r;
  apply Rplus_le_compat_l; apply Rmult_le_compat_l; try apply Rabs_pos|].
apply default_rel_ge_0.
apply (sum_rel_R_Rabs (map FT2R l)); auto; apply H11.
rewrite (sum_rel_R_Rabs_eq (map FT2R l)); auto.
rewrite one_plus_d_mul_g. simpl.
rewrite Rplus_comm.
apply Rplus_le_compat.
apply Rmult_le_compat; try apply Rabs_pos;
  try apply default_rel_ge_0; try nra.
apply d_le_g_1; try lia.
apply Req_le; f_equal. f_equal; lia.
Qed.

Lemma sum_backward_error :
  forall (t: type) (l: list (ftype t))
  (Hlen: (1 <= length l)%nat)
  (fs : ftype t) (rs : R)
  (Hfs: sum_rel_Ft t l fs)
  (Hrs: sum_rel_R (map FT2R l) rs)
  (Hin: forall a, In a l ->  Binary.is_finite _ _ a = true)
  (Hfin: Binary.is_finite (fprec t) (femax t) fs = true),
    exists (l': list R),
    length l' = length l /\
    sum_rel_R l' (FT2R fs) /\
    (forall n, (n <= length l')%nat -> exists delta,
        nth n l' 0 = FT2R (nth n l neg_zero) * (1 + delta) /\ Rabs delta <= g t (length l' - 1)).
Proof.
intros ? ?. induction l.
{ simpl; intros; pose proof (Nat.nle_succ_0 0); try contradiction. }
(* case a::l *)
intros.
assert (Hl: l = [] \/ l <> []).
destruct l; auto.
right.
eapply hd_error_some_nil; simpl; auto.
destruct Hl.
(* case empty l *)
{ assert (HFINa:
  Binary.is_finite (fprec t) (femax t) a = true) by (apply Hin; simpl; auto).
  assert (HFINfs:
  Binary.is_finite (fprec t) (femax t) fs = true).
  { subst. inversion Hfs. fold (@sum_rel_Ft NAN t) in H2. inversion H2. subst.
  destruct a; simpl; try discriminate; auto. }
  inversion Hfs. inversion Hrs; subst. inversion H3. subst. inversion H7; subst.
  unfold sum in Hrs; simpl in Hrs; rewrite Rplus_0_r in Hrs.
  exists [FT2R a]; repeat split.
  simpl; auto. unfold sum. rewrite BPLUS_neg_zero; auto.
  intros. exists 0; split; auto. rewrite Rplus_0_r. rewrite Rmult_1_r.
  replace [FT2R a] with (map FT2R [a]) by (simpl; auto).
  replace 0 with (@FT2R t neg_zero) by (unfold neg_zero; simpl; auto).
  rewrite map_nth; auto.
  unfold g. simpl. rewrite Rabs_R0; nra.
}
(* case non-empty l *)
inversion Hfs; fold (@sum_rel_Ft NAN t) in H3.
inversion Hrs; fold sum_rel_R in H7.
subst; unfold sum in *.
assert (HFINa:
  Binary.is_finite (fprec t) (femax t) a = true) by (apply Hin; simpl; auto).
(* IHl *)
pose proof (length_not_empty_nat l H) as Hlen1.
assert (Hinl: forall a : ftype t,
       In a l -> Binary.is_finite (fprec t) (femax t) a = true).
{ intros; apply Hin; simpl; auto. }
assert (Hfins: Binary.is_finite (fprec t) (femax t) s = true).
{ destruct a, s; simpl in *; try discriminate; auto. }
specialize (IHl Hlen1 s s0 H3 H7 Hinl Hfins).
destruct IHl as (l' & Hlen' & Hsum & Hdel).
(* construct l'0 *)
assert (Hov: Bplus_no_overflow t (FT2R a) (FT2R s)).
{ unfold Bplus_no_overflow. pose proof is_finite_sum_no_overflow t.
  simpl in H0; unfold rounded in H0; eapply H0; auto. }
pose proof (BPLUS_accurate t a HFINa s Hfins Hov) as Hplus.
destruct Hplus as (d' & Hd'& Hplus).
exists (FT2R a * (1+d') :: map (Rmult (1+d')) l'); repeat split.
{ simpl; auto. rewrite map_length; auto. }
{ rewrite Hplus. unfold sum_rel_R.
  rewrite Rmult_plus_distr_r. apply sum_rel_cons. rewrite Rmult_comm; apply sum_map_Rmult; auto. }
intros. destruct n.
{ simpl. exists d'; split; auto.
  eapply Rle_trans; [apply Hd'| ]. apply d_le_g_1. rewrite map_length; auto.
  rewrite Hlen'. lia. }
simpl in H0; rewrite map_length in H0; rewrite Hlen' in H0.
assert (Hlen2: (n <= length l')%nat) by lia.
specialize (Hdel n Hlen2).
destruct Hdel as (d & Hd1 & Hd2).
exists ( (1+d') * (1+d) -1). simpl; split.
{ replace 0 with (Rmult (1 + d') 0) by nra. rewrite map_nth; rewrite Hd1; nra. }
rewrite map_length. field_simplify_Rabs.
  eapply Rle_trans; [apply Rabs_triang | eapply Rle_trans; [apply Rplus_le_compat_r; apply Rabs_triang | ]  ].
rewrite Rabs_mult.
replace (Rabs d' * Rabs d + Rabs d' + Rabs d ) with
  ((1 + Rabs d') * Rabs d + Rabs d' ) by nra.
eapply Rle_trans; [apply Rplus_le_compat | ].
apply Rmult_le_compat; try apply Rabs_pos.
apply Fourier_util.Rle_zero_pos_plus1; try apply Rabs_pos.
apply Rplus_le_compat_l; apply Hd'.
apply Hd2. apply Hd'.
replace ((1 + default_rel t) * g t (length l' - 1) + default_rel t) with
((1 + default_rel t) * g t (length l' - 1) * 1 + default_rel t * 1) by nra.
rewrite one_plus_d_mul_g; apply Req_le; rewrite Rmult_1_r. f_equal; lia.
Qed.

End NAN.


Require Import EqNat.

(** * Hypermaps in Coq *)
(** ** Dimensions
  We define dimensions inductively. As there are only two dimensions to be considered, we just define two branches: 0 and 1.
*)
Inductive dimension: Set :=
| zero: dimension
| one: dimension.

(** We then prove that equality of dimensions is decidable i.e. either two dimensions
    are equal or they are not equal. Logic in Coq is constructive, we need to prove
    seperately, even though it may seem trivial
*)
Theorem eq_dimension_decide: forall p q: dimension,
  {p = q} + {p <> q}.
Proof.
  intros.
  destruct p, q;
  try(left; reflexivity);
  right; intro; discriminate.
Qed.

(** ** Darts
  Darts we simply encode as natural numbers.
*)

Definition dart := nat.
Definition eq_dart_decide := eq_nat_decide.
Definition nil := 0.

(** We set aside 0 for the [nil] dart. We use the [nil] dart for exceptions later on. *)

(** ** Free Maps
  Before going into hypermaps we first define a collection of darts we call a free map.
  We will use this definition of free maps, and some propositions to define hyper maps.
  A Free Map we define inductively as either a empty free map, or a free map with a dart
  inserted into it, or a free map with two darts joined in a specified dimension.
  *)

Inductive free_map: Set :=
(* void(empty) free map *)
| V: free_map
(* inserting dart d into free map f *)
| I(f: free_map)(d: dart): free_map
(* linking darts d1 and d2, of free map f, in dimension d *)
| L(f: free_map)(dim: dimension)(d1 d2: dart): free_map.

(** Then we define [dart_exists] which checks if a dart is in a map *)

Fixpoint dart_exists (d: dart) (f: free_map): Prop :=
  match f with
  | V => False
  | I f' d' => d = d' \/ dart_exists d f'
  | L f' _ _ _ => dart_exists d f'
  end.

(** We then prove decidability of [dart_exists]: either a dart exists in a map,
  or it doesn't
*)

Theorem dart_exists_is_decidable: forall d m,
  {dart_exists d m} + {~dart_exists d m}.
Proof.
  intros.
  induction m; simpl.
  - right. intro. assumption.
  - destruct IHm.
    + left. right. assumption.
    + destruct (eq_dart_decide d d0) as [H1 | H1].
      * apply (eq_nat_eq d d0) in H1.
        left. left. assumption.
      * unfold not in H1.
        right.
        intro.
        destruct H.
        -- apply H1. apply eq_eq_nat. assumption.
        -- apply n. assumption.
  - assumption.
Qed.

Fixpoint A (f: free_map)(k: dimension)(d: dart) :=
  match f with
  | V => nil
  | I f' _ => A f' k d
  | L f' k' d1 d2 =>
      if (eq_dimension_decide k k') then
        if (eq_dart_decide d d1) then
          d2
        else
          A f' k d
      else
        A f' k d
  end.

Fixpoint A_inv (f: free_map)(k: dimension)(d: dart) :=
  match f with
  | V => nil
  | I f' _ => A_inv f' k d
  | L f' k' d1 d2 =>
      if (eq_dimension_decide k k') then
        if (eq_dart_decide d d2) then
          d1
        else
          A_inv f' k d
      else
        A_inv f' k d
  end.


Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelflip.

Section Euclid.

Context `{Ax1:euclidean_neutral}.

Lemma lemma_PGrotate :
   forall A B C D,
   PG A B C D ->
   PG B C D A.
Proof.
intros.
assert ((Par A B C D /\ Par A D B C)) by (conclude_def PG ).
assert (Par B C A D) by (conclude lemma_parallelsymmetric).
assert (Par B C D A) by (forward_using lemma_parallelflip).
assert (Par B A C D) by (forward_using lemma_parallelflip).
assert (PG B C D A) by (conclude_def PG ).
close.
Qed.

End Euclid.


Require Export Untyped.
Require Import Omega.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Plus.
Require Import Coq.Arith.Lt.

(** (l)ift (t)erms by some (l)evel if greater or equal the (b)ound **)

Fixpoint lift (l: nat) (b: nat) (t: lterm) : lterm :=
  match t with
      | Var i as v =>  if (lt_dec i b) then v else Var (i+l)
      | App m n => App (lift l b m) (lift l b n)
      | Lam t => Lam (lift l (b+1) t)
  end.

Definition shift (b: nat) (t: lterm) : lterm :=
  lift 1 b t.

(** Substitute the variable with index [v] by [r] in the term [t] **)

Fixpoint subst (v: nat) (r: lterm) (t: lterm) : lterm :=
  match t with
      | Var i =>  match (nat_compare i v) with
                           | Lt => Var i
                           | Eq => lift v 0 r
                           | Gt => Var (i - 1)
                  end
      | App m n => App (subst v r m) (subst v r n)
      | Lam m => Lam (subst (v+1) r m)
  end.

Lemma lift_0_ident:
  forall M, forall b,
    lift 0 b M = M.
Proof.
  induction M.
  intros. simpl. replace (n + 0) with n. case (lt_dec n b).
     reflexivity. reflexivity.
     auto.
  simpl. intros. rewrite IHM. reflexivity.
  simpl. intros. rewrite IHM1. rewrite IHM2. reflexivity.
Qed.

(** The following lemmas are described in Berghofer and Urban, who
    seem to trace down these due to Huet
*)

Lemma lift_fuse:
  forall (N: lterm) (i j n m: nat),
    i <= j <= i + m -> lift n j (lift m i N) = lift (n+m) i N.
Proof.
  induction N as [k | N1 N2 | N1].
    (* N := Var k *)
    intros. simpl. case_eq (lt_dec k i).
      (* k < i *)
      intros. simpl. assert (k < j).
          apply lt_le_trans with i. assumption. apply H.
          destruct (lt_dec k j). reflexivity. contradict H1. auto.
      (* k >= i *)
      intros. simpl.
          destruct (lt_dec (k+m) j). contradict l. omega. apply f_equal.
          omega.
    (* N := Lam .. *)
    intros. simpl. apply f_equal. rewrite N2. reflexivity. omega.
    (* N := App .. .. *)
    intros. simpl. rewrite IHN1. rewrite IHN2. auto. auto. auto.
Qed.

Lemma lift_lem2:
  forall (N L: lterm) (i j k: nat),
  k <= j -> lift i k (subst j L N) = subst (j+i) L (lift i k N).
Proof.
  induction N as [v | N' | N1 ].
    (* N := Var v *)
    intros. simpl. case_eq (nat_compare v j).
      (* v Eq j *)
      intros. apply nat_compare_eq in H0. rewrite lift_fuse.
      destruct (lt_dec v k).
        (* v < k *)
        simpl. case_eq (nat_compare v (j + i)).
          (* Eq *)
          rewrite plus_comm. reflexivity.
          (* Lt *)
          contradict l. omega.
          (* Gt *)
          intros. apply nat_compare_gt in H1. contradict H1. omega.
        (* ~ v < k *)
        simpl. case_eq (nat_compare (v+i) (j+i)).
          (* Eq *)
          intros. rewrite plus_comm. reflexivity.
          (* Lt *)
          intros. apply nat_compare_lt in H1. contradict H1. omega.
          (* Gt *)
          intros. apply nat_compare_gt in H1. contradict H1. omega.
        split. omega. omega.
      (* v Lt j *)
      intros. apply nat_compare_lt in H0. destruct (lt_dec v k).
        (* v < k *)
        simpl. destruct (lt_dec v k).
          (* v < k *)
          case_eq (nat_compare v (j + i)).
            (* Eq *)
            intros. apply nat_compare_eq in H1. contradict H0. omega.
            (* Lt *)
            intros. reflexivity.
            (* Gt *)
            intros. apply nat_compare_gt in H1. contradict H1. omega.
          (* ~ v < k *)
          contradiction.
        (* ~ v < k *)
        simpl. destruct (lt_dec v k).
          (* v < k *)
          contradiction.
          (* ~ v < k *)
          case_eq (nat_compare (v+i) (j+i)).
            (* Eq *)
            intros. apply nat_compare_eq in H1. contradict H0. omega.
            (* Lt *)
            intros. reflexivity.
            (* Gt *)
            intros. apply nat_compare_gt in H1. contradict H0. omega.
      (* v Gt j *)
      intros. apply nat_compare_gt in H0. simpl. destruct (lt_dec (v - 1) k).
        (* v - 1 < k *)
        contradict l. omega.
        (* ~ v - 1 < k *)
        destruct (lt_dec v k).
          (* v < k *)
          contradict l. omega.
          (* ~ v < k *)
          simpl. case_eq (nat_compare (v + i) (j + i)).
            (* Eq *)
            intros. apply nat_compare_eq in H1. contradict H0. omega.
            (* Lt *)
            intros. apply nat_compare_lt in H1. contradict H0. omega.
            (* Gt *)
            intros. apply nat_compare_gt in H1. f_equal. omega.
    (* N := Lam N' *)
    intros. simpl. f_equal.
    assert (U: j + 1 + i = j + i + 1). omega. rewrite <- U.
    apply (IHN' L i (j+1) (k+1)). omega.
    (* N := App N1 N2 *)
    intros. simpl. f_equal.
    apply IHN1. assumption.
    apply IHN2. assumption.
Qed.

Lemma lift_lem3:
  forall (L P: lterm) (i j k: nat),
  k <= i < k + (j + 1) -> subst i P (lift (j+1) k L) = lift j k L.
Proof.
  intro L. induction L.
  intros. simpl. destruct (lt_dec n k).
    intros. simpl. assert (n < i). apply lt_le_trans with k. assumption. apply H.
    apply nat_compare_lt in H0. rewrite H0. reflexivity.

    simpl. apply not_lt in n0. assert (i < n + (j + 1)). omega.
     apply nat_compare_gt in H0. rewrite H0. apply f_equal. omega.

  intros. simpl. apply f_equal. apply IHL. omega.
  intros. simpl. rewrite IHL1. rewrite IHL2. reflexivity.
  auto. auto.
Qed.

(** We now proceed to prove the substitution lemma **)

(* variable case of the substitution lemma *)
Lemma var_subst_lemma: forall (i j n: nat), forall (N L: lterm),
   (i <= j) ->
       subst j L (subst i N (Var n)) =
                 subst i (subst (j-i) L N) (subst (j+1) L (Var n)).
Proof.
  intros. simpl. case_eq (nat_compare n i).
  (* n = i *)
    intros. simpl. apply nat_compare_eq in H0. rewrite H0. simpl.
    assert (i < j + 1). omega. apply nat_compare_lt in H1. rewrite H1.
    simpl. assert (i = i). reflexivity. apply nat_compare_eq_iff in H2.
    rewrite H2. clear H1 H2. rewrite lift_lem2.
    assert (Jeq: j - i + i = j). omega. rewrite Jeq. reflexivity. omega.
  (* n < i *)
    simpl. intros. apply nat_compare_lt in H0.
    assert (n < j). omega. assert (n < j + 1). omega.
    apply nat_compare_lt in H0.
    apply nat_compare_lt in H1.
    apply nat_compare_lt in H2.
    rewrite  H1, H2. simpl. rewrite H0. reflexivity.
  (* n > i *)
    intros.
    apply nat_compare_gt in H0.
    case_eq (nat_compare n (j + 1)).
      (* n = j + 1 *)
      intros. apply nat_compare_eq in H1. rewrite H1.
      assert (Jeq: j + 1 - 1 = j). omega. rewrite Jeq. simpl.
      assert (HH: nat_compare j j = Eq). assert (JJ: j = j). reflexivity.
          apply nat_compare_eq_iff in JJ. assumption.
      rewrite HH. rewrite lift_lem3. reflexivity. omega.
      (* n < j + 1 *)
      intros. apply nat_compare_lt in H1. simpl.
      assert (HLt: nat_compare (n-1) j = Lt).
        assert (n - 1 < j). omega. apply nat_compare_lt in H2. assumption.
        rewrite HLt.
      assert (Hgt: nat_compare n i = Gt).
        apply nat_compare_gt in H0. assumption.
        rewrite Hgt.
      reflexivity.
      (* n > j + 1 *)
      intros. apply nat_compare_gt in H1. simpl.
      assert (Ineq1: nat_compare (n - 1) j = Gt).
        assert (F: n - 1 > j). omega.
        apply nat_compare_gt in F. assumption. rewrite Ineq1.
      assert (Ineq2: nat_compare (n - 1) i = Gt).
        assert (n - 1 > i). omega. apply nat_compare_gt in H2. assumption.
        rewrite Ineq2.
      reflexivity.
Qed.

(** The substitution lemma.
    The named version looks like this:

       [x =/= y] and [x] not free in [L] implies:
           [M[x/N][y/L] = M[y/L][x/(N[y/L])]
**)

Lemma subst_lemma: forall (M N L: lterm), forall (i j: nat),
   (i <= j) ->
       subst j L (subst i N M) = subst i (subst (j-i) L N) (subst (j+1) L M).
Proof.
  induction M.
  intros. intros. apply var_subst_lemma. assumption.
  intros. simpl. apply f_equal. rewrite IHM.
  assert (AllGood: j + 1 - (i + 1) = j - i). omega.
  rewrite AllGood. reflexivity. omega.
  intros. simpl. rewrite IHM1. rewrite IHM2. reflexivity.
  auto. auto.
Qed.

(** A few other useful lemmas about [lift] and [subst]. **)

(** Attempting to substitute a variable with index [k] in a term which is
    already shifted by [k] simply un-shifts the term: **)

Lemma subst_shift_ident:
    forall t, forall k v,
    subst k v (shift k t) =  t.
Proof.
  induction t.
  unfold shift. intros.
  simpl.
  case_eq (lt_dec n k).
  intros. simpl. clear H. rewrite nat_compare_lt in l. rewrite l.
  reflexivity.
  intros. simpl.
  case_eq (nat_compare (n+1) k). intros. apply nat_compare_eq_iff in H0. omega.
  intros. apply nat_compare_lt in H0. omega.
  intros. f_equal. omega.

  intros. simpl. f_equal.
  apply IHt.

  intros. simpl. f_equal. apply IHt1. apply IHt2.
Qed.

(** Similarly, if the variable we're substituting in is [Var 0], then
    it gets unshifted even more: **)

Lemma subst_k_shift_S_k:
    forall t, forall k,
    subst k (Var 0) (shift (S k) t) = t.
Proof.
  induction t.
  unfold shift. simpl.
  case_eq (lt_dec n 1).
  intros. simpl. assert (HH: n = 0). omega.
  rewrite HH. simpl.
  case_eq (lt_dec k 1).
  intros. simpl. assert (HHH: k = 0). omega.
  rewrite HHH. reflexivity.
  intros.
  case_eq (lt_dec 0 k).
  intros. simpl. destruct k.
  reflexivity. reflexivity.
  intros. omega.

  intros.
  case_eq (lt_dec n k).
  intros. simpl.
  case_eq (nat_compare n k).
  intros. apply nat_compare_eq_iff in H1. f_equal. auto.
  rewrite H1.
  case_eq (lt_dec k (S k)).
  intros. simpl. replace (nat_compare k k) with Eq. reflexivity.
  symmetry. apply nat_compare_eq_iff. reflexivity.
  intros. omega. intros. apply nat_compare_lt in H1.
  case_eq (lt_dec n (S k)).
  intros. simpl.
  replace (nat_compare n k) with Lt. reflexivity.
  symmetry. apply nat_compare_lt. assumption.
  intros. omega. intros. apply nat_compare_gt in H1. omega.
  intros.
  case_eq (lt_dec n (S k)).
  intros. assert (n = k). omega. rewrite H2.
  simpl. replace (nat_compare k k) with Eq.
  reflexivity. symmetry. apply nat_compare_eq_iff. reflexivity.
  intros. simpl.
  replace (nat_compare (n+1) k) with Gt. f_equal. omega.
  symmetry. apply nat_compare_gt. omega.

  intros. simpl. f_equal. apply IHt.

  intros. simpl. f_equal. apply IHt1. apply IHt2.
Qed.

(** Given compatible bounds, a sequence of [lift]s commutes in a very specific
    way: **)

Lemma lift_lift:
    forall M, forall b1 b2 k1 k2,
      b1 <= b2 ->
      lift k1 b1 (lift k2 b2 M) = lift k2 (k1 + b2) (lift k1 b1 M).
Proof.
  induction M.
  intros.
  simpl.
  case_eq (lt_dec n b1).
  intros.
  case_eq (lt_dec n b2).
  intros.
  simpl. rewrite H0.
  case_eq (lt_dec n (k1 + b2)).
  intros. reflexivity.
  intros. omega.
  intros. omega.

  intros.
  case_eq (lt_dec n b2).
  intros. simpl.
  rewrite H0.
  case_eq (lt_dec (n+k1) (k1+b2)).
  intros. reflexivity.
  intros. omega.
  intros. simpl.
  case_eq (lt_dec (n+k2) b1).
  intros. omega. intros.
  case_eq (lt_dec (n+k1) (k1+b2)).
  intros. omega.
  intros. f_equal. omega.

  intros.
  simpl.
  f_equal. rewrite IHM.
  f_equal. omega. omega.

  intros.
  simpl. f_equal. apply IHM1. omega.
  apply IHM2. omega.
Qed.

(** This is a reverse statement of [lift_lift]: **)

Lemma lift_lift_rev:
  forall wk k ws s t,
  k >= s + ws ->
  lift wk k (lift ws s t) = lift ws s (lift wk (k - ws) t).
Proof.
  intros.
  replace k with (ws + (k - ws)) by omega.
  rewrite <- lift_lift by omega.
  replace (ws + (k - ws) - ws) with (k - ws) by omega.
  reflexivity.
Qed.

(** [lift] distributes over [subst], also in a specific way: **)

Lemma lift_distr_subst:
  forall M N, forall v, forall i b,
    v <= b ->
    lift i b (subst v N M) = subst v (lift i (b-v) N) (lift i (b+1) M).
Proof.
  induction M. intros N v.
  generalize dependent N.
  generalize dependent n.
  induction v.
  intros ? ? ? ? HH. simpl. case_eq (nat_compare n 0).
  intros H. apply nat_compare_eq_iff in H. rewrite H. simpl.
  replace (b + 1) with (S b) by omega. simpl.
  rewrite lift_0_ident. rewrite lift_0_ident.
  replace (b - 0) with b by omega. reflexivity.

  intros. simpl. apply nat_compare_lt in H. omega.
  intros. simpl. apply nat_compare_gt in H.

  assert (H1: exists n', n = (S n')).
  inversion H. exists 0. reflexivity.
  exists m. reflexivity.

  destruct H1. rewrite H0. replace (S x - 1) with x by omega.
  simpl.  replace (b +1) with (S b) by omega.
  case_eq (lt_dec x b).
  simpl.
  intros. case_eq (lt_dec (S x) (S b)).
  intros. simpl. f_equal. omega.
  intros. omega. intros.
  case_eq (lt_dec (S x) (S b)). intros. simpl. omega.
  intros. simpl. f_equal. omega.

  intros ? ? ? ? HH. simpl.
  case_eq (nat_compare n (S v)).
  intros H. apply nat_compare_eq_iff in H.
  rewrite H. simpl.
  case_eq (lt_dec (S v) (b + 1)).
  intros.
  simpl. replace (nat_compare v v) with Eq.
  replace b with (((b - S v) + (S v))) by omega.
  rewrite lift_lift_rev. reflexivity.
  omega. symmetry. apply nat_compare_eq_iff. reflexivity.
  intros. simpl.
  case_eq (nat_compare (v+i) v).
  intros. apply nat_compare_eq_iff in H1.
  assert (HHH: i = 0). omega.
  rewrite HHH. rewrite lift_0_ident.
  f_equal. rewrite lift_0_ident. reflexivity.
  intros. apply nat_compare_lt in H1.
  omega. intros. apply nat_compare_gt in H1.
  omega.
  intros.
  apply nat_compare_lt in H.
  simpl.
  case_eq (lt_dec n b).
  intros.
  case_eq (lt_dec n (b+1)).
  simpl. intros.
  replace (nat_compare n (S v)) with Lt.
  reflexivity. symmetry. apply nat_compare_lt. assumption.
  intros. omega.
  intros. omega.
  intros. apply nat_compare_gt in H.
  simpl. case_eq (lt_dec (n - 1) b).
  intros. case_eq (lt_dec n (b+1)).
  intros. simpl. replace (nat_compare n (S v)) with Gt.
  reflexivity. symmetry. apply nat_compare_gt. assumption.
  intros. omega.
  intros. case_eq (lt_dec n (b+1)). intros.
  omega. intros. simpl.
  case_eq (nat_compare (n+i) (S v)).
  intros. apply nat_compare_eq_iff in H2.
  omega.
  intros. apply nat_compare_lt in H2.
  omega.
  intros. f_equal. omega.

  intros.
  simpl. f_equal.
  rewrite IHM. f_equal. f_equal. omega. omega.

  intros. simpl. f_equal. apply IHM1. omega.
  apply IHM2. omega.
Qed.

(** Finally, some trivialities for convenient rewriting. **)

Lemma subst_app : forall t1 t2 t3, forall n,
  subst n t3 (App t1 t2) = App (subst n t3 t1) (subst n t3 t2).
Proof. intros. reflexivity. Qed.

Lemma subst_lam : forall t t', forall n,
  subst n t' (Lam t) = Lam (subst (n+1) t' t).
Proof.  intros. reflexivity. Qed.

Lemma lift_app : forall t t' n k,
  lift n k (App t t') = App (lift n k t) (lift n k t').
Proof. intros. reflexivity. Qed.

Lemma lift_lam : forall t n k,
  lift n k (Lam t) = Lam (lift n (k+1) t).
Proof. intros. reflexivity. Qed.


From Enderton Require Export NaturalNumbers.

(** In this chapter, Enderton embeds the real numbers into the axiomatic set
    theory. He begins by constructing the integers as equivalence classes of
    ordered pairs of natural numbers. *)

Definition NatPair_Equivalence (r : set) : Prop :=
  forall x, In x r <-> exists m n mn p q pq mq pn,
      NaturalNumber m /\ NaturalNumber n /\ OrdPair m n mn /\
      NaturalNumber p /\ NaturalNumber q /\ OrdPair p q pq /\
      Sum_w m q mq /\ Sum_w p n pn /\ mq = pn /\ OrdPair mn pq x.

Theorem NatPair_Equivalence_Exists : exists x, NatPair_Equivalence x.
Proof.
  omga. prod omga omga. rename x into wxw. rename H into Hwxw.
  prod wxw wxw. rename x into wxwxwxw. rename H into Hwxwxwxw.
  build_set unit
    (fun (_ : unit) (wxwxwxw ab : set) => exists m n mn p q pq mq pn,
      NaturalNumber m /\ NaturalNumber n /\ OrdPair m n mn /\
      NaturalNumber p /\ NaturalNumber q /\ OrdPair p q pq /\
      Sum_w m q mq /\ Sum_w p n pn /\ mq = pn /\ OrdPair mn pq ab)
    tt wxwxwxw.
  rename x into eq. rename H into Heq. exists eq. intros x. split; intros H.
  - apply Heq. assumption.
  - apply Heq. split; try assumption.
    apply Hwxwxwxw. destruct H as [m [n [mn [p [ q [pq [mq [pn H]]]]]]]].
    destruct H as [Hm [Hn [Hmn [Hp [Hq [Hpq [_ [_ [_ H]]]]]]]]].
    exists mn. exists pq. split; try (split; try assumption).
    + apply Hwxw. exists m. exists n. split; try apply Homga; try assumption.
      split; try apply Homga; try assumption.
    + apply Hwxw. exists p. exists q. split; try split; try apply Homga; try assumption.
Qed.

Theorem NatPair_Equivalence_Unique : forall x y, NatPair_Equivalence x ->
                                            NatPair_Equivalence y -> x = y.
Proof.
  intros A B HA HB. apply Extensionality_Axiom. intros x. split; intros H.
  - apply HB. apply HA. assumption.
  - apply HA; apply HB; assumption.
Qed.

Ltac natpair_eq := destruct NatPair_Equivalence_Exists.

Lemma NatPair_Equivalence_On_NatPairs : forall eq w wxw,
    NatPair_Equivalence eq -> Nats w -> Prod w w wxw -> RelationOn eq wxw.
Proof.
  intros eq w wxw Heq Hw Hwxw ab H. apply Heq in H.
  destruct H as [m [n [mn [p [q [pq [_ [_ [Hm [Hn [Hmn [Hp [Hq [Hpq [_ [_ [_ H]]]]]]]]]]]]]]]]].
  exists mn, pq. split; try assumption. split.
    + apply Hwxw. exists m, n. repeat (split; try assumption; try apply Hw; try assumption).
    + apply Hwxw. exists p, q. repeat (split; try assumption; try apply Hw; try assumption).
Qed.

Theorem Enderton5ZA : forall x w wxw, NatPair_Equivalence x -> Nats w ->
                                 Prod w w wxw -> EquivalenceRelation x wxw.
Proof.
  intros eq w wxw Heq Hw Hwxw. repeat (try split).
  - apply (NatPair_Equivalence_On_NatPairs eq w wxw); try assumption.
  - intros a aa Haa H. apply Heq. apply Hwxw in H. destruct H as [x [y [Hx [Hy Ha]]]].
    apply Hw in Hx, Hy. exists x, y, a, x, y, a.
    sum_w x y Hx Hy. rename x0 into xy. rename H into Hxy. exists xy, xy.
    repeat (split; try assumption).
  - intros x y xy yx Hxy Hyx H. apply Heq in H. apply Heq.
    destruct H as [m [n [mn [p [q [pq [mq [pn H]]]]]]]].
    destruct H as [Hm [Hn [Hmn [Hp [Hq [Hpq [Hmq [Hpn [H Hxy']]]]]]]]].
    exists p, q, pq, m, n, mn, pn, mq.
    assert (P : mn = x /\ pq = y). {
      apply (Enderton3A mn pq x y xy xy Hxy' Hxy). reflexivity. }
    destruct P as [P1 P2]. replace y with pq in Hyx. replace x with mn in Hyx.
    repeat (split; try assumption). symmetry. assumption.
  - intros x y z xy yz xz Hxy Hyz Hxz H1 H2.
    apply Heq. apply Heq in H1, H2.
    destruct H1 as [m [n [mn [p [q [pq [mq [pn H1]]]]]]]].
    destruct H1 as [Hm [Hn [Hmn [Hp [Hq [Hpq [Hmq [Hpn [H1 Hxy']]]]]]]]].
    destruct H2 as [p' [q' [pq' [r [s [rs [ps [rq H2]]]]]]]].
    destruct H2 as [Hp' [Hq' [Hpq' [Hr [Hs [Hrs [Hps [Hrq [H2 Hyz']]]]]]]]].
    replace p' with p in *. replace q' with q in *. replace pq' with pq in *.
    sum_w m s Hm Hs. rename x0 into ms. rename H into Hms.
    sum_w r n Hr Hn. rename x0 into rn. rename H into Hrn.
    exists m, n, mn, r, s, rs, ms, rn.
    replace x with mn in Hxz. replace z with rs in Hxz. repeat (split; try assumption).
    sum_w ms p (Sum_NaturalNumber m s ms Hm Hs Hms) Hp.
    rename x0 into msp. rename H into Hmsp.
    sum_w rn p (Sum_NaturalNumber r n rn Hr Hn Hrn) Hp.
    rename x0 into rnp. rename H into Hrnp.
    apply (Enderton4P ms rn p msp rnp).
    { apply (Sum_NaturalNumber m s ms Hm Hs Hms). }
    { apply (Sum_NaturalNumber r n rn Hr Hn Hrn). }
    apply Hp. apply Hmsp.  apply Hrnp.
    sum_w n p Hn Hp. rename x0 into np. rename H into Hnp.
    sum_w r np Hr (Sum_NaturalNumber n p np Hn Hp Hnp). rename x0 into rnp'. rename H into Hrnp'.
    transitivity rnp'. sum_w s p Hs Hp. rename x0 into sp. rename H into Hsp.
    sum_w m sp Hm (Sum_NaturalNumber s p sp Hs Hp Hsp). rename x0 into msp'. rename H into Hmsp'.
    transitivity msp'. symmetry. Print Enderton4K1.
    apply (Enderton4K1 m s p sp ms msp' msp Hm Hs Hp Hsp Hms Hmsp' Hmsp).
    sum_w r pn Hr (Sum_NaturalNumber p n pn Hp Hn Hpn). rename x0 into rpn. rename H into Hrpn.
    transitivity rpn.
    sum_w m ps Hm (Sum_NaturalNumber p s ps Hp Hs Hps). rename x0 into mps. rename H into Hmps.
    transitivity mps.
    apply (Sum_w_Unique m ps msp' mps Hm (Sum_NaturalNumber p s ps Hp Hs Hps)); try assumption.
    replace ps with sp. assumption. apply (Enderton4K2 s p sp ps Hs Hp Hsp Hps).
    sum_w r mq Hr (Sum_NaturalNumber m q mq Hm Hq Hmq). rename x0 into rmq. rename H into Hrmq.
    transitivity rmq. sum_w q m Hq Hm. rename x0 into qm. rename H into Hqm.
    sum_w r qm Hr (Sum_NaturalNumber q m qm Hq Hm Hqm). rename x0 into rqm. rename H into Hrqm.
    transitivity rqm.
    sum_w rq m (Sum_NaturalNumber r q rq Hr Hq Hrq) Hm. rename x0 into rqm'. rename H into Hrqm'.
    transitivity rqm'.
    sum_w m rq Hm (Sum_NaturalNumber r q rq Hr Hq Hrq). rename x0 into mrq. rename H into Hmrq.
    transitivity mrq. apply (Sum_w_Unique m ps mps mrq); try assumption.
    apply (Sum_NaturalNumber p s ps Hp Hs Hps). replace ps with rq; try assumption.
    apply (Enderton4K2 m rq mrq rqm'); try assumption.
    apply (Sum_NaturalNumber r q rq); try assumption.
    symmetry. apply (Enderton4K1 r q m qm rq); try assumption.
    apply (Sum_w_Unique r qm rqm rmq); try assumption.
    apply (Sum_NaturalNumber q m qm); try assumption.
    replace qm with mq; try assumption.
    apply (Enderton4K2 m q mq qm); try assumption.
    apply (Sum_w_Unique r mq rmq rpn); try assumption.
    apply (Sum_NaturalNumber m q mq); try assumption.
    replace mq with pn; try assumption.
    apply (Sum_w_Unique r pn rpn rnp'); try assumption.
    apply (Sum_NaturalNumber p n pn); try assumption.
    replace pn with np; try assumption.
    apply (Enderton4K2 n p np pn); try assumption.
    apply (Enderton4K1 r n p np rn); try assumption.
    assert (P : pq = y /\ rs = z). {
      apply (Enderton3A pq rs y z yz yz); try assumption. trivial. }
    apply P.
    assert (P : mn = x /\ pq = y). {
      apply (Enderton3A mn pq x y xy xy); try assumption. trivial. }
    apply P.
    transitivity y.
    assert (P : mn = x /\ pq = y). {
      apply (Enderton3A mn pq x y xy xy); try assumption. trivial. }
    apply P.
    assert (P : pq' = y /\ rs = z). {
      apply (Enderton3A pq' rs y z yz yz); try assumption. trivial. }
    symmetry. apply P.
    assert (P : pq' = y /\ rs = z). {
      apply (Enderton3A pq' rs y z yz yz); try assumption. trivial. }
    assert (Q : mn = x /\ pq = y). {
      apply (Enderton3A mn pq x y xy xy); try assumption. trivial. }
    assert (R : pq = pq'). {
      transitivity y; try apply Q; try (symmetry; apply P). }
    assert (S : p = p /\ q = q'). {
      apply (Enderton3A p q p q' pq pq'); try assumption. }
    apply S.
    assert (P : pq' = y /\ rs = z). {
      apply (Enderton3A pq' rs y z yz yz); try assumption. trivial. }
    assert (Q : mn = x /\ pq = y). {
      apply (Enderton3A mn pq x y xy xy); try assumption. trivial. }
    assert (R : pq = pq'). {
      transitivity y; try apply Q; try (symmetry; apply P). }
    assert (S : p = p' /\ q = q'). {
      apply (Enderton3A p q p' q' pq pq'); try assumption. }
    apply S.
Qed.

Definition Ints (Z : set) : Prop :=
  forall w wxw natpair_eq, Nats w -> Prod w w wxw -> NatPair_Equivalence natpair_eq ->
                      Quotient wxw natpair_eq Z.

Theorem Ints_Exists : exists Z, Ints Z.
Proof.
  natpair_eq. rename x into eq. rename H into Heq.
  omga. prod omga omga. rename x into wxw. rename H into Hwxw.
  assert (P : RelationOn eq wxw). {
    destruct (Enderton5ZA eq omga wxw Heq Homga Hwxw). assumption. }
  quotient P wxw eq. exists x. intros w wxw' eq' Hw Hwxw' Heq'.
  replace wxw' with wxw; replace eq' with eq; try assumption;
    try (apply NatPair_Equivalence_Unique; assumption).
  - apply (Prod_Unique omga omga); try assumption.
    replace omga with w; try assumption.
    apply (Nats_Unique); assumption.
Qed.

Theorem Ints_Unique : forall Z Z', Ints Z -> Ints Z' -> Z = Z'.
Proof.
  intros Z Z' HZ HZ'. omga.
  prod omga omga. rename x into wxw. rename H into Hwxw.
  natpair_eq. rename x into eq. rename H into Heq.
  apply (Quotient_Unique wxw eq);
    try apply (NatPair_Equivalence_On_NatPairs eq omga wxw); try assumption.
  - apply (HZ omga wxw eq); try assumption.
  - apply (HZ' omga wxw eq); try assumption.
Qed.

Ltac Z := destruct (Ints_Exists) as [Z HZ].

Definition Int (a : set) : Prop :=
  forall Z, Ints Z -> In a Z.

Definition Addition_Z (add : set) : Prop :=
  forall abc, In abc add <-> exists ab c a b m n p q mn pq mp nq mpnq eq,
      OrdPair ab c abc /\ OrdPair a b ab /\ Int a /\ Int b /\
      NaturalNumber m /\ NaturalNumber n /\ NaturalNumber p /\ NaturalNumber q /\
      OrdPair m n mn /\ OrdPair p q pq /\ Sum_w m p mp /\ Sum_w n q nq /\
      OrdPair mp nq mpnq /\ NatPair_Equivalence eq /\ EquivalenceClass mn eq a /\
      EquivalenceClass pq eq b /\ EquivalenceClass mpnq eq c.

Theorem Addition_Z_Exists : exists add_Z, Addition_Z add_Z.
Proof.
  Z. prod Z Z. rename x into ZxZ. rename H into HZxZ.
  prod ZxZ Z. rename x into ZxZxZ. rename H into HZxZxZ.
  build_set unit
    (fun (_ : unit) (ZxZxZ abc : set) => exists ab c a b m n p q mn pq mp nq mpnq eq,
      OrdPair ab c abc /\ OrdPair a b ab /\ Int a /\ Int b /\
      NaturalNumber m /\ NaturalNumber n /\ NaturalNumber p /\ NaturalNumber q /\
      OrdPair m n mn /\ OrdPair p q pq /\ Sum_w m p mp /\ Sum_w n q nq /\
      OrdPair mp nq mpnq /\ NatPair_Equivalence eq /\ EquivalenceClass mn eq a /\
      EquivalenceClass pq eq b /\ EquivalenceClass mpnq eq c)
    tt ZxZxZ.
  rename x into add. rename H into Hadd. exists add. intros abc. split; intros H.
  - apply Hadd. assumption.
  - apply Hadd. split; try assumption.
    destruct H as [ab [c [a [b [m [n [p [q [mn [pq [mp [nq [mpnq [eq H]]]]]]]]]]]]]].
    destruct H as [Habc [Hab [Ha [Hb [Hm [Hn [Hp [Hq [Hmn [Hpq [Hmp [Hnq [Hmpnq [Heq [HCa [HCb HCc]]]]]]]]]]]]]]]].
    apply HZxZxZ. exists ab, c. split; try (split; try assumption).
    apply HZxZ. exists a, b. repeat (split; try assumption).
    + apply Ha; try assumption.
    + apply Hb; try assumption.
    + omga. prod omga omga. rename x into wxw. rename H into Hwxw.
      apply (HZ omga wxw eq Homga Hwxw Heq
                (NatPair_Equivalence_On_NatPairs eq omga wxw Heq Homga Hwxw)).
      exists mpnq. split; try assumption. apply Hwxw.
      exists mp, nq. split; try split; try assumption. Check Sum_NaturalNumber.
      * apply Homga. apply (Sum_NaturalNumber m p mp Hm Hp Hmp).
      * apply Homga. apply (Sum_NaturalNumber n q nq Hn Hq Hnq).
Qed.

Theorem Addition_Z_Unique : forall add_Z add_Z', Addition_Z add_Z -> Addition_Z add_Z' ->
                                            add_Z = add_Z'.
Proof.
  intros Z Z' HZ HZ'. apply Extensionality_Axiom. intros abc. split; intros H.
  - apply HZ'. apply HZ in H. apply H.
  - apply HZ. apply HZ' in H. apply H.
Qed.

Theorem Addition_Z_BinaryOperation : forall Z add_Z, Ints Z -> Addition_Z add_Z ->
                                                BinaryOperator add_Z Z.
Proof.
  intros Z add_Z HZ Hadd_Z. prod Z Z. rename x into ZxZ. rename H into HZxZ.
  exists ZxZ. split; try assumption. split; try split.
  - intros abc Habc. apply Hadd_Z in Habc.
    destruct Habc as [ab [c [a [b [m [n [p [q [mn [pq [mp [nq [mpnq [eq Habc]]]]]]]]]]]]]].
    destruct Habc as [Habc _]. exists ab, c. assumption.
  - intros ab c d abc abd Habc Habd H1 H2.
    apply Hadd_Z in H1, H2.
Admitted.

Ltac add_Z := destruct Addition_Z_Exists as [addZ HaddZ].

Definition Sum_Z (a b c : set) : Prop :=
  exists add ab abc, Addition_Z add /\ OrdPair a b ab /\ OrdPair ab c abc /\
                In abc add.

Theorem Sum_Z_Exists : forall a b, Int a -> Int b -> exists c, Sum_Z a b c.
Proof.
Admitted.

Lemma Enderton5ZB : forall m n m' n' p q p' q' mp nq m'p' n'q' mn m'n' pq p'q' mpnq,
  forall m'p'n'q' A B C eq,
  NaturalNumber m -> NaturalNumber n -> NaturalNumber m' -> NaturalNumber n' ->
  NaturalNumber p -> NaturalNumber q -> NaturalNumber p' -> NaturalNumber q' ->
  Sum_w m p mp -> Sum_w n q nq -> Sum_w m' p' m'p' -> Sum_w n' q' n'q' ->
  OrdPair m n mn -> OrdPair m' n' m'n' -> OrdPair p q pq -> OrdPair p' q' p'q' ->
  OrdPair mp nq mpnq -> OrdPair m'p' n'q' m'p'n'q' ->
  OrdPair mn m'n' A -> OrdPair pq p'q' B -> OrdPair mpnq m'p'n'q' C ->
  NatPair_Equivalence eq ->
  In A eq -> In B eq -> In C eq.
Proof.
Admitted.

(* should follow from Enderton3Q and previous lemma *)
Theorem Sum_Z_Unique : forall a b c c', Int a -> Int b -> Sum_Z a b c ->
                                   Sum_Z a b c' -> c = c'.
Proof.
Admitted.

Ltac sum_w a b Ha Hb := destruct (Sum_Z_Exists a b Ha Hb).

Definition Add_Z_Associative : Prop := forall a b c ab bc r l,
  Int a -> Int b -> Int c -> Sum_Z a b ab -> Sum_Z b c bc ->
  Sum_Z a bc r -> Sum_Z ab c l -> r = l.

Definition Add_Z_Commutative : Prop := forall a b ab ba,
  Int a -> Int b -> Sum_Z a b ab -> Sum_Z b a ba -> ab = ba.

Theorem Enderrton5ZC1 : Add_Z_Associative.
Proof.
Admitted.

Theorem Enderton5ZC2 : Add_Z_Commutative.
Proof.
Admitted.

Definition Zero_Z (z : set) : Prop :=
  forall o oo eq, Empty o -> OrdPair o o oo -> NatPair_Equivalence eq -> EquivalenceClass oo eq z.

Theorem Zero_Z_Exists : exists z, Zero_Z z.
Proof.
Admitted.

Theorem Zero_Z_Unique : forall z z', Zero_Z z -> Zero_Z z' -> z = z'.
Proof.
Admitted.

Ltac zero_z := destruct Zero_Z_Exists.

Theorem Enderton5ZDa : forall a o, Int a -> Zero_Z o -> Sum_Z a o a.
Proof.
Admitted.

Theorem Enderton5ZDb : forall a o, Int a -> Zero_Z o -> exists b, Sum_Z a b o.
Proof.
Admitted.

Theorem Add_Z_Inverse_Unique : forall a b b' o,
  Int a -> Int b -> Int b' -> Zero_Z o -> Sum_Z a b o -> Sum_Z a b' o -> b = b'.
Proof.
Admitted.


(** 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 (lf3 : natural) (lf1 : natural) : natural :=
  plus Zero (plus lf1 lf3).


(** 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 (x : natural) (y : natural) (lf1 : natural) : natural :=
  plus y (plus x lf1).


Require Import Coq.Program.Tactics.
Require Import Coq.Sets.Ensembles.
Require Export Essentials.Notations Essentials.Definitions.

Local Open Scope order_scope.

(** Basic Definition of a preorder relation. *)
Record PartialOrder : Type :=
  {
    PO_Carrier :> Type;
    PO_LE : PO_Carrier → PO_Carrier → Prop where "x ⊑ y" := (PO_LE x y);
    PO_Refl : ∀ x, x ⊑ x;
    PO_ASym : ∀ x y, x ⊑ y → y ⊑ x → x = y;
    PO_Trans : ∀ x y z, x ⊑ y → y ⊑ z → x ⊑ z
  }
.

Arguments PO_Carrier _ : assert.
Arguments PO_LE {_} _ _, _ _ _.
Arguments PO_Refl {_} _.
Arguments PO_ASym {_} _ _ _ _.
Arguments PO_Trans {_} _ _ _ _ _.

Notation "x ⊑ y" := (PO_LE x y) : order_scope.

Definition PO_LT {p : PartialOrder} (x y : p) := (x ⊑ y)%order ∧ x ≠ y.

Notation "x ⊏ y" := (PO_LT x y) : order_scope.

(** A monotone function is order preserving. *)
Record Monotone (A B : PartialOrder) : Type :=
  {
    MNT_fun :> A → B;
    MNT_monotone : ∀ x y, x ⊑ y → MNT_fun x ⊑ MNT_fun y
  }.

Local Hint Resolve MNT_monotone.

Program Definition Monotone_comp
           {A B C : PartialOrder}
           (f : Monotone A B)
           (g : Monotone B C)
  :
    Monotone A C :=
  {|
    MNT_fun := fun x => g (f x)
  |}.

Program Definition iterate_Monotone
        {A : PartialOrder}
        (f : Monotone A A)
        (n : nat)
  :
    Monotone A A :=
  {|
    MNT_fun := fun x => iterate f x n
  |}.

Next Obligation.
Proof.
  induction n; cbn; auto.
Qed.

(** Greatest lower bound and least upper bound in a preorder. *)
Section LUB_GLB.
  Context {A : PartialOrder}.

  Section Generalized.
    Context {X : Type} (f : X → A).

    Record LUB :=
      {
        lub :> A;
        lub_ub : ∀ (x : X), (f x) ⊑ lub;
        lub_lst : ∀ (ub : A), (∀ (x : X), (f x) ⊑ ub) → lub ⊑ ub
      }
    .

    Record GLB :=
      {
        glb :> A;
        glb_lb : ∀ (x : X), glb ⊑ (f x);
        glb_grst : ∀ (lb : A), (∀ (x : X), lb ⊑ (f x)) → lb ⊑ glb
      }
    .

  End Generalized.

  Notation "⊔ᵍ Q" := (LUB Q) : order_scope.

  Notation "⊓ᵍ Q" := (GLB Q) : order_scope.

  Definition LUB_Pair (x y : A) :=
    (⊔ᵍ (fun u : bool => match u with | true => x | false => y end)).

  Definition GLB_Pair (x y : A) :=
    (⊓ᵍ (fun u : bool => match u with | true => x | false => y end)).

End LUB_GLB.

Arguments lub {_ _ _} _.
Arguments glb {_ _ _} _.

Notation "⊔ᵍ Q" := (LUB Q) : order_scope.

Notation "⊓ᵍ Q" := (GLB Q) : order_scope.

Notation "x ⊔ y" := (LUB_Pair x y) : order_scope.

Notation "x ⊓ y" := (GLB_Pair x y) : order_scope.

Hint Resolve PO_Refl PO_ASym PO_Trans.

Theorem LE_LT_Trans {A : PartialOrder} : ∀ (x y z : A), x ⊑ y → y ⊏ z → x ⊏ z.
Proof.
  intros x y z H1 [H21 H22]; split; eauto.
  intros eq.
  rewrite eq in H1; auto.
Qed.

Theorem LT_LE_Trans {A : PartialOrder} : ∀ (x y z : A), x ⊏ y → y ⊑ z → x ⊏ z.
Proof.
  intros x y z [H11 H12] H2; split; eauto.
  intros eq.
  rewrite <- eq in H2; auto.
Qed.


Inductive Var := n | i | sum.
Definition var_eq (v1 v2 : Var) : bool :=
  match v1, v2 with
  |n ,n => true
  |i, i => true
  |sum, sum => true
  |_,_ => false
  end.

Compute (var_eq n n).

(*Eviroment*)
Definition Env := Var -> nat.
Definition env1 : Env :=
  fun x =>
    if (var_eq x n)
    then 10
    else 0.

Check env1.
Compute (env1 n).
Compute (env1 sum).

Definition update (env : Env) (x: Var) (v : nat) : Env :=
  fun y =>
    if(var_eq y x)
    then v
    else (env y).
Check update.

Definition env2 := (update env1 n 1045).
Compute (env2 n).
Compute ((update env1 n 1045) n).

Inductive AExp :=
  |avar : Var -> AExp
  |anum : nat -> AExp
  |aplus : AExp -> AExp -> AExp
  |amul : AExp -> AExp -> AExp.

Notation "A +' B" := (aplus A B) (at level 48).
Notation "A *' B" := (amul A B) (at level 46).
Coercion anum : nat >-> AExp.
Coercion avar : Var >-> AExp.

Check (2 +' 3 *' 5).

Fixpoint aeval (a : AExp) (env : Env) : nat :=
  match a with
  | avar x => env x
  | anum v => v
  | aplus a1 a2 => (aeval a1 env) + (aeval a2 env)
  | amul a1 a2 => (aeval a1 env) * (aeval a2 env)
end.

Compute aeval (2 +' 3 *' 5) env1.
Compute aeval (2 +' 3 *' n) env1.

Inductive BExp :=
| btrue : BExp
| bfalse : BExp
| blessthan : AExp -> AExp -> BExp
| bnot : BExp -> BExp.

Fixpoint beval (b : BExp) (env : Env) : bool :=
  match b with
  | btrue => true
  | bfalse => false
  | blessthan a1 a2 =>Nat.leb (aeval a1 env) (aeval a2 env)
  | bnot b' => negb (beval b' env)
end.

Notation "A <<= B" := (blessthan A B) (at level 58).
Compute beval (bnot (n<<= (2 +' 3 *' n))) env1.

Inductive Stmt :=
| assignment : Var -> AExp -> Stmt
| sequence : Stmt -> Stmt -> Stmt
| while : BExp -> Stmt -> Stmt.

Notation "X ::= N" := (assignment X N) (at level 60).
Notation "S ;; S'" := (sequence S S') (at level 63, right associativity).

Check (n ::= n +' 10).
Check (n ::= 0 ;; i ::=7 ;; sum ::= 0).

Fixpoint eval (s : Stmt) (env : Env) (gas : nat) : Env :=
  match gas with
  |0 => env
  |S gas' => match s with
              | x ::= a => update env x (aeval a env)
              | sequence s1 s2 => eval s2 (eval s1 env gas') gas'
              |while b s => if (beval b env)
                            then (eval (sequence s (while b s)) env gas')
                            else env
  end
end.

Definition pgm := (n ::= 7).
Definition env_after_assign := eval pgm env1.

Definition pgm2 := n ::= 243 ;; i ::= 7 ;; sum ::= 10.

Compute (eval pgm2 env1 100) n.
Compute (eval pgm2 env1 100) i.
Compute (eval pgm2 env1 100) sum.

Definition sumpgm :=
  n::=10;;
  i::=1;;
  sum::=0;;
    while (i<<=n)
      (sum ::= sum +' i ;; i::=i+'1).

Check sumpgm.
Compute (eval sumpgm env1 100) sum.


(* These exercises come from Lab Session 6 of the MAP Spring School *)
(* on formalization of mathematics. *)

From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition onext_id n (x: 'I_n): 'I_n.
pose v := nat_of_ord x.
pose H := ltn_ord x.
pose H1 := leq_trans H (leqnn n).
exact: Ordinal H1.
Defined.

(* {x | x < 0} is an empty type *)
Lemma empty_i0 (x: 'I_0): false.
Proof.
  case x. by [].
Qed.

(* Toy structure from examples *)
Structure semiGroup := SemiGroup {
  toy_dom : Type;
  binop : toy_dom -> toy_dom -> toy_dom;
  binopA : forall x y z : toy_dom,
    binop x (binop y z) = binop (binop x y) z
}.

(* Canonical semigroup: register a semigroup to be available for type
   inference - see next Lemma *)
Canonical nat_semiGroup : semiGroup := @SemiGroup nat addn addnA.

Lemma semigroup_canonical (x y z : nat) : x + (y + z) = x + y + z.
Proof.
  apply: binopA.
Qed.

(* We define here an interface for types equipped with a binary boolean *)
(* relation and a unary operation monotonic wrt the previous relation*)
(* Specification projections are unnamed to avoid introducing *)
(* projections that do not play a role for the inference of canonical *)
(* instances *)
Structure rel_s := Rel_s {
   dom : Type;
   cmp : rel dom;
   f : dom -> dom;
   _ : transitive cmp;
   _ : forall x, cmp x (f x)
}.

(* Now we prove that the relation associated with an instance of rel_s *)
(* is transitive.*)
Lemma cmp_trans (s : rel_s) : transitive (@cmp s).
Proof.
  by case: s.
Qed.

(* Ex1 - Prove the following lemma *)
Lemma cmp_f (s : rel_s) : forall x : dom s, cmp x (f x).
Proof.
  by case: s.
Qed.

Section thms.

(* We a assume a parameter type and all the material needed in order *)
(* to build an instance of rel_s*)
Variables (T : Type) (cmpT : rel T) (fT : T -> T).

Hypothesis cmp_trans : transitive cmpT.

Hypothesis f_mon : forall x, cmpT x (fT x).

(* Define a canonical instance of rel_s for cmpT and fT *)
(* Warning: the effect of canonical declarations do not survive *)
(* to the end of sections *)
Canonical res_st : rel_s := Rel_s cmp_trans f_mon.

(* This is a notation local to the section thms for the relation *)
(* associated with the instance s *)

End thms.

(* Prove the following theorem *)
Lemma f3 : forall (s : rel_s) (n : dom s), cmp n (f (f (f n))).
Proof.
  move => s n.
  apply (@cmp_trans _ (f (f n))).
    - apply (@cmp_trans _ (f n)); by rewrite cmp_f.
    - by rewrite cmp_f.
Qed.

(* Define a canonical instance of rel_s on type nat equipped with the *)
(* relation leq and the successor operation *)
Canonical res_snat : rel_s := Rel_s leq_trans leqnSn.

(* This result comes for free using the more generic f3 *)
Lemma fnat3 n : n <= n.+3.
Proof.
  apply f3.
Qed.

Section pairs.

(* We assume two parameter types, and two binary boolean relations *)
(* respectively on these types, and two unary functions *)

Variables (T1 T2 : Type)(r1 : rel T1)(r2 : rel T2).
Variables (f1 : T1 -> T1)(f2 : T2 -> T2).

Hypothesis r1_trans : transitive r1.
Hypothesis r2_trans : transitive r2.

Hypothesis f1_mon : forall x, r1 x (f1 x).
Hypothesis f2_mon : forall x, r2 x (f2 x).

Definition pair_rel (u v : T1 * T2) := (r1 u.1 v.1) && (r2 u.2 v.2).

(* Complete the following definition to define a function on pairs *)
(* which associates (x, y) with the pair (f1 x, f2 y) *)
Definition pair_fun (u : T1 * T2) := (*D *) (f1 u.1, f2 u.2).

(* State and prove that pair_rel is transitive *)
Lemma pair_rel_trans : transitive pair_rel.
Proof.
  case => x1 x2 [y1 y2] [z1 z2].
  move => /andP. rewrite /=. move => [Hxy1 Hxy2].
  move => /andP /= [Hxz1 Hxz2].
  (* Unfold pair_rel definition *)
  rewrite/pair_rel. apply /andP. rewrite /=.
  rewrite (r1_trans Hxy1).
    + by rewrite (r2_trans Hxy2).
    + by apply Hxz1.
Qed.

(* State and prove that pair_fun is monotonic wrt pair_rel *)
Lemma pair_fun_mon : forall x, pair_rel x (pair_fun x).
Proof.
  case => x1 x2.
  rewrite /pair_rel /=. apply /andP.
  by rewrite f1_mon f2_mon.
Qed.

End pairs.

Section instances.
(* Write a canonical declaration which builds a new instance of rel_s *)
(* from two existing ones using the lemmas prouved in section Pairs. *)

Definition test_fun := pair_fun S S.
Definition test_comp := pair_rel leq leq.

(* An instance of rel_s which satisfies the Rel_s definition for pairs *)
Canonical rel_s_pair (s1 s2: rel_s) :=
  Rel_s (pair_rel_trans (@cmp_trans s1) (@cmp_trans s2))
  (pair_fun_mon (@cmp_f s1) (@cmp_f s2)).

(* Find the shortest possible proof for this test lemma *)
Lemma test_rels_pair : forall u : nat * nat, test_comp u (test_fun u).
Proof.
  apply cmp_f.
Qed.

(* Now instanciate rel_s for divisibility and doubling on nat and test *)
(* your approach *)

Lemma doubling_mon_dvdn : forall x, dvdn x (x.*2).
Proof.
  move => x.
  apply /dvdnP.
  by exists 2; rewrite mulnC muln2.
Qed.

Canonical rel_s_div : rel_s := Rel_s dvdn_trans doubling_mon_dvdn.

(* Test the benchmark to see if our approach was correct *)
Lemma dvdn_times_8 : forall x, dvdn x (x.*2.*2.*2).
Proof.
  move => x. apply f3.
Qed.

End instances.


Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Hints.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.ZUtil.Lnot.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Hints.Ztestbit.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.ZUtil.Log2.
Require Import Crypto.Util.ZUtil.Pow.
Require Import Crypto.Util.Bool.LeCompat.
Local Open Scope Z_scope.

Module Z.
  Lemma ones_spec : forall n m, 0 <= n -> 0 <= m -> Z.testbit (Z.ones n) m = if Z_lt_dec m n then true else false.
  Proof using Type.
    intros.
    break_match.
    + apply Z.ones_spec_low. lia.
    + apply Z.ones_spec_high. lia.
  Qed.
#[global]
  Hint Rewrite ones_spec using zutil_arith : Ztestbit.

  Lemma ones_spec' n m (Hn : 0 <= n) (Hm : 0 <= m) :
    Z.testbit (Z.ones n) m = if (m <? n) then true else false.
  Proof using Type. rewrite ones_spec by assumption.
         destruct (Z_lt_dec m n) as [lt|lt];
           [apply Z.ltb_lt in lt|apply Z.ltb_nlt in lt];
           rewrite lt; reflexivity. Qed.

  Lemma ones_spec_full : forall n m, Z.testbit (Z.ones n) m
                                     = if Z_lt_dec m 0
                                       then false
                                       else if Z_lt_dec n 0
                                            then true
                                            else if Z_lt_dec m n then true else false.
  Proof using Type.
    intros n m.
    repeat (break_match || autorewrite with Ztestbit); try reflexivity; try lia.
    unfold Z.ones.
    rewrite <- Z.shiftr_opp_r, Z.shiftr_eq_0 by (simpl; lia); simpl.
    destruct m; simpl in *; try reflexivity.
    exfalso; auto using Zlt_neg_0.
  Qed.
#[global]
  Hint Rewrite ones_spec_full : Ztestbit_full.

  Lemma testbit_pow2_mod : forall a n i, 0 <= n ->
  Z.testbit (Z.pow2_mod a n) i = if Z_lt_dec i n then Z.testbit a i else false.
  Proof using Type.
    cbv [Z.pow2_mod]; intros a n i H; destruct (Z_le_dec 0 i);
      repeat match goal with
          | |- _ => rewrite Z.testbit_neg_r by lia
          | |- _ => break_innermost_match_step
          | |- _ => lia
          | |- _ => reflexivity
          | |- _ => progress autorewrite with Ztestbit
          end.
  Qed.
#[global]
  Hint Rewrite testbit_pow2_mod using zutil_arith : Ztestbit.

  Lemma testbit_pow2_mod_full : forall a n i,
      Z.testbit (Z.pow2_mod a n) i = if Z_lt_dec n 0
                                     then if Z_lt_dec i 0 then false else Z.testbit a i
                                     else if Z_lt_dec i n then Z.testbit a i else false.
  Proof using Type.
    intros a n i; destruct (Z_lt_dec n 0); [ | apply testbit_pow2_mod; lia ].
    unfold Z.pow2_mod.
    autorewrite with Ztestbit_full;
      repeat break_match;
      autorewrite with Ztestbit;
      reflexivity.
  Qed.
#[global]
  Hint Rewrite testbit_pow2_mod_full : Ztestbit_full.

  Lemma bits_above_pow2 a n : 0 <= a < 2^n -> Z.testbit a n = false.
  Proof using Type.
    intros.
    destruct (Z_zerop a); subst; autorewrite with Ztestbit; trivial.
    apply Z.bits_above_log2; auto with zarith concl_log2.
  Qed.
#[global]
  Hint Rewrite bits_above_pow2 using zutil_arith : Ztestbit.

  Lemma testbit_low : forall n x i, (0 <= i < n) ->
    Z.testbit x i = Z.testbit (Z.land x (Z.ones n)) i.
  Proof using Type.
    intros.
    rewrite Z.land_ones by lia.
    symmetry.
    apply Z.mod_pow2_bits_low.
    lia.
  Qed.

  Lemma testbit_add_shiftl_low : forall i, (0 <= i) -> forall a b n, (i < n) ->
    Z.testbit (a + Z.shiftl b n) i = Z.testbit a i.
  Proof using Type.
    intros i H a b n H0.
    erewrite Z.testbit_low; eauto.
    rewrite Z.land_ones, Z.shiftl_mul_pow2 by lia.
    rewrite Z.mod_add by (pose proof (Z.pow_pos_nonneg 2 n); lia).
    auto using Z.mod_pow2_bits_low.
  Qed.
#[global]
  Hint Rewrite testbit_add_shiftl_low using zutil_arith : Ztestbit.

  Lemma testbit_sub_pow2 n i x (i_range:0 <= i < n) (x_range:0 < x < 2 ^ n) :
    Z.testbit (2 ^ n - x) i = negb (Z.testbit (x - 1)  i).
  Proof using Type.
    rewrite <-Z.lnot_spec, Z.lnot_sub1 by lia.
    rewrite <-(Z.mod_pow2_bits_low (-x) _ _ (proj2 i_range)).
    f_equal.
    rewrite Z.mod_opp_l_nz; autorewrite with zsimplify; lia.
  Qed.

  Lemma testbit_false_bound : forall a x, 0 <= x ->
    (forall n, ~ (n < x) -> Z.testbit a n = false) ->
    a < 2 ^ x.
  Proof using Type.
    intros a x H H0.
    assert (H1 : a = Z.pow2_mod a x). {
     apply Z.bits_inj'; intros.
     rewrite Z.testbit_pow2_mod by lia; break_match; auto.
    }
    rewrite H1.
    cbv [Z.pow2_mod]; rewrite Z.land_ones by auto.
    try apply Z.mod_pos_bound; Z.zero_bounds.
  Qed.

  Lemma testbit_neg_eq_if x n :
    0 <= n ->
    - (2 ^ n) <= x  < 2 ^ n ->
    Z.b2z (if x <? 0 then true else Z.testbit x n) = - (x / 2 ^ n) mod 2.
  Proof using Type.
    intros. break_match; Z.ltb_to_lt.
    { autorewrite with zsimplify. reflexivity. }
    { autorewrite with zsimplify.
      rewrite Z.bits_above_pow2 by lia.
      reflexivity. }
  Qed.

  Lemma shiftl_spec_full a n m : Z.testbit (a << n) m = if (0 <=? m) then Z.testbit a (m - n) else false.
  Proof using Type.
    break_innermost_match; Z.ltb_to_lt; now autorewrite with Ztestbit.
  Qed.
#[global]
  Hint Rewrite shiftl_spec_full : Ztestbit_full.

  Lemma shiftr_spec_full a n m : Z.testbit (a >> n) m = if (0 <=? m) then Z.testbit a (m + n) else false.
  Proof using Type.
    break_innermost_match; Z.ltb_to_lt; now autorewrite with Ztestbit.
  Qed.
#[global]
  Hint Rewrite shiftr_spec_full : Ztestbit_full.

  Lemma mod_pow2_ones a m :
    a mod 2 ^ m = if (Z_lt_dec m 0) then ltac:(match eval hnf in (1 mod 0) with | 0 => exact 0 | _ => exact a end) else a &' Z.ones m.
  Proof using Type. destruct (Z_lt_dec m 0). rewrite Z.pow_neg_r, Zmod_0_r; lia.
         symmetry; apply Z.land_ones; lia. Qed.

  Lemma bits_1 m :
    Z.testbit 1 m = if Z.eq_dec m 0 then true else false.
  Proof using Type.
    destruct (Z.eq_dec m 0); subst. reflexivity.
    destruct (Z_lt_dec m 0). rewrite Z.testbit_neg_r by lia. reflexivity.
    rewrite Z.bits_above_log2; simpl; try reflexivity; lia. Qed.

  Lemma bits_opp_full a i :
    Z.testbit (- a) i = if (Z_lt_dec i 0) then false else negb (Z.testbit (Z.pred a) i).
  Proof using Type.
    destruct (Z_lt_dec i 0). rewrite Z.testbit_neg_r by lia. reflexivity.
    apply Z.bits_opp; lia. Qed.

  Lemma pow2_bits_full m i :
    Z.testbit (2 ^ m) i =
    if (Z_lt_dec m 0) then false else if (Z.eq_dec i m) then true else false.
  Proof using Type.
    destruct (Z_lt_dec m 0); [now rewrite Z.pow_neg_r, Z.bits_0|].
    destruct (Z.eq_dec i m); subst.
    - apply Z.pow2_bits_true; lia.
    - apply Z.pow2_bits_false; lia. Qed.

  Definition bit_compare (b1 b2 : bool) : comparison
    := match b1, b2 with
       | true, true => Eq
       | true, false => Lt
       | false, false => Eq
       | false, true => Gt
       end.

  Lemma bit_compare_refl (b  : bool) : bit_compare b b = Eq.
  Proof using Type. now destruct b. Qed.
#[global]
  Hint Rewrite bit_compare_refl : Ztestbit.

  Lemma bit_compare_eq_iff (b1 b2 : bool)
    : bit_compare b1 b2 = Eq <-> b1 = b2.
  Proof using Type. now destruct b1, b2. Qed.

  Lemma bit_compare_gt_iff (b1 b2 : bool)
    : bit_compare b1 b2 = Gt <-> (b1 = false /\ b2 = true).
  Proof using Type. now destruct b1, b2. Qed.

  Lemma bit_compare_lt_iff (b1 b2 : bool)
    : bit_compare b1 b2 = Lt <-> (b1 = true /\ b2 = false).
  Proof using Type. now destruct b1, b2. Qed.

  Lemma bits_const_iff z b
    : (forall n, 0 <= n -> Z.testbit z n = b)
      <-> z = if b then -1 else 0.
  Proof using Type.
    destruct b; [ rewrite <- (Z.bits_inj_iff z (-(1))) | rewrite <- (Z.bits_inj_iff z 0) ];
      cbv [Z.eqf];
      split; intros H n; specialize (H n); intros; destruct (Z_le_gt_dec 0 n);
        try specialize (H ltac:(assumption)); try lia;
        revert H;
        rewrite ?Z.bits_0, ?Z.bits_m1, ?Z.testbit_neg_r by lia; trivial.
  Qed.

  Lemma compare_by_bits_impl z1 z2 c
    : (forall n, 0 <= n -> bit_compare (Z.testbit z1 n) (Z.testbit z2 n) = c)
      -> Z.compare z1 z2 = c.
  Proof using Type.
    destruct (Z.compare_spec z1 z2), c; subst.
    all: repeat first [ progress setoid_rewrite bit_compare_refl
                      | progress setoid_rewrite bit_compare_eq_iff
                      | progress setoid_rewrite bit_compare_gt_iff
                      | progress setoid_rewrite bit_compare_lt_iff
                      | reflexivity
                      | assumption
                      | congruence
                      | lia
                      | progress subst
                      | progress intros
                      | progress split_and
                      | match goal with
                        | [ H : forall n, 0 <= n -> ?T |- _ ] => assert T by (eapply H; reflexivity); clear H
                        | [ H : forall n, 0 <= n -> Z.testbit _ _ = Z.testbit _ _ |- _ ]
                          => apply Z.bits_inj' in H
                        | [ H : forall n, 0 <= n -> Z.testbit _ n = ?b |- _ ]
                          => apply bits_const_iff in H
                        end ].
  Qed.

  Lemma testbit_small_neg a b
        (Ha : - 2^b <= a < 0)
        (Hb : 0 < b) :
    Z.testbit a b = true.
  Proof using Type.
    destruct Ha; apply Z_le_lt_eq_dec in H; destruct H.
    - apply Z.bits_iff_neg with (n:=b) in H0; [assumption|].
      apply Log2.Z.log2_lt_pow2_alt; try lia.
    - subst; replace (- 2 ^ b) with ((-1) * 2 ^ b) by ring.
      rewrite Z.mul_pow2_bits, Z.sub_diag, Z.bit0_odd by lia; reflexivity. Qed.

  Lemma testbit_large a b
        (Ha : 2 ^ (b - 1) <= a < 2 ^ b)
        (Hb : 0 < b) :
    Z.testbit a (b - 1) = true.
  Proof using Type.
    destruct (Z.testbit a (b - 1)) eqn:E; try reflexivity.
    rewrite Z.testbit_false in * by lia.
    apply Z.div_exact in E; [|lia].
    rewrite Div.Z.div_between_1 in E; auto with zarith.
    rewrite Pow.Z.pow_mul_base, Z.sub_simpl_r; lia. Qed.

   Lemma testbit_b2z a m :
     Z.testbit a m = negb (Z.b2z (Z.testbit a m) =? 0).
   Proof using Type. destruct (Z.testbit a m); reflexivity. Qed.

   Lemma pos_le_bitwise a b (H : forall i, Bool.le (Pos.testbit a i) (Pos.testbit b i))
     : Pos.le a b.
   Proof using Type.
     revert dependent a; induction b as [b IHb|b IHb|], a as [a|a|]; intros; try lia;
       try solve [ change (a <= b)%positive;
                   apply IHb;
                   intro i; specialize (H (N.succ i)); destruct i; cbn in H; rewrite ?Pos.pred_N_succ in H; try assumption ].
     all: first [ cbv [Pos.le]; cbn; rewrite Pos.compare_cont_Lt_not_Gt
                | cbv [Pos.le]; cbn; rewrite Pos.compare_cont_Gt_not_Gt
                | idtac ].
     all: try solve [ apply IHb;
                      intro i; specialize (H (N.succ i)); destruct i; cbn in H; rewrite ?Pos.pred_N_succ in H; try assumption
                    | specialize (H 0%N); cbn in H; congruence ].
     all: specialize (fun i => H (Npos i)).
     all: lazymatch type of H with
          | forall i, Bool.le (Pos.testbit ?a _) (Pos.testbit ?b _)
            => change (forall i, Bool.le (Z.testbit (Zpos a) (Zpos i)) (Z.testbit (Zpos b) (Zpos i))) in H;
                 specialize (H (Z.to_pos (Z.log2 (Zpos a))))
          end.
     all: rewrite Z2Pos.id in H by (apply Z.log2_pos; lia).
     all: rewrite Z.bit_log2 in H by lia.
     all: rewrite Z.bits_above_log2 in H; try apply Z.log2_pos; try lia.
     all: cbn in H; try congruence.
   Qed.

   Lemma le_bitwise a b (Ha : 0 <= a) (Hb : 0 <= b)  (H : forall i, 0 <= i -> Bool.le (Z.testbit a i) (Z.testbit b i))
     : Z.le a b.
   Proof using Type.
     destruct a as [|a|a], b as [|b|b]; try lia.
     { specialize (H (Z.log2 (Zpos a)) (Z.log2_nonneg (Zpos a))).
       rewrite Z.testbit_0_l, Z.bit_log2 in H by lia.
       cbn in H; congruence. }
     { apply pos_le_bitwise.
       intro i; destruct i.
       { specialize (H 0 ltac:(lia)); cbn in H.
         destruct a, b; cbn in *; try reflexivity; try congruence. }
       { refine (H (Zpos _) _); lia. } }
   Qed.
End Z.


(** 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 (lf1 : natural) (y : natural) (x : natural) : natural :=
  mult x (Succ y).


(*  This showcases a version of Higg's involution theorem.
    The proof outline was taken from
      "On Some non-classical extensions of second-order
       intuitionistic propositional calculus"
    by Andrej Scedrov.
*)
Section Higgs.

Implicit Type p q P : Prop.
Variable f : Prop -> Prop.
Hypothesis f_lc : (forall p q, (f p <-> f q) -> (p <-> q)).
Hypothesis f_eq : (forall p q,  (p <-> q) -> (f p <-> f q)).

Fact L1 P :
  f P -> (f True <-> P).
Proof.
  intros fp. split.
  - intros fT. apply f_lc with True.
    all: tauto.
  - intros p. apply f_eq with P.
    all: tauto.
Qed.

Fact L2 P :
  f (f P) -> P.
Proof.
  intros H%L1. apply (f_lc True P) in H; tauto.
Qed.

Fact L3 P :
  f P -> f (f (f P)).
Proof.
  intros fp.
  apply L1 in fp as H.
  specialize (f_eq (f P) True ltac:(tauto)) as E.
  eapply f_eq with P.
  all: tauto.
Qed.

Theorem Involutive P :
  f (f P) <-> P.
Proof.
  apply f_lc. split.
  - apply L2.
  - apply L3.
Qed.
End Higgs.

Definition PE := forall A B, (A <-> B) -> A = B.

Lemma PE_Involutive (f : Prop -> Prop) :
  PE ->
  (forall p q, (f p <-> f q) -> (p <-> q)) <->
  forall P, f (f P) = P.
Proof.
  intros pe. split.
  - intros f_lc P.
    apply pe, Involutive. try assumption.
    intros A B. now intros ->%pe.
  - intros inv. intros p q H%pe.
    rewrite <-(inv p), <-(inv q).
    now rewrite !H.
Qed.