Require Import Reals.
Require Import Omega.
Require Import Fourier.
Open Scope R_scope.

(** Stuff contributed by Charlie Murphy **)

Definition I (n : nat) : R :=
  if eq_nat_dec (n mod 3) 0 then Rpower 3 ((INR n) / 3)
  else if eq_nat_dec (n mod 3) 1 then 4 * (Rpower 3 (((INR n) - 4)/3))
       else 2 * (Rpower 3 (((INR n) - 2) / 3)).

Lemma mod3_eq_2 : forall (a : nat),
    (a mod 3 <> 0 -> a mod 3 <> 1 -> a mod 3 = 2)%nat.
Proof.
  intros.
  assert (3 <> 0)%nat.
  auto.
  assert (forall (n : nat), n <> n -> False).
  intros;
    apply H2;
    reflexivity.
  assert (H3 := Nat.mod_upper_bound a 3 H1).
  destruct (a mod 3);
    [ apply H2 in H |
      destruct n;
      [ apply H2 in H0|]]; try contradiction.
  destruct n; auto.
  unfold lt in H3.
  repeat apply le_S_n in H3.
  apply le_n_0_eq in H3.
  inversion H3.
Qed.

Theorem I_unfold: forall (n : nat),
    (I n) * 3 = I (n + 3).
Proof.
  intros. assert ((n + 3) mod 3 = n mod 3).
  rewrite <- Nat.add_mod_idemp_r; auto.
  assert (INR 3 = 3). simpl; Rcompute.
  unfold I; rewrite H.
  destruct (eq_nat_dec (n mod 3) 0).
  { unfold Rdiv. rewrite plus_INR. rewrite H0.
    rewrite Rmult_plus_distr_r.
    rewrite Rinv_r; discrR.
    rewrite Rpower_plus.
    rewrite Rpower_1; prove_sup; auto.
  } destruct (eq_nat_dec (n mod 3) 1).
  { unfold Rdiv. rewrite plus_INR. rewrite H0.
    unfold Rminus. rewrite (Rplus_assoc _ 3).
    rewrite (Rplus_comm 3). rewrite <- (Rplus_assoc _ _ 3).
    rewrite (Rmult_plus_distr_r _ 3 (/3)).
    rewrite Rinv_r; discrR.
    rewrite Rpower_plus.
    rewrite Rpower_1; prove_sup. ring.
  } assert (H1 := Nat.mod_le n 3).
  rewrite (mod3_eq_2 _ n0 n1) in H1.
  rewrite plus_comm. replace (INR (3 + n)) with (3 + (INR n)).
  replace ((3 + INR n - 2) / 3) with ((3/3)+(INR n -2)/3).
  replace (Rpower 3 (3 / 3 + (INR n - 2) / 3)) with ((Rpower 3 (3/3))*(Rpower 3 ((INR n - 2) / 3) )).
  replace (3/3) with (1).
  rewrite Rpower_1.
  field.
  fourier.
  field.
  symmetry.
  apply Rpower_plus.
  field.
  replace (3) with (INR 3) at 1.
  symmetry.
  apply plus_INR.
Qed.

Require Import Wellfounded.
Theorem strong_induction : forall (P : nat -> Prop),
    (P 0 ->
     (forall n, (forall m, m <= n -> P m) -> P (S n)) ->
     forall n, P n)%nat.
Proof.
  intros.
  induction n using (well_founded_induction lt_wf).
  destruct n; auto.
  apply H0.
  intros.
  assert (m < S n)%nat.
  omega.
  apply H1 in H3; auto.
Qed.

Theorem I_n_q : forall (n : nat),
    I n <= Rpower 3 ((INR n)/3).
Proof.
  intros n. induction n using strong_induction.
  { unfold I; simpl. apply Rle_refl.
  } assert (S n = 1 \/ S n = 2 \/ exists m, S n = m + 3)%nat.
  destruct n. auto. destruct n. auto. right. right. exists n. omega.
  destruct H0.
  { inversion H0; subst. unfold I. simpl. unfold Rdiv.
    assert ((1 - 4) * / 3 = -1). field. rewrite H1.
    rewrite Rmult_1_l.
    assert ((IZR (Zneg xH)) = (Ropp (IZR (Zpos xH)))).
    {
      auto.
    }
    rewrite H2.
    rewrite Rpower_Ropp.
    clear H2.
    rewrite Rpower_1; prove_sup.
    assert (4 * / 3 = Rpower (64*/27) (/3)).
    assert (64 */27 = Rpower (4*/3) (INR 3)).
    rewrite Rpower_pow; try fourier; field.
    rewrite H2. rewrite Rpower_mult. simpl.
    field_simplify.
    replace (1 + 1 + 1) with 3; [|ring].
    replace (3 * / 3) with 1; [|field].
    rewrite Rpower_1; [auto | fourier].
    rewrite H2. apply Rle_Rpower_l; [|split]; fourier.
  } destruct H0.
  { inversion H0; subst. unfold I; simpl.
    unfold Rdiv. replace (1+1-2) with 0 by field.
    rewrite Rmult_0_l.
    rewrite Rpower_O; prove_sup. rewrite Rmult_1_r.
    rewrite <- Rpower_mult. assert (Rpower 3 (INR 2) = 9).
    rewrite Rpower_pow; prove_sup. field.
    simpl in H1; rewrite H1. assert (2 = Rpower 8 (/3)).
    assert (8 = Rpower 2 (INR 3)).
    rewrite Rpower_pow; prove_sup; field. rewrite H2.
    rewrite Rpower_mult. simpl.
    field_simplify.
    replace (2/1) with 2 by field.
    replace (1 +1 + 1) with 3; [|ring].
    replace (3 * / 3) with 1; [|field].
    rewrite Rpower_1; [auto | fourier].
    rewrite H2 at 1. apply Rle_Rpower_l; [|split]; fourier.
  } destruct H0 as [m H0]. assert (m <= n)%nat. omega.
  apply H in H1. rewrite H0. rewrite <- I_unfold.
  unfold Rdiv. rewrite plus_INR. rewrite Rmult_plus_distr_r.
  rewrite Rpower_plus. simpl.
  replace (1 + 1 + 1) with 3; [|ring].
  replace (3 * / 3) with 1; [|field].
  rewrite Rpower_1; [auto | fourier].
  apply Rmult_le_compat_r; auto; fourier.
Qed.

Open Scope R_scope.

Lemma n_q' : forall (n : nat),
    (3 <= n)%nat -> 1 <= (Rpower 3 ((INR (S n))/3)) - (Rpower 3 ((INR n)/3)).
Proof.
  intros. assert (3 = INR 3). simpl; Rcompute. induction H.
  { unfold Rdiv. rewrite <- H0. rewrite Rinv_r; discrR.
    rewrite Rpower_1; prove_sup. unfold Rminus.
    apply (Rplus_le_reg_r 3 _ _). rewrite Rplus_assoc.
    rewrite Rplus_opp_l. rewrite Rplus_0_r.
    assert (1+3 = 4). Rcompute. rewrite H.
    rewrite <- Rpower_mult. rewrite Rpower_pow; prove_sup.
    assert (3^4 = 81)%R. simpl. Rcompute.
    rewrite H1. assert (4 = Rpower 64 (/3)).
    assert (64 = Rpower 4 3). rewrite H0.
    rewrite Rpower_pow; prove_sup; ring.
    rewrite H2. rewrite Rpower_mult.
    rewrite Rinv_r; discrR.
    rewrite Rpower_1; prove_sup; auto.
    rewrite H2 at 1. apply Rle_Rpower_l;
                       [left; apply Rinv_0_lt_compat | split; [|left]]; prove_sup.
  } rewrite S_INR. rewrite S_INR at 2. unfold Rdiv.
  repeat rewrite Rmult_plus_distr_r. rewrite Rmult_1_l.
  repeat rewrite Rpower_plus. unfold Rminus.
  rewrite Ropp_mult_distr_l. rewrite <- Rmult_plus_distr_r.
  assert (1 <= (Rpower 3 (/3))). assert (1 = Rpower 1 (/3)).
  assert (1 = (Rpower 1 3)). rewrite H0.
  rewrite Rpower_pow; prove_sup; simpl; Rcompute.
  rewrite H1 at 2. rewrite Rpower_mult.
  rewrite Rinv_r; discrR.
  rewrite Rpower_1; prove_sup; auto.
  rewrite H1 at 1. apply Rle_Rpower_l;
                     [left; apply Rinv_0_lt_compat | split; [|left]]; prove_sup.
  rewrite <- Rmult_1_r at 1.
  apply Rmult_le_compat; try (left; prove_sup; fail); assumption. Qed.

Theorem n_q : forall (n : nat),
    INR n <= Rpower 3 ((INR n)/3).
Proof.
  assert (3 = INR 3). simpl; Rcompute. destruct n.
  { simpl. unfold Rdiv. rewrite Rmult_0_l.
    rewrite Rpower_O; prove_sup; apply Rle_0_1.
  } destruct n. {
    simpl. unfold Rdiv. rewrite Rmult_1_l.
    assert (1 = Rpower 1 (/3)).
    assert (1 = (Rpower 1 3)). rewrite H.
    rewrite Rpower_pow; prove_sup; simpl; Rcompute.
    rewrite H0 at 2. rewrite Rpower_mult.
    rewrite Rinv_r; discrR.
    rewrite Rpower_1; prove_sup; auto.
    rewrite H0 at 1. apply Rle_Rpower_l;
                       [left; apply Rinv_0_lt_compat | split; [|left]]; prove_sup.
  } destruct n. {
    unfold Rdiv. rewrite <- Rpower_mult.
    rewrite Rpower_pow; prove_sup.
    assert (3^2 = 9)%R. simpl; Rcompute. rewrite H0. simpl.
    assert (2 = Rpower 8 (/3)). assert (8 = Rpower 2 3).
    rewrite H. rewrite Rpower_pow; prove_sup; simpl; Rcompute.
    rewrite H1. rewrite Rpower_mult. rewrite Rinv_r; discrR.
    rewrite Rpower_1; prove_sup; auto.
    rewrite H1 at 1; apply Rle_Rpower_l;
      [left; apply Rinv_0_lt_compat | split; [|left]]; prove_sup.
  } induction n. {
    rewrite <- H. unfold Rdiv. rewrite Rinv_r; discrR.
    rewrite Rpower_1; prove_sup; apply Rle_refl.
  } remember (S (S (S n))) as m.
  rewrite S_INR at 1. rewrite Rplus_comm.
  apply Rle_minus in IHn.
  apply (Rplus_le_reg_r (Ropp (Rpower 3 ((INR m)/3))) _ _).
  rewrite Rplus_assoc. fold (Rminus (INR m) (Rpower 3 ((INR m)/3))).
  fold (Rminus (Rpower 3 ((INR (S m))/3)) (Rpower 3 ((INR m)/3))).
  apply (Rle_trans _ 1 _). rewrite <- Rplus_0_r.
  apply Rplus_le_compat; auto; apply Rle_refl.
  apply n_q'. rewrite Heqm. repeat apply le_n_S. apply Nat.le_0_l.
Qed.

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

Require Import MIS_basics.
Require Import graph_basics.
Require Import Coq.Program.Equality.

Lemma lGraph_vert_ind :
  forall P : lGraph -> Prop,
    P nil_lGraph ->
    (forall n, (forall G, lV G = n -> P G) ->
               forall G', lV G' = S n -> P G') ->
    forall G, P G.
Proof.
  intros.
  destruct G.
  dependent induction lV.
  + rewrite <- fix_LiftGraph. simpl lV.
    rewrite least_LiftGraph. auto.
  + apply (H0 lV). intros.
    destruct G. simpl in H1. subst. apply IHlV. auto.
Qed.
Open Scope nat_scope.
Lemma lGraph_vert_str_ind :
  forall P : lGraph -> Prop,
    P nil_lGraph ->
    (forall n, (forall G, lV G < n -> P G) ->
               forall G', lV G' = n -> P G') ->
    forall G, P G.
Proof.
  intros.
  destruct G.
  dependent induction lV using (well_founded_ind lt_wf).
  apply (H0 lV); try auto.
  intros.
  destruct G. apply H1. apply H2.
Qed.
Import graphs_nondep.
Require Import List.
Open Scope R_scope.

Lemma helper_1 : forall n : nat,
    4 * Rpower 3 (((INR n)-4) / 3) <= (I n).
Proof.
  induction n using strong_induction.
  {
    simpl.
    unfold I.
    simpl.
    assert ((0-4) / 3 = (-(4/3))) by field.
    rewrite H.
    assert (64 */27 = Rpower (4*/3) (INR 3)).
    rewrite Rpower_pow; try fourier; field.
    assert (4 / 3 = Rpower (64*/27) (/3)).
    {
      rewrite H0. rewrite Rpower_mult. simpl.
      replace (1 + 1 + 1) with 3; [|ring].
      replace (3 * / 3) with 1; [|field].
      rewrite Rpower_1; [ auto  | fourier ].
    }
    assert (H2 : Rpower (64 * / 27) (/ 3) <= Rpower 3 (/ 3))
      by (apply Rle_Rpower_l; [|split]; fourier).
    rewrite H1.
    replace (0/3) with (0) by field.
    rewrite Rpower_O; [ prove_sup| ].
    rewrite Rpower_Ropp.
    field_simplify.
    {
      replace (1/1) with (1) by field.
      rewrite <- H1.
      pose proof (I_n_q 4).
      replace (INR 4) with 4 in H3; [|simpl; ring].
      unfold I in H3.
      simpl in H3.
      replace ((1 + 1 + 1 + 1 - 4) / 3) with 0 in H3 by field.
      rewrite Rpower_O in H3; try fourier.
      ring_simplify in H3.
      generalize dependent (Rpower 3 (4 / 3)).
      intros.
      unfold Rdiv.
      apply Rmult_le_reg_r with (r := r); [
        try fourier|].
      ring_simplify.
      field_simplify;
        [fourier | intros Hnot; fourier].
    }
    {
      rewrite <- H1.
      clear.
      pose proof (I_n_q 4).
      unfold I in H; simpl in H.
      intros Hnot.
      replace ((1 + 1 + 1 + 1 - 4) / 3) with 0 in H by field.
      replace ((1 + 1 + 1 + 1)) with (4) in H by (simpl; ring).
      rewrite Rpower_O in H; ring_simplify in H; try fourier.
    }
    fourier.
  }
  (* Inductive Step *)
  {
    assert (H0 : (S n = 1 \/ S n = 2 \/ exists m, S n = ( m + 3) )%nat).
    {
      do 2 (destruct n;
            auto); do 2 right;
        exists n; omega.
    }
    destruct H0.
    { inversion H0; subst. unfold I. simpl. unfold Rdiv.
      assert ((1 - 4) * / 3 = -1). field. rewrite H1.
      assert ((IZR (Zneg xH)) = (Ropp (IZR (Zpos xH)))).
      {
        auto.
      }
      rewrite H2.
      rewrite Rpower_Ropp.
      (* clear H2.
      rewrite Rpower_1; prove_sup.*)
      apply Rle_refl.
    }
    destruct H0.
    {
    rewrite H0.
      unfold I; simpl.
      unfold Rdiv.
      replace (1+1-2) with 0 by ring.
      rewrite Rmult_0_l.
      rewrite Rpower_O; prove_sup. rewrite Rmult_1_r.
      rewrite <- Rpower_mult.
      assert (Rpower 3 (INR 2) = 9).
      {
        rewrite Rpower_pow; prove_sup. field.
      }
      replace (1 + 1 - 4) with (-(2)) by (simpl; field).
      replace (-(2) * / 3) with (- ( 2 * / 3)) by (simpl; field).
      rewrite Rpower_Ropp.
      replace (INR 2) with 2 in H1 by (simpl; field).
      replace (2) with (4 * (/2)) by (simpl; field).
      apply Rmult_le_compat_l; prove_sup.
      fourier.
      rewrite <- Rpower_Ropp.
      rewrite Rpower_mult.
      replace (- (4 * / 2) * / 3) with (- ((4 * / 2) * / 3)) by
          (simpl; field).
      rewrite Rpower_Ropp.
      replace (4 * /2) with 2 by
          (simpl; field).
      apply Rinv_le_contravar.
      fourier.
      pose proof (n_q 2).
      replace (INR 2) with 2 in H2 by
          (simpl; field).
      auto.
    }
    {
      destruct H0 as [m H0]. assert (m <= n)%nat. omega.
      apply H in H1. rewrite H0. rewrite <- I_unfold.
      rewrite plus_INR.
      ring_simplify.
      replace (INR m + INR 3 - 4) with (INR m - 4 +  INR 3)
        by (simpl; ring).
      rewrite Rdiv_plus_distr.
      replace (INR 3) with 3 by (simpl; ring).
      rewrite Rpower_plus.
      replace (3 /3) with 1 by field.
      simpl. rewrite Rpower_1; try fourier.
      ring_simplify.
      replace 12 with (3 * 4) by ring.
      fourier.
    }
  }
Qed.

(* Dr Juedes Contribution *)
Theorem exp_vs_3: forall x:R, 0<x -> exp x <= Rpower 3 x.
Proof.
intros.
unfold Rpower.
assert (1<=ln 3).
assert (ln (exp 1) = 1).
apply ln_exp.
rewrite <-H0 at 1.
unfold Rle.
assert (exp 1 <= 3).
apply exp_le_3.
unfold Rle in H1.
destruct H1.
left.
apply ln_increasing.
assert (1+1 < exp 1).
apply exp_ineq1.
fourier.
assert (0<2).
fourier.
apply (Rlt_trans 0 2 (exp 1)).
exact H3.
exact H2.
exact H1.
right.
apply exp_inv.
assert ((exp (ln 3)) = 3).
apply exp_ln.
fourier.
rewrite H0.
rewrite H2.
exact H1.
unfold Rle.
unfold Rle in H0.
destruct H0.
left.
assert (x< x*ln 3).
assert (x*1 = x).
assert (x*1 = 1*x).
apply Rmult_comm.
rewrite H1.
apply Rmult_1_l.
rewrite <-H1 at 1.
apply Rmult_lt_compat_l.
exact H.
exact H0.
apply exp_increasing.
exact H1.
right.
assert (x*ln 3 = x).
rewrite <-H0.
ring.
rewrite H1.
reflexivity.
Qed.

Theorem three_x_1: forall x:R, 0<x -> 1+x < Rpower 3 x.
Proof.
intros.
assert ((exp x) <= (Rpower 3 x)).
apply exp_vs_3.
exact H.
assert (1+x < exp x).
apply exp_ineq1.
exact H.
destruct H0.
apply (Rlt_trans (1+x) (exp x) (Rpower 3 x)).
exact H1.
exact H0.
rewrite <-H0.
exact H1.
Qed.

Theorem ln_one_pos: forall x:R, 1<x -> 0 < ln x.
Proof.
assert (ln 1 = 0).
apply ln_1.
intros.
rewrite <-H.
apply ln_increasing.
fourier.
exact H0.
Qed.

Theorem pos_pow: forall a b :R, 1<=a -> 0< b -> 0< (Rpower a b).
Proof.
intros.
unfold Rpower.
assert (0 <= ln a).
unfold Rle in H.
destruct H.
unfold Rle.
left.
apply ln_one_pos.
exact H.
unfold Rle.
right.
assert (ln a = 0).
rewrite <-H.
apply ln_1.
rewrite H1.
reflexivity.
unfold Rle in H1.
destruct H1.
assert (0<b* ln a).
apply Rmult_lt_0_compat; auto.
assert (0 < 1 + (b*ln a)).
assert (0 < 1).
fourier.
apply Rplus_lt_0_compat; auto.
assert (1+(b*ln a) < exp (b*ln a)).
apply exp_ineq1.
exact H2.
apply (Rlt_trans 0 (1+ b*ln a) (exp (b * ln a))).
exact H3.
exact H4.
rewrite <-H1.
assert (b*0 = 0).
apply Rmult_0_r.
rewrite H2.
rewrite exp_0.
fourier.
Qed.

Theorem simple2: forall n:nat, forall x y:R, 0<y-> y=x -> y^n =x^n.
Proof.
induction n.
intros.
simpl; auto.
intros.
simpl.
rewrite H0.
reflexivity.
Qed.

Theorem simple1: forall n:nat, forall x y:R, 0<y-> y<=x -> y^n <=x^n.
Proof.
induction n.

intros.
assert (0<x).
fourier.
simpl.
fourier.
intros.
assert (0<x).
fourier.
assert (y^(S n) = y*y^n).
simpl.
reflexivity.
assert (x^(S n) = x*x^n).
simpl.
reflexivity.
assert (y^n <=x^n).
apply IHn.
exact H.
exact H0.
assert (y*y^n <= x*y^n).
rewrite Rmult_comm.
(* rewrite Rmult_comm at 2. *)
assert (x*y^n = y^n*x).
rewrite Rmult_comm.
reflexivity.
rewrite H5.
SearchAbout Rle.
Print Rfourier_le.
assert (0<y^n).
generalize n.
induction n0.
simpl.
fourier.
simpl.
apply Rmult_lt_0_compat; auto.
apply (Rfourier_le y x (y^n));auto.
simpl.
assert (x*y^n <= x*x^n).
apply (Rfourier_le (y^n) (x^n) x);auto.
fourier.
Qed.

Theorem Real_roots: forall n:nat, forall x y:R, 0<x-> 0<y-> y^n<x^n -> y<x.
Proof.
intros.
(* Proof by contradiction. *)
assert ( x<y \/ x=y \/ x>y).
apply Rtotal_order.
destruct H2.
assert (x^n <= y^n).
assert (x<=y).
unfold Rle.
left.
exact H2.

apply simple1.
exact H.
exact H3.
fourier.
destruct H2.
assert (y^n=x^n).
apply simple2.
exact H0.
rewrite H2.
auto.
fourier.
exact H2.
Qed.

Theorem two_le_3_two_over_threea: 2< (Rpower 3 (2/3)).
Proof.
assert (2^3%nat < (Rpower 3 (2/3))^3%nat).
assert ((Rpower (Rpower 3 (2/3)) (INR 3))=(Rpower 3 (2/3))^3%nat).
apply Rpower_pow.
apply pos_pow.
fourier.
fourier.
assert ((Rpower (Rpower 3 (2/3) ) (INR 3)) = (Rpower 3 2)).
assert ((Rpower 3 2) = (Rpower 3 ((2/3)*(INR 3)))).
assert (2/3*(INR 3) = 2).
assert (2/3*(INR 3) = (2*(/3*(INR 3)))).
unfold Rdiv.
assert ((INR 3) = 3).
unfold INR.
ring.
rewrite H0.

apply Rmult_assoc.
assert ((/3*3)=1).
apply Rinv_l.
apply Rgt_not_eq.
fourier.
assert ((INR 3)=3).
unfold INR.
ring.
rewrite H0.
rewrite H2.
rewrite H1.
ring.
rewrite H0.
reflexivity.
assert ((Rpower (Rpower 3 (2/3) ) (INR 3)) = (Rpower 3 ((2/3)*(INR 3)))).
rewrite (Rpower_mult 3 (2/3) (INR 3)).
reflexivity.
rewrite H1.
rewrite H0.
reflexivity.
rewrite <-H.
rewrite H0.
assert (INR 2 = 2).
unfold INR.
reflexivity.
assert ((Rpower 3 (INR 2)) = 3^2).
apply Rpower_pow.
fourier.
replace (INR 2) with 2 in H2 by (simpl; ring).
rewrite H2.
unfold pow.
fourier.
apply Real_roots in H; try fourier.
apply pos_pow.
fourier.
fourier.
Qed.

Theorem n_vs_3n: forall n:nat, INR n <= (Rpower 3 ((INR n)/3)).
Proof.
intros.
assert ((n=0)\/ (n=1) \/ (n=2) \/ (n=3) \/ (4<=n))%nat.
omega. (* I love omega! *)
destruct H.
rewrite H.
simpl.
assert (0/3 = 0).
field.
rewrite H0.
assert ((Rpower 3 0) = 1).
apply Rpower_O.
fourier.
rewrite H1.
fourier. (* Case 0 is done *)
destruct H.
rewrite H.
assert (INR 1<= (1+1/3)).
simpl.
fourier.
assert ((1+1/3) <= (Rpower 3 ((INR 1)/3))).
left.
apply three_x_1.
simpl.
fourier.
apply (Rle_trans (INR 1) (1+(1/3)) (Rpower 3 (INR 1 / 3)));auto.
destruct H.
rewrite H.
assert (INR 2 = 2).
simpl;auto.
rewrite H0.
left.
apply two_le_3_two_over_threea.
destruct H.
rewrite H.
assert (INR 3 / 3 = 1).
simpl.
field.
rewrite H0.
assert (Rpower 3 1 = 3).
apply Rpower_1.
fourier.
rewrite H1.
simpl.
fourier.
apply n_q.
Qed.

Theorem Nate_Help: forall n:nat, INR(4+n)/4 <= Rpower 3 ((INR n)/3).
Proof.
induction n.
{
  simpl.
  assert (0/3 = 0).
  { field. }
  rewrite H.
  assert (Rpower 3 0 = 1).
  {
    apply Rpower_O.
    fourier.
  }
  rewrite H0.
  fourier.
}
{
  assert (4+ (S n)%nat = 1+(4+n))%nat.
  simpl.
  omega.
  rewrite H.
  assert (INR(1+(4+n)) = INR(1)+INR(4+n)).
  SearchAbout INR.
  apply plus_INR.
  rewrite H0.
  assert (INR (S n) = INR(n) + INR(1)).
  rewrite S_INR.
  assert(INR 1 = 1).
  unfold INR.
  reflexivity.
  rewrite H1.
  reflexivity.
  rewrite H1.
  assert ((INR n + INR 1)/3 = INR n/3 + INR 1 /3).
  field.
  rewrite H2.
  assert ((INR 1 + (INR (4+n)))/4 = INR 1/4 + INR(4+n)/4).
  field.
  rewrite H3.
  assert ((Rpower 3 ((INR n)/3 + (INR 1)/3)) = (Rpower 3 ((INR n)/3) ) * (Rpower 3 ((INR 1)/3))).
  apply Rpower_plus.
  rewrite H4.
  assert (1+(1/3) < Rpower 3 (1/3)).

  apply three_x_1 with (x:=1/3).
  fourier.
  assert ((INR 1) = 1).
  unfold INR.
  reflexivity.
  rewrite H6.
  assert (1/4 + (INR (4+n))/4 <= (INR (4+n))/4 * (1+(1/3))).
  assert ((INR (4+n))/4 * (1+(1/3)) = (1+(1/3))*((INR (4+n))/4)).
  field.
  rewrite H7.
  assert ((1+(1/3))*((INR (4+n))/4) = (INR(4+n)/4) + (1/3)*(INR (4+n)/4)).
  field.
  rewrite H8.
  assert (1 <= (INR (4+n) / 4)).
  assert (INR (4+n) = 4 + INR n).
  rewrite plus_INR.
  assert (INR 4 = 4).
  unfold INR.
  field.
  rewrite H9.
  reflexivity.
  rewrite H9.
  assert ((4+ INR n)/4 = 1 + INR n/4).
  field.
  rewrite H10.
  assert (0<=INR n).
  apply pos_INR.
  assert (0 <= INR n / 4).
  {
    clear - H11.
    fourier.
  } (* Note: without clear this won't work!!! *)
  {
    clear - H12.
    fourier.
  }
  {
    assert (1/3 <= (1/3* (INR (4 + n) / 4))).
    {
    clear - H9.
    assert (1/3 = (1/3) * 1).
    {
      field.
    }
    rewrite H at 1.
    apply Rfourier_le.
    exact H9.
    fourier.
  }
  assert (((1 / 4) + INR (4 + n) / 4) = INR (4 + n) / 4 + (1/4)).
  field.
  rewrite H11.
  apply Rplus_le_compat_l with (r:= INR (4 + n) / 4 ) (r1:=1/4) (r2:= (1/3 * (INR (4 + n) / 4))).
  {
    clear - H10.
    fourier.
  }
  }
  assert ((INR (4+n)/4 )* (1+1/3) <= Rpower 3 (INR n / 3) * Rpower 3 (1 / 3)).
  {
    clear - IHn H5.
    assert (1<=(1+ (1/3))).
    fourier.
    assert (INR (4 + n) / 4 * (1 + 1 / 3) <= Rpower 3 (INR n / 3)* (1+(1/3))).
    rewrite Rmult_comm.
    assert (Rpower 3 (INR n / 3) * (1 + 1 / 3) = (1+1/3)*Rpower 3 (INR n / 3)).
    rewrite Rmult_comm.
    reflexivity.
    rewrite H0.
    apply Rfourier_le.
    exact IHn.
    fourier.
    assert (Rpower 3 (INR n / 3) * (1 + 1 / 3) <= Rpower 3 (INR n / 3) * Rpower 3 (1 / 3)).
    apply Rfourier_le.
    left.
    exact H5.
    SearchAbout Rpower.
    {
      induction n.
      {
        assert (INR 0/3 = 0).
        unfold INR.
        field.
        rewrite H1.
        rewrite Rpower_O.
        fourier.
        fourier.
      }{
        assert (0 < INR (S n)).
        apply lt_0_INR.
        omega.
        assert (INR (S n)<= Rpower 3 (INR (S n) / 3)).
        SearchAbout Rpower.
        apply n_vs_3n.
        fourier.
      }
      }
      fourier.
      }
      clear - H7 H8.
      fourier.
  }
Qed.
(************************************)
Lemma three_le_d_2 : forall d n,
 (3 <= d)%nat ->
 (3 <= n)%nat ->
 (d <= n)%nat ->
 (INR d + 1) * Rpower 3 ((INR n - INR d -1)/3) <=
 4 * Rpower 3 ((INR n -4)/3).
Proof.
    clear.
    intros.
    replace (INR d + 1) with (((INR d+1)/4) * 4) by field.
    assert (exists (eps : nat), INR d + 1 = 4 + INR eps).
    {
      clear H0 H1.
      induction d.
      omega.
      inversion H.
      subst.
      exists O; simpl; ring.
      subst.
      apply IHd in H1.
      destruct H1.
      exists (S x).
      do 2 rewrite S_INR.
      rewrite H0.
      ring.
    }
    destruct H2 as [eps H2].
    replace (INR n - INR d - 1) with
        (INR n - (INR d + 1)) by ring.
    rewrite -> H2 in *.
    ring_simplify.
    replace (INR n - (4 + INR eps)) with
        ((INR n - 4) + -(INR eps)) by ring.
    replace ((INR n - 4 + - INR eps) / 3) with
        (((INR n - 4)/3) + (-(INR eps /3))) by field.
    rewrite Rpower_plus.
    ring_simplify.
    pose proof (Nate_Help eps).
    rewrite plus_INR in H3.
    replace (INR 4) with 4 in H3 by (simpl; ring).
    replace (  4 * ((4 + INR eps) / 4) * Rpower 3 ((INR n - 4) / 3) *
               Rpower 3 (- (INR eps / 3))) with
        (  4 * (((4 + INR eps) / 4) * Rpower 3 ((INR n - 4) / 3) *
  Rpower 3 (- (INR eps / 3)))) by ring.
    apply Rmult_le_compat_l; [fourier|].
    clear H2.
    replace ((4 + INR eps) / 4 * Rpower 3 ((INR n - 4) / 3) *
             Rpower 3 (- (INR eps / 3))) with
        ((4 + INR eps) / 4 * Rpower 3 (- (INR eps / 3)) * Rpower 3 ((INR n - 4) / 3)) by ring.
    assert ((4 + INR eps) / 4 * Rpower 3 (- (INR eps / 3)) <= 1).
    {
      apply Rmult_le_compat_r with (r:= / Rpower 3 (INR eps / 3)) in H3.
      replace (Rpower 3 (INR eps / 3) * / Rpower 3 (INR eps / 3)) with
          1  in H3.
      {
        rewrite Rpower_Ropp; auto.
      }
      {
        symmetry.
        apply Rinv_r.
        pose proof (n_q eps).
        clear -H2.
        intros Hnot.
        rewrite Hnot in H2.
        pose proof (pos_INR eps).
        inversion H2.
        inversion H.
        fourier.
        subst.
        fourier.
        inversion H.
        fourier.
        rewrite H0 in Hnot.
        replace (0 / 3) with 0 in Hnot by field.
        rewrite Rpower_O in Hnot; fourier.
      }
      {
        pose proof (n_q eps).
        clear - H2.
        pose proof (pos_INR eps).
        inversion H.
        inversion H2.
        constructor.
        apply Rinv_0_lt_compat; auto.
        fourier.
        rewrite <- H1.
        constructor.
        apply Rinv_0_lt_compat; auto.
        rewrite <- H0.
        replace (0 / 3) with 0  by field.
        rewrite Rpower_O; fourier.
      }
    }
    apply Rmult_le_compat_r with (r:= Rpower 3 ((INR n -4 )/3)) in H2.
    fourier.
    pose proof (n_q (n - 4)).
    clear - H4 H0.
    assert ( n = 3 \/ n = 4 \/ 4 <= n)%nat.
    omega.
    destruct H; subst.
    {
      simpl.
      replace ((1 + 1 + 1 - 4) / 3) with (-(1/3)) by field.
      rewrite Rpower_Ropp.
      left.
      apply Rinv_0_lt_compat; try fourier.
      apply pos_pow; try fourier.
    }
    destruct H; subst.
    {
      simpl.
      replace ((1 + 1 + 1 + 1 - 4) / 3) with (0) by field.
      rewrite Rpower_O; fourier.
    }
    pose proof (pos_INR (n-4)).
    inversion H1.
    left.
    apply pos_pow; try fourier.
    unfold Rdiv.
    apply Rmult_lt_0_compat; try fourier; auto.
    rewrite minus_INR in H2; try fourier.
    replace (INR 4) with 4 in H2 by (simpl; ring);
    auto.
    auto.
    assert (INR n = 4).
    {
      rewrite minus_INR in H2; auto.
      replace (INR 4) with 4 in H2 by (simpl; ring).
      clear -H2.
      generalize dependent (INR n).
      intros.
      unfold Rminus in H2.
      symmetry in H2.
      apply Rplus_opp_r_uniq in H2.
      apply Ropp_eq_compat in H2.
      do 2 rewrite Ropp_involutive in H2.
      symmetry; auto.
    }
    rewrite H3.
    replace ((4 - 4) / 3) with 0 by field.
    rewrite Rpower_O; fourier.
  Qed.

(*** Paper proof
  if d >= 3
     MIS(G)| ≤ (d + 1) · 3^(n−d−1)/3 ≤ 4 · 3^(n−4)/3 ≤ g(n)
  if d = 2
     | MIS(G)| ≤ 3 · g(n − 3) = g(n)
  if d = 1
        MIS(G) ≤ 2 · g(n − 2) ≤ g(n)
   ***)

  Lemma I_three_eq : forall (n: nat),
      (3  <= n)%nat ->
       3 * I (n - 3) = I n.
  Proof.
    intros.
    destruct n.
    inversion H.
    inversion H.
    {
      subst.
      unfold I; simpl.
      replace ((1 + 1 + 1) / 3) with (1) by field.
      rewrite Rpower_1.
      replace (0 /3) with 0 by field.
      rewrite Rpower_O.
      ring.
      fourier.
      fourier.
    }
    subst.
    assert (H0 : (S n = 1 \/ S n = 2 \/ exists m, S n = ( m + 3) )%nat).
    {
      do 2 (destruct n;
            auto); do 2 right;
        exists n; omega.
    }
    destruct H0; subst.
    {
      exfalso.
      omega.
    }
    destruct H0.
    {
      exfalso.
      omega.
    }
    destruct H0.
    rewrite -> H0 in *.
    replace (x+ 3-3)%nat with x by (omega).
    rewrite <- I_unfold; ring.
  Qed.

  Lemma I_pos :
    forall n, (0 <= n)%nat ->
              0 <= I n .
  Proof.
    clear.
    intros.
    induction n using strong_induction.
    {
      unfold I; simpl; auto.
      replace (0/3) with 0 by field.
      rewrite Rpower_O; fourier.
    }
    rename H0 into H1.
    assert (H0 : (S n = 1 \/ S n = 2 \/ exists m, S n = ( m + 3) )%nat).
    {
      do 2 (destruct n;
            auto); do 2 right;
        exists n; omega.
    }
    destruct H0.
    {
      inversion H0.
      subst.
      unfold I; simpl.
      replace ((1-4)/3) with (-(1)) by field.
      rewrite Rpower_Ropp.
      rewrite Rpower_1;
        fourier.
    }
    destruct H0.
    {
      inversion H0.
      subst.
      unfold I; simpl.
      replace (0/3) with 0 by field.
      replace (2-2) with (0) by ring.
      replace (0/3) with (0) by field.
      replace ((1 + 1 - 2) / 3) with 0 by field.
      rewrite Rpower_O; fourier.
    }
    destruct H0.
    inversion H.
    subst.
    assert (x <= n)%nat by omega.
    apply H1 in H2; auto.
    rewrite H0.
    rewrite <- I_unfold.
    apply Rmult_le_pos; try fourier.
    omega.
  Qed.

Lemma I_lower_bound_1 :
  forall n,
    (3 <= n)%nat ->
    2 * I (n - 2) <= I n.
Proof.
  clear.
  intros.
  induction n using strong_induction.
  {
    omega.
  }
  inversion H.
  subst.
  simpl.
  unfold I.
  simpl.
  {
    replace ((1-4)/3) with (-(1)) by field.
    rewrite Rpower_Ropp.
    replace ((1 + 1 + 1)/3) with 1 by field.
    rewrite Rpower_1;
      fourier.
  }
  subst.
  clear H.
  assert (H1 : (S n = 1 \/ S n = 2 \/ exists m, S n = ( m + 3) )%nat).
  {
    do 2 (destruct n;
          auto); do 2 right;
      exists n; omega.
  }
  destruct H1; subst.
  {
    exfalso.
    omega.
  }
  destruct H.
  {
    exfalso.
    omega.
  }
  destruct H.
  rewrite H.
  assert (x <= n)%nat by omega.
  assert (3 <= x \/ x = 0 \/ x = 1 \/ x = 2 \/ x = 3)%nat.
  omega.
  destruct H3.
  {
    apply H0 in H1; auto.
    replace (x + 3 - 2)%nat with (x - 2 + 3)%nat by
        (clear - H3;
         omega).
    rewrite <- I_unfold;
      auto.
    rewrite <- I_unfold.
    rewrite <- Rmult_assoc.
    apply Rmult_le_compat; try fourier; auto.
    assert (0 <= x - 2)%nat by
        omega.
    {
      apply Rmult_le_pos; try fourier.
      apply I_pos; auto.
    }
  }
  destruct H3; subst.
  {
    simpl.
    unfold I.
    simpl.
    replace ((1-4)/3) with (-(1)) by field.
    rewrite Rpower_Ropp.
    replace ((1 + 1 + 1)/3) with 1 by field.
    rewrite Rpower_1;
      fourier.
  }
  {
    destruct H3; subst.
    {
      unfold I; simpl.
      replace (1 + 1 + 1 + 1 - 4) with 0 by field.
      replace ((1 + 1 - 2) / 3) with 0 by field.
      replace (0 / 3) with 0 by field.
      rewrite Rpower_O; fourier.
    }
    destruct H3; subst; unfold I; simpl; try fourier.
    {
      apply Rmult_le_compat_l; try fourier.
      apply Rle_Rpower; fourier.
    }
    {
      replace ((1+ 1+1 + 1 + 1 + 1)/3) with 2 by field.
      replace ((1 + 1 + 1 + 1 - 4)/3) with
          0 by field.
      rewrite Rpower_O; try fourier.
      replace 2 with (INR 2) by (simpl; ring).
      rewrite Rpower_pow; try fourier.
      simpl.
      fourier.
    }
  }
Qed.

Lemma I_lower_bound_2 :
  forall n,
    (3 <= n)%nat ->
    I (n - 1) + I (n - 4) <= I n.
Proof.
  clear.
  intros.
  intros.
  induction n using strong_induction.
  {
    omega.
  }
  inversion H.
  subst.
  simpl.
  unfold I.
  simpl.
  {
    replace (0 /3) with 0 by field.
    rewrite Rpower_O; try fourier.
    replace ((1 + 1 + 1)/3) with 1 by field.
    replace ((1+1-2)/3) with 0 by field.
    rewrite Rpower_O.
    rewrite Rpower_1.
    all: fourier.
  }
  subst.
  clear H.
  assert (H1 : (S n = 1 \/ S n = 2 \/ exists m, S n = ( m + 3) )%nat).
  {
    do 2 (destruct n;
          auto); do 2 right;
      exists n; omega.
  }
  destruct H1; subst.
  {
    exfalso.
    omega.
  }
  destruct H.
  {
    exfalso.
    omega.
  }
  destruct H.
  rewrite H.
  assert (x <= n)%nat by omega.
  assert (4 <= x \/ x = 0 \/ x = 1 \/ x = 2 \/ x = 3 \/ x = 4)%nat.
  omega.
  destruct H3.
  {
    apply H0 in H1; auto.
    replace (x + 3 - 1)%nat with (x - 1 + 3)%nat by
        (clear - H3;
         omega).
    rewrite <- I_unfold;
      auto.
    rewrite <- I_unfold.
    replace (x + 3 - 4)%nat with (x - 4 + 3)%nat by
        (clear - H3;
         omega).
    rewrite <- I_unfold.
    ring_simplify.
    fourier.
    omega.
  }
  destruct H3; subst.
  {
    simpl.
    unfold I.
    simpl.
    replace ((0/3)) with (0) by field.
    rewrite Rpower_O; try fourier.
    replace ((1 + 1 + 1)/3) with 1 by field.
    replace ((1+1-2)/3) with 0 by field.
    rewrite Rpower_O.
    rewrite Rpower_1.
    all: fourier.
  }
  {
    destruct H3; subst.
    {
      unfold I; simpl.
      replace (1 + 1 + 1 + 1 - 4) with 0 by field.
      replace (0 / 3) with 0 by field.
      replace ((1 + 1 + 1)/3) with 1 by field.
      rewrite Rpower_1;
        try fourier.
      rewrite Rpower_O; fourier.
    }
    destruct H3; subst; unfold I; simpl; try fourier.
    {
      replace (1 + 1 + 1 + 1 - 4) with 0 by field.
      replace ((1 + 1 + 1)/3) with
          1 by field.
      replace ((1 - 4)/3) with (-(1)) by field.
      replace (0 / 3) with 0 by field.
      rewrite Rpower_O; try fourier.
      ring_simplify.
      rewrite Rpower_Ropp.
      rewrite Rpower_1.
      replace (((1 + 1 + 1 + 1 + 1 - 2) / 3)) with 1 by field.
      rewrite Rpower_1;
      fourier.
      fourier.
    }
    destruct H3; subst;
      simpl.
    {
      replace ((1+ 1+1 + 1 + 1 + 1)/3) with 2 by field.
      replace ((1+1-2)/3) with 0 by field.
      replace ((1 + 1+ 1 + 1 + 1 -2)/3) with 1 by field.
      rewrite Rpower_O.
      rewrite Rpower_1.
      replace 2 with (INR 2) by (simpl; ring).
      rewrite Rpower_pow; try fourier.
      simpl.
      all:
      fourier.
    }
    {
      replace ((1+ 1+1 + 1 + 1 + 1)/3) with 2 by field.
      replace ((1+ 1+1 + 1 + 1 + 1 + 1-4)/3) with (1) by field.
      replace ((1 + 1 + 1)/3) with
          1 by field.
      rewrite Rpower_1; try fourier.
      ring_simplify.
      replace 2 with (INR 2) by (simpl; ring).
      rewrite Rpower_pow; try fourier.
      simpl.
      fourier.
    }
  }
Qed.

(** This next section is contributed by DWJ  **)
(** We are trying to prove that I is monotonic **)
Lemma DWJ_helper1:forall n:nat, ((n mod 3 = 0)\/ (n mod 3) = 1 \/ (n mod 3) =2)%nat.
Proof.
  intros.
  assert ((n mod 3) < 3)%nat.
  apply Nat.mod_small_iff.
  omega.
  apply Nat.mod_mod.
  omega.
  assert (forall n:nat, (n =0)\/(n = 1)\/(n=2)\/(n>2))%nat.
  intro.
  omega.
  assert (((n mod 3) =0)\/((n mod 3) = 1)\/((n mod 3) =2)\/((n mod 3) >2))%nat.
  apply H0.
  destruct H1.
  left;rewrite H1; reflexivity.
  destruct H1.
  right;left;rewrite H1;reflexivity.
  destruct H1.
  right;right;rewrite H1;reflexivity.
  omega.
Qed.

Lemma DWJ_helper2: (INR 0) /3 = 0.
Proof.
simpl.
field.
Qed.

Lemma DWJ_helper3: forall n:nat, 0<= (INR n) /3.
Proof.
intros.
assert (0<=INR n).
apply pos_INR.
unfold Rdiv.
apply Rmult_le_pos.
exact H.
fourier.
Qed.

Lemma DWJ_helper4: 0 < Rpower 3 (1 / 3).
Proof.
apply Rlt_trans with (r2:=1 + (1/3)).
fourier.
apply three_x_1.
fourier.
Qed.

Lemma DWJ_helper5: forall x:R, 0<x -> 0< Rpower 3 (x/3).
Proof.
intros.
apply Rlt_trans with (r2:=1 + (x/3)).
fourier.
apply three_x_1.
fourier.
Qed.

(*** The hardest technical lemma --- forall n, I(n) < I(n+1)  ***)
Lemma Monotonic_helper: forall n:nat, I n < I (S n).
Proof.
intros.
unfold I.

assert (  n mod 3 = 0%nat \/ n mod 3 = 1%nat \/ n mod 3 = 2%nat).
apply DWJ_helper1.

destruct H.
{
  rewrite H.
  assert ((S n mod 3) = 1)%nat.
  replace (S n) with (n+1)%nat.
SearchAbout Nat.modulo.
rewrite Nat.add_mod.
rewrite H.
simpl.
reflexivity.
omega.
omega.
rewrite H0.
simpl.
induction n.
{
  rewrite DWJ_helper2.
  replace (1-4) with (-3).
  replace (Rpower 3 0) with 1.
  replace (-3/3) with (-1).
  replace (Rpower 3 (-1)) with (/Rpower 3 1).
  replace (Rpower 3 1) with 3.
  fourier.
  symmetry.
  apply Rpower_1.
  fourier.
  symmetry.
  apply Rpower_Ropp.
  field.
  symmetry.
  apply Rpower_O.
  fourier.
  field.
  }
  {
    replace (INR (S n)) with ((INR n) + 1).
    replace (INR n + 1 + 1 -4) with (INR n -2).
    replace ((INR n +1)/3) with ((INR n)/3 + 1/3).
    replace ((INR n -2)/3) with (((INR n)/3) + (-2/3)).
    replace (Rpower 3 (INR n / 3 + 1 / 3)) with  ((Rpower 3 ((INR n)/3))* (Rpower 3 (1/3))).
    assert ((Rpower 3 (((INR n) / 3) + (-2 / 3))) = ((Rpower 3 ((INR n)/3) ) * (Rpower 3 (-2/3)))).
    apply Rpower_plus with (x:=(INR n)/3) (y:= (-2/3)) (z:=3).
    rewrite H1.
    replace (4 * (Rpower 3 (INR n / 3) * Rpower 3 (-2 / 3))) with (Rpower 3 (INR n / 3)*(4*Rpower 3 (-2 / 3))).
    apply Rfourier_lt.
    assert ((Rpower 3 (1/3)) = (3*(Rpower 3 (-2/3)))).
    replace (3) with (Rpower 3 1) at 3.
    replace ((Rpower 3 1) * (Rpower 3 (-2/3))) with (Rpower 3 (1 + (-2/3))).
    replace (1+(-2/3)) with (1/3).
    reflexivity.
    field.
    apply Rpower_plus.
    apply Rpower_1.
    fourier.
    rewrite H2.
    rewrite Rmult_comm.
    assert (4 * Rpower 3 (-2 / 3) = (Rpower 3 (-2/3))*4).
    rewrite Rmult_comm.
    reflexivity.
    rewrite H3.
    apply Rfourier_lt.
    fourier.
    replace (-2/3) with (-(2/3)).
    rewrite Rpower_Ropp.
    replace (/Rpower 3 (2/3)) with (1*/(Rpower 3 (2/3))).
    apply Rlt_mult_inv_pos.
    fourier.
    assert (1+(2/3) < (Rpower 3 (2/3))).
    apply three_x_1.
    fourier.
    assert (0<1+(2/3)).
    fourier.
    apply Rlt_trans with (r2:=(1+(2/3))).
    exact H5.
    exact H4.
    rewrite Rmult_comm.
    apply Rmult_1_r.
    field.
    apply Rlt_le_trans with (r2:=1+(INR n /3)).
    apply Rlt_le_trans with (r2:=1).
    fourier.
    replace (1) with (1+0) at 1.
    apply Rplus_le_compat_l.
    apply DWJ_helper3.
    field.
    destruct n.
    {
      simpl.
      replace (0/3) with (0).
      replace (Rpower 3 0) with 1.
      fourier.
      symmetry.
      apply Rpower_O.
      fourier.
      field.
    }
    {

    unfold Rle.
    left.
    apply three_x_1.
    replace (INR (S n) ) with ((INR n)+1).
    replace (((INR n)+1)/3) with ((INR n)/3 + (1/3)).
    apply Rplus_le_lt_0_compat.
    apply DWJ_helper3.
    fourier.
    symmetry.
    apply Rdiv_plus_distr.
    symmetry.
    apply S_INR.
    }
    field.
    symmetry.
    apply Rpower_plus.
    field.
    field.
    field.
    symmetry.
    apply S_INR.
  }
  }
  (*** First case (n mod 3 = 0 is done! ***)
  destruct H.
  assert ((S n mod 3) = 2)%nat.
  replace (S n) with (n+1)%nat.
  rewrite Nat.add_mod.
  rewrite H.
  simpl.
  reflexivity.
  omega.
  omega.
  rewrite H.
  rewrite H0.
  simpl.
  {
    induction n.
    {
      (* Base *)
      replace (INR 0) with (0) by (simpl;reflexivity).
      replace (1 - 2) with (-1) by field.
      replace ((0-4)/3) with (-1 + (-1/3)) by field.
      replace (Rpower 3 ((-1 +  (-1 / 3)))) with ((Rpower 3 (-1))*(Rpower 3 (-1/3))).
      replace (4 * (Rpower 3 (-1) * Rpower 3 (-1 / 3))) with ((Rpower 3 (-1 / 3)) * (4 * (Rpower 3 (-1)))) by field.
      replace (2 * Rpower 3 (-1 / 3)) with (Rpower 3 (-1 / 3) * 2) by field.
      apply Rfourier_lt.
      replace (-1) with (-(1)) by auto.
      rewrite Rpower_Ropp.
      rewrite Rpower_1.
      fourier.
      fourier.
      replace (-1/3) with (-(1/3)) by field.
      rewrite Rpower_Ropp.
      assert ((Rpower 3 (1/3)) <= Rpower 3 1).
      apply Rle_Rpower.
      fourier.
      fourier.
      apply Rlt_le_trans with (r2:=1/3); auto.
      fourier.
      replace (1/3) with (/3) by field.
      apply Rinv_le_contravar.
      assert (1<=Rpower 3 (/3)).
      rewrite <-Rpower_O with (x:=3) at 1.
      apply Rle_Rpower.
      fourier.
      fourier.
      fourier.
      fourier.
      assert (3=Rpower 3 1).
      symmetry.
      apply Rpower_1.
      fourier.
      rewrite H2 at 3.
      replace (/3) with (1/3) by field.
      exact H1.
      symmetry.
      apply Rpower_plus.
      }
      replace (INR (S n)) with ((INR n)+1) by (rewrite S_INR; field).
      replace ((INR n) + 1-4) with ((INR n) + -3) by field.
      replace ((INR n) + 1 + 1 -2) with (INR n) by field.
      replace (2 * Rpower 3 (INR n / 3)) with (Rpower 3 (INR n / 3) * 2) by field.
      replace ((INR n + -3) / 3) with ((INR n)/3 + (-3/3)) by field.
      replace (Rpower 3 ((INR n) / 3 + (-3 / 3))) with ((Rpower 3 ((INR n)/3))*(Rpower 3 (-3/3))).
      replace (4 * ((Rpower 3 ((INR n) / 3)) * Rpower 3 (-3 / 3))) with ((Rpower 3 ((INR n) / 3))*(4*(Rpower 3 (-3/3)))).
      apply Rfourier_lt.
      replace (-3/3) with (-1) by field.
      replace (-1) with (-(1)) by field.
      rewrite Rpower_Ropp.
      rewrite Rpower_1.
      fourier.
      fourier.
      assert (1<=Rpower 3 (INR n /3)).
      rewrite <-Rpower_O with (x:=3) at 1.
      apply Rle_Rpower.
      fourier.
      {
        clear.
        induction n.
        simpl.
        fourier.
        rewrite S_INR.
        rewrite Rdiv_plus_distr.
        fourier.
      }
      fourier.
      fourier.
      field.
      symmetry.
      apply Rpower_plus.
    }
  {
      rewrite H.
  assert ((S n mod 3) = 0)%nat.
  replace (S n) with (n+1)%nat.
  rewrite Nat.add_mod.
  rewrite H.
  simpl.
  reflexivity.
  omega.
  omega.
  rewrite H0.
  simpl.
  induction n.
  {
    simpl.
    replace (0-2) with (1+-3) by field.
    replace ((1+-3)/3) with (1/3+(-1)) by field.
    replace (Rpower 3 ((1/3)+(-1))) with ((Rpower 3 (1/3)) * (Rpower 3 (-1))).
    replace (2 * (Rpower 3 (1 / 3) * Rpower 3 (-1)) ) with ((Rpower 3 (1/3)) * (2* (Rpower 3 (-1)))).
    assert ( Rpower 3 (1 / 3) = Rpower 3 (1 / 3) * 1).
    field.
    rewrite H1 at 2.
    apply Rfourier_lt.
    replace (-1) with (-(1)) by auto.
    rewrite Rpower_Ropp.
    rewrite Rpower_1.
    fourier.
    fourier.
    apply DWJ_helper4.
    field.
    symmetry.
    apply Rpower_plus.
   }
    {
      replace (INR (S n)) with ((INR n) + 1).
      replace (INR n +1 -2) with (((INR n) + 2) + (- 3)) by field.
      replace ((INR n) + 1 + 1) with ((INR n) + 2) by field.
      replace (Rpower 3 ((INR n + 2) / 3)) with (Rpower 3 ((INR n + 2) / 3) * 1) by field.
      replace (Rpower 3 ((INR n + 2 + -3) / 3)) with ((Rpower 3 ((INR n +2)/3))*(Rpower 3 (-3/3))).
      replace  (2* (Rpower 3 ((INR n + 2) / 3) * Rpower 3 (-3 / 3))) with
      (Rpower 3 ((INR n + 2) / 3) * (2* Rpower 3 (-3 / 3))) by field.
      apply Rfourier_lt.
      replace (-3/3) with (-(1)) by field.
      rewrite Rpower_Ropp.
      rewrite Rpower_1.
      fourier.
      fourier.
      apply DWJ_helper5.
      assert (0<=INR n).
      apply pos_INR.
      fourier.
      symmetry.
      replace (((INR n)+2 + -3)/3) with (((INR n) +2)/3 + (-3)/3) by field.
      apply Rpower_plus.
      rewrite S_INR.
      reflexivity.
    }
   }
Qed.

 (*** Here we prove that the function I is strictly increasing for all values of      n.   ****)

Theorem I_increasing:  forall m :nat, forall n:nat, ((n<m)%nat -> I n < I m).
Proof.
induction m.
{
  induction n.
  {
  intro.
  inversion H.
  }
  {
    intros.
    omega.
  }
  }
  {
    assert (forall n m:nat, (n<m)\/ (n=m) \/ (m<n))%nat.
    intros.
    omega.
    intros.
    assert ((n < m)%nat \/ n = m \/ (m < n)%nat).
    apply H.
    destruct H1.
    {
      apply Rlt_trans with (r2:= I m).
      apply IHm.
      exact H1.
      apply Monotonic_helper.
    }
    destruct H1.
    {
      rewrite H1.
      apply Monotonic_helper.
    }
    {
      omega.
    }
  }
Qed.
(*** The function I is monotonically increasing, i.e., n<=m -> I(n) <= I(m) **)
Theorem I_monotonic:  forall m :nat, forall n:nat, ((n<=m)%nat -> I n <= I m).
Proof.
intros.
destruct H.
{
  fourier.
}
{
  assert (n<S m)%nat.
  omega.
  left.
  apply I_increasing.
  exact H0.
}
Qed.


(* Lists *)
Fixpoint eqb (n m : nat) : bool := (* copied from HW_1/2 *)
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.
Notation "x =? y" := (eqb x y) (at level 70).

Module NatList.

Inductive natprod : Type :=
| pair (n1 n2: nat).

Check (pair 3 5).

(* Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.

Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Compute fst(pair 3 4).
*)
Notation "( x , y )" := (pair x y).

(* Compute (fst (3, 5)). *)

Definition fst(p : natprod) : nat :=
  match p with
  |(x, y) => x
  end.

Definition snd(p : natprod) : nat :=
  match p with
  |(x, y) => y
  end.

Compute (fst (3, 5)).
Compute (snd (3, 5)).

Definition swap_pair (p : natprod) : natprod :=
  match p with
  | (x, y) => (y, x)
  end.

Compute (swap_pair (3,5)).

Theorem surjective_pairing' :
forall n m : nat,
 (n, m) = (fst(n,m), snd(n,m)).
Proof.
simpl. reflexivity.
Qed.

Theorem surjective_pairing :
forall p : natprod,
  p = (fst p, snd p).
Proof.
  intros p.
  destruct p as [n m].
  simpl.
  reflexivity.
Qed.

Theorem snd_fst_is_swap :
forall p : natprod,
  (snd p, fst p) = swap_pair p.
Proof.
  intros p.
  destruct p as [n m].
  simpl.
  reflexivity.
Qed.

Theorem fst_swap_is_snd :
forall p : natprod,
  fst (swap_pair p) = snd p.
Proof.
  intros p.
  destruct p as [n m].
  simpl.
  reflexivity.
Qed.

Inductive natlist : Type :=
  |nil
  |cons(n : nat) (l : natlist).

Definition list_3 := cons 3 nil.
Definition list_2_3 := cons 2 list_3.
Definition list_1_2_3 := cons 1 list_2_3.

(* now let's make it more readable *)
Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).

(* the following function takes a number n and a count and returns a
list of length count with each element equal to n *)
Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' =>  n::(repeat n count')
  end.

Compute (repeat 4 10).

Fixpoint length (l : natlist) : nat :=
  match l with
  |nil => O
  |head::tail => S (length tail) (* 1 + length(tail) *)
  end.

Compute (length [1; 2; 3; 4; 5; 6]).

(* appends two lists *)
Fixpoint app(l1 l2 : natlist) : natlist :=
  match l1 with
  |nil => l2
  |head::tail => head::(app tail l2)
  end.

Compute (app [1; 2; 3; 4] [5; 6; 7; 8]).

Notation "x ++ y" := (app x y) (at level 60, right associativity).

(* right associativity means that x~y~z will be read as x~(y~z) instead of (x~y)~z *)

Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.
Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3: [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.

Definition hd(default : nat) (l : natlist) : nat :=
  match l with
  |nil => default
  |head::tail => head
  end.

Definition tl(l : natlist) : natlist :=
  match l with
  |nil => nil
  |head::tail => tail
  end.

Example test_hd_1: hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.
Example test_hd_2: hd 0 [] = 0.
Proof. reflexivity. Qed.
Example test_tl: tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.

Fixpoint nonzeros (l: natlist) : natlist :=
  match l with
  |nil => nil
  |head::tail =>
    match head with
    |O => nonzeros tail
    |S head' => S head'::(nonzeros tail)
    end
  end.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. reflexivity. Qed.

Theorem nil_app :
forall l : natlist, [] ++ l = l.
Proof. simpl. reflexivity. Qed.

Theorem tl_length_pred :
forall l : natlist,
pred (length l) = length (tl l).
Proof.
  intros l.
  destruct l as [| head tail].
  -(* l = nil *)
    simpl.
    reflexivity.
  -(* l = head::tail *)
    simpl.
    reflexivity.
Qed.

Theorem app_assoc :
forall l1 l2 l3 : natlist,
(l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
intros l1 l2 l3.
induction l1 as [| n l1' IHl1'].
-simpl. reflexivity.
-simpl. rewrite -> IHl1'. reflexivity.
Qed.

Fixpoint rev (l : natlist) : natlist :=
  match l with
  | nil => nil
  | head::tail => rev tail ++ [head]
  end.

Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.
Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

Theorem plus_comm :
forall n m: nat,
  n + m = m + n.
Proof.
  intros n m.
  induction n as [| n IHn'].
    -simpl. rewrite <- plus_n_O. reflexivity.
    -simpl. rewrite <- plus_n_Sm. rewrite -> IHn'. reflexivity.
(*we use the second function we proved followed by the hypothesis*)
Qed.

Theorem app_length:
forall l1 l2 : natlist,
length (l1++l2) = (length l1) + (length l2).
Proof.
intros l1 l2.
induction l1 as [| n l1' IHl1'].
-simpl. reflexivity.
-simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem rev_length:
forall l : natlist,
length (rev l) = length l.
Proof.
intros l.
induction l as [| n l' IHl'].
-simpl. reflexivity.
-simpl. rewrite app_length. rewrite plus_comm. rewrite -> IHl'.  simpl. reflexivity.
Qed.

(* Homework begins from here *)

Theorem app_nil_r:
forall l : natlist,
l ++ [] = l.
Proof.
intros l.
induction l as [| n l' IHl']. (* we proceed by simple induction *)
-simpl. reflexivity.
-simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem rev_app_distr:
forall l1 l2 : natlist,
rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
intros l1 l2.
induction l1 as [| n l1' IHl1']. (* we proceed by simple induction *)
-simpl. rewrite -> app_nil_r. reflexivity. (* we apply the previous theorem *)
-simpl. rewrite -> IHl1'. rewrite app_assoc. reflexivity. (* we apply the associativity theorem proven earlier. *)
Qed.

Theorem rev_involutive:
forall l : natlist,
rev (rev l) = l.
Proof.
intros l.
induction l as [| n l' IHl'].
-simpl. reflexivity.
-simpl. rewrite rev_app_distr. rewrite -> IHl'. simpl. reflexivity.
(* we apply the previous theorem and the induction hypothesis *)
Qed.

(* a helper function for equality of natural numbers *)
Fixpoint eq_nat (n m : nat) : bool :=
  match n, m with
    | O, O => true
    | O, S _ => false
    | S _, O => false
    | S n1, S m1 => (eq_nat n1 m1)
  end.

Fixpoint eqblist (l1 l2 : natlist) : bool :=
  match l1 with
  |nil => (* trivial *)
    match l2 with
    |nil => true
    |head::tail => false
    end
  |head1::tail1 =>
    match l2 with
    |nil => false
    |head2::tail2 => (andb (eq_nat head1 head2) (eqblist tail1 tail2))
    (* two lists are equal if their heads and tails are both equal *)
    end
  end.

Example test_eqblist1 :
  (eqblist nil nil = true).
Proof. reflexivity. Qed.
Example test_eqblist2 :
  eqblist [1;2;3] [1;2;3] = true.
Proof. reflexivity. Qed.
Example test_eqblist3 :
  eqblist [1;2;3] [1;2;4] = false.
Proof. reflexivity. Qed.

(*a lemma used in the next theorem *)
Lemma eq_nat_n:
forall n : nat,
eq_nat n n = true. (* eq_nat applied to the same number returns true *)
Proof.
intros n.
induction n as [| n' IHn'].
-simpl. reflexivity.
-simpl. rewrite IHn'. reflexivity.
Qed.

Theorem eqblist_refl :
forall l : natlist,
true = eqblist l l.
Proof.
intros l.
induction l as [| n l' IHl'].
-simpl. reflexivity. (* nil = nil *)
-simpl. rewrite eq_nat_n. simpl. rewrite <- IHl'. reflexivity.
(* The function will return true if the heads are equal (which they are), we use the lemma. Then we just
proceed with the hypothesis *)
Qed.

Theorem rev_injective:
forall l1 l2 : natlist,
rev l1 = rev l2 -> l1 = l2.
Proof.
intros l1 l2 condition.
rewrite <- rev_involutive.  (* apply that l2 = rev (rev l2). *)
rewrite <- condition. (* use the condition that rev l2 = rev l1. *)
rewrite -> rev_involutive. (* apply that l1 = rev (rev l1) *)
reflexivity.
Qed.

End NatList.

Module PartialMap.

Lemma eqb_n:
forall n : nat, eqb n n = true. (* n = n is true *)
Proof.
intros n.
induction n as [| n' IHn'].
-simpl. reflexivity.
-simpl. rewrite -> IHn'. reflexivity.
Qed.

Inductive natoption : Type :=
  | Some (n : nat)
  | None.

Inductive id : Type :=
  | Id (n : nat).

Definition eqb_id (x1 x2 : id) :=
  match x1, x2 with
  |Id n1, Id n2 => n1 =? n2
  end.

Theorem eqb_id_refl:
forall x, true = eqb_id x x.
Proof.
intros x.
destruct x. simpl. rewrite -> eqb_n. reflexivity. (*we just use the lemma above *)
Qed.

Inductive partial_map : Type :=
|empty
|record (i : id) (v : nat) (m : partial_map).

(* This declaration can be read: There are two ways to construct a partial_map:
either using the constructor empty to represent an empty partial map,
or by applying the constructor record to a key, a value, and an existing partial_map
 to construct a partial_map with an additional key-to-value mapping. *)

Definition update (d : partial_map) (x : id) (value : nat) : partial_map :=
  record x value d.
(* update just adds the new (key, value) pair into the hashmap *)

Fixpoint find (x : id) (d : partial_map) : natoption :=
  match d with
  |empty => None
  |record y v d' =>
    if eqb_id x y
    then Some v
    else find x d'
  end.

Theorem update_eq :
forall (d : partial_map) (x : id) (v : nat),
find x (update d x v) = Some v.

Proof.
intros d x v.
simpl. rewrite <- eqb_id_refl. reflexivity. (* we just apply the eqb_id_refl property proven earlier *)
Qed.

Theorem update_neq :
forall (d : partial_map) (x y : id) (o : nat),
eqb_id x y = false -> find x (update d y o) = find x d.

Proof.
intros d x y o condition.
unfold update. (* rewrite update with its definition *)
simpl.
rewrite -> condition. (* use the condition to get to a symmetric claim *)
reflexivity.
Qed.

End PartialMap.

Module Polymorphism.

(* Polymorphism *)

(* In general, we can use curly braces when defining a parameter to avoid writing the type each time *)
Inductive list (X : Type) : Type :=
|nil
|cons (x : X) (l : list X).

Arguments nil {X}.
Arguments cons {X} _ _.

(* the following function takes a number n and a count and returns a
list of length count with each element equal to n *)
Fixpoint repeat {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | O => nil
  | S count' =>  cons x (repeat x count')
  end.

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
  |nil => l2
  |cons head tail => cons head (app tail l2)
  end.

Fixpoint rev {X : Type} (l : list X) : list X :=
  match l with
  |nil => nil
  |cons head tail => app (rev tail) (cons head nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  |nil => O
  |cons _ tail => S (length tail)
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.
Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.
Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Notation "x :: y" := (cons x y) (at level 60, right associativity).
Notation "[]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y) (at level 60, right associativity).

(* poly_exercises *)
Theorem app_nil_r:
forall (X : Type) (l : list X),
l ++ [] = l.
Proof.
intros X l.
induction l as [| h l' IHl'].
-simpl. reflexivity.
-simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem app_assoc:
forall (A : Type) (l m n : list A),
l ++ m ++ n = (l ++ m) ++ n.
intros A l m n.
induction l as [| h l' IHl'].
-simpl. reflexivity.
-simpl. rewrite <- IHl'. reflexivity.
Qed.

Lemma app_length:
forall (X : Type) (l1 l2 : list X),
length (l1 ++ l2) = length l1 + length l2.
Proof.
intros X l1 l2.
induction l1 as [| h l' IHl'].
-simpl. reflexivity.
-simpl. rewrite IHl'. reflexivity.
Qed.

(* more_poly_exercises *)
Theorem rev_app_distr:
forall X (l1 l2 : list X),
rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
intros X l1 l2.
induction l1 as [| h l1' IHl1'].
-simpl. rewrite -> app_nil_r. reflexivity.
-simpl. rewrite -> IHl1'. rewrite <- app_assoc. reflexivity.
Qed.

Theorem rev_involutive:
forall (X : Type) (l : list X),
rev (rev l) = l.
Proof.
intros X l.
induction l as [| h l' IHl'].
-simpl. reflexivity.
-simpl. rewrite -> rev_app_distr. simpl. rewrite -> IHl'. reflexivity.
Qed.

(*note: The previous 5 functions were more or less exactly the same as for lists *)

(* functions as data *)
Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Definition doit3times {X:Type} (f : X  -> X) (n:X) : X :=
  f (f (f n)).
Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.

Example test_doit3times': doit3times negb true = false. (* negate 3 times *)
Proof. reflexivity. Qed.

Fixpoint filter {X:Type} (test: X -> bool) (l:list X) : (list X) :=
  match l with
  |[] => []
  |h :: t =>
    if test h
    then h :: (filter test t)
    else filter test t
  end.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.
Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity. Qed.

(* the following function takes [n1, n2 .. nk] and returns [f n1, f n2, .. f nk] *)
Fixpoint map {X Y: Type} (f:X -> Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

Fixpoint fold {X Y : Type} (f : X -> Y -> Y) (l : list X) (b : Y) : Y :=
  match l with
  |nil => b
  |h :: t => f h (fold f t b )
  end.

Compute fold plus [1;2;3;4] 0.

Definition constfun {X: Type} (x: X) : nat -> X :=
  fun (k:nat) => x.
Definition ftrue := constfun true.
Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.
Example constfun_example2 : ftrue 4 = true.
Proof. reflexivity. Qed.

Definition prod_curry {X Y Z : Type} (f : X * Y -> Z) (x : X) (y : Y) : Z :=
 f (x, y).
Definition prod_uncurry {X Y Z : Type} (f : X -> Y -> Z) (p : X*Y) : Z :=
(* p is a pair, and we want to apply the function with the two parameters, so *)
  f (fst p) (snd p).

End Polymorphism.

Module Church.

(* We can represent a natural number n as a function that takes
a function f as a parameter and returns f iterated n times. *)
Definition cnat :=
forall X : Type, (X -> X) -> X -> X.
(*the first argument is a function, the second argument is a variable, the third is the output *)

Check cnat.

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition three : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f (f x)).

(* church_succ *)
(* n X f x gives the natural number n corresponding to the church numeral.
To get its successor we apply f on that term. *)
Definition succ (n : cnat) : cnat :=
  fun (X : Type) (f: X -> X) (x : X) => f (n X f x).

Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.
Example succ_2 : succ one = two.
Proof. reflexivity. Qed.
Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

(* church_plus *)
(* m X f x gives the natural number m corresponding to the church numeral.
Thus, we need to apply f n more times to the number we just got.*)
Definition plus (n m : cnat) : cnat :=
  fun (X : Type) (f: X-> X) (x : X) => (n X f (m X f x)).

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.
Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.
Example plus_3 : plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

(* church_mult *)
(*    n * m = m + m + .. + m is just adding the number m, n times *)
Definition mult (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => (n X (m X f) x).
Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.
Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.
Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

(* church_exp *)
Definition exp (n m : cnat) : cnat := (* returns n^m *)
  fun (X : Type) (f : X -> X) (x : X) => (m (X -> X) (n X) f) x.
(*source: https://www.ps.uni-saarland.de/courses/sem-ws13/files/notes.pdf *)
(* this was by far the hardest function I had to implement in Coq *)

Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.
Example exp_2 : exp three zero = one.
Proof. reflexivity. Qed.
Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

End Church.


Require Export P06.

(** Use induction to prove this simple fact about [double]: *)
Print double.

Theorem plus_double_comm : forall n m : nat,
  double (n + m) = double n + double m.
Proof.
  exact FILL_IN_HERE.
Qed.


(** 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.

Definition synth (y : natural) (lf1 : natural) : natural := plus Zero lf1.


Require Import Id.
Require Import Arith Arith.EqNat.
Require Import Omega.

(* Lambda term definition *)
Inductive term : Type :=
    | Var : id -> term
    | App : term -> term -> term
    | Lam : id -> term -> term.

Hint Constructors term.

Definition x := (Id 1).
Definition y := (Id 2).
Definition z := (Id 3).

Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Fixpoint height t :=
  match t with
  | Var _   => 0
  | App m n => 1 + max (height m) (height n)
  | Lam _ m => 1 + height m
  end.

Lemma max_lemma : forall x y z, max x y = z -> z = x \/ z = y.
Proof.
  intros. destruct (Max.max_dec x0 y0); subst; auto.
Qed.

Lemma induction_by_height :
  forall (P : term -> Prop),
  (forall t, height t = 0 -> P t) ->
  (forall n t, height t = n -> P t -> (forall t', height t' = n+1 -> P t')) ->
  (forall t, P t).
Proof.
  intros.
  induction t.
  - auto.
  - destruct (max_lemma (height t1) (height t2) (height (App t1 t2) - 1)).
    + simpl. omega.
    + specialize (H0 (height t1) t1).
      assert (height (App t1 t2) = height t1 + 1). { rewrite <- H1. simpl. omega. }
      clear H1.
      assert (forall t' : term, height t' = height t1 + 1 -> P t') by auto.
      specialize (H1 (App t1 t2)). auto.
    + specialize (H0 (height t2) t2).
      assert (height (App t1 t2) = height t2 + 1). { rewrite <- H1. simpl. omega. }
      clear H1.
      assert (forall t' : term, height t' = height t2 + 1 -> P t') by auto.
      specialize (H1 (App t1 t2)). auto.

  - specialize (H0 (height t) t).
    assert (height (Lam i t) = height t + 1). { simpl. omega. }
    assert (forall t' : term, height t' = height t + 1 -> P t') by auto.
    specialize (H2 (Lam i t)). auto.
Qed.


Require Import Omega List.

Set Implicit Arguments.

Definition classicalProp P := P \/ ~ P.

Ltac applyExists :=
  match goal with
    | H: exists _, _ |- _ => let x := fresh in
                               let y := fresh in
                                 destruct H as [x y]; exists x
  end.

Ltac destructAll :=
  match goal with
    | [|- context [match ?P with _ => _ end] ] => destruct P
    | [_:context [match ?P with _ => _ end] |- _] => destruct P
  end.

Ltac diff t1 t2 cond :=
  remember (t2 - t1) as td eqn:Heqtd;
  assert (t2eq: t2 = t1 + td) by omega;
  rewrite t2eq in *; clear t2eq Heqtd t2 cond.

Ltac simplArith :=
  repeat match goal with
           | [|- context [?x + 0]] => assert (H: x+0 = x) by omega; rewrite H; clear H
           | [|- context [?x + S ?y]] => assert (H: x+S y = S(x+y)) by omega; rewrite H; clear H
           | [H: context [?x + 0] |- _ ] => assert (L: x+0=x) by omega; rewrite L in H; clear L
           | [H: context [?x + S ?y]|- _ ] => assert (L: x+S y=S(x+y)) by omega; rewrite L in H; clear L
         end.

Section StrongInd1.
  Variable P: nat -> Type.
  Hypothesis case_0: P 0.
  Hypothesis case_n: forall t, (forall ti, ti <= t -> P ti) -> P (S t).

  Theorem strong_ind' t: P t.
  Proof.
    assert (q0: forall ti, ti <= 0 -> P ti) by
        (intros ti ti_le_0; assert (rew: ti = 0) by omega; rewrite rew; assumption).
    assert (qIHt: forall t, (forall ti, ti <= t -> P ti) -> (forall ti, ti <= S t -> P ti)).
    intros t0 lt_t0.
    specialize (case_n lt_t0).
    intros ti ti_le_S_t0.
    pose proof (le_lt_eq_dec ti (S t0) ti_le_S_t0) as options.
    destruct options as  [hyp|new].
    firstorder.
    rewrite new.
    assumption.
    assert (Hyp: forall t, (forall ti, ti <= t -> P ti)) by (
                                                            induction t0; firstorder).
    specialize (Hyp t t).
    assert (fct: t <= t) by omega.
    firstorder.
  Qed.
End StrongInd1.

Section StrongInd2.
  Variable P: nat -> Type.
  Hypothesis case_n: forall t, (forall ti, ti < t -> P ti) -> P t.
  Theorem strong_ind t: P t.
  Proof.
    assert (case0: P 0).
    specialize (@case_n 0).
    assert (ez: forall ti, ti < 0 -> P ti) by (intros ti cond; assert False by omega;
                                               intuition).
    apply (@case_n ez).
    assert (casen: forall t, (forall ti, ti <= t -> P ti) -> P (S t)).
    intros t0 cond.
    assert (cond2: forall ti, ti < S t0 -> P ti) by (intros ti cond2;
                                                     assert (ti <= t0) by omega;
                                                     intuition).
    apply (case_n cond2).
    apply (strong_ind' _ case0 casen t).
  Qed.
End StrongInd2.

Section List.
  Variable A: Set.
  Variable P: A -> Prop.
  Variable ls: list A.

  Hypothesis exOrNot: forall x, In x ls -> P x \/ ~ P x.

  Theorem exOrNotforall:
    (exists x, In x ls /\ P x) \/ forall x, In x ls -> ~ P x.
  Proof.
    induction ls.
    intuition.
    simpl in *.
    assert (H: forall x, In x l -> P x \/ ~ P x).
    intros x inxl.
    assert (arg: a = x \/ In x l) by intuition.
    apply (exOrNot _ arg).
    specialize (IHl H).
    destruct IHl.
    destruct H0 as [x inxl px].
    left.
    exists x.
    intuition.
    assert (arg: a = a \/ In a l) by intuition.
    specialize (exOrNot a arg).
    destruct exOrNot.
    left.
    exists a.
    intuition.
    right.
    unfold not.
    intros x cond px.
    destruct cond.
    rewrite H2 in *.
    intuition.
    apply (H0 _ H2 px).
  Qed.
End List.


(** Lemmas and tactics for working with and solving goals related to
    non-membership in finite sets.  The main tactic of interest here
    is [notin_solve].

    Authors: Arthur Charguéraud and Brian Aydemir. *)

Set Implicit Arguments.
Require Import FSetInterface.

(* *********************************************************************** *)
(** * Implementation *)

Module Notin (X : FSetInterface.S).

Import X.

(* *********************************************************************** *)
(** ** Facts about set (non-)membership *)

(*
Lemma in_singleton : forall x,
  In x (singleton x).
Proof.
  intros x.
Qed.
*)

Lemma notin_empty : forall x,
  ~ In x empty.
Proof.
  auto using empty_1.
Qed.

Lemma notin_union : forall x E F,
  ~ In x E -> ~ In x F -> ~ In x (union E F).
Proof.
  intros x E F H J K.
  destruct (union_1 K); intuition.
Qed.

Lemma elim_notin_union : forall x E F,
  ~ In x (union E F) -> (~ In x E) /\ (~ In x F).
Proof.
  intros x E F H. split; intros J; contradiction H.
  auto using union_2.
  auto using union_3.
Qed.

Lemma notin_singleton : forall x y,
  ~ E.eq x y -> ~ In x (singleton y).
Proof.
  intros x y H J. assert (K := singleton_1 J). intuition.
Qed.

Lemma elim_notin_singleton : forall x y,
  ~ In x (singleton y) -> ~ E.eq x y.
Proof.
  intros x y H J. contradiction H. apply X.singleton_2. apply E.eq_sym. apply J.
Qed.

Lemma elim_notin_singleton' : forall x y,
  ~ In x (singleton y) -> x <> y.
Proof.
  intros. unfold not. intros e. assert (~ E.eq x y). contradiction H. apply X.singleton_2. rewrite <- e. apply E.eq_refl.
  subst. intuition.
Qed.

Lemma notin_singleton_swap : forall x y,
  ~ In x (singleton y) -> ~ In y (singleton x).
Proof.
  intros.
  assert (Q := elim_notin_singleton H).
  auto using singleton_1.
Qed.

(* *********************************************************************** *)
(** ** Rewriting non-membership facts *)

Lemma notin_singleton_rw : forall x y,
  ~ In x (singleton y) <-> ~ E.eq x y.
Proof.
  intros. split.
    auto using elim_notin_singleton.
    auto using notin_singleton.
Qed.

(* *********************************************************************** *)
(** ** Tactics *)

(** The tactic [notin_simpl_hyps] destructs all hypotheses of the form
    [(~ In x E)], where [E] is built using only [empty], [union], and
    [singleton]. *)

Ltac notin_simpl_hyps :=
  try match goal with
        | H: In ?x ?E -> False |- _ =>
          change (~ In x E) in H;
          notin_simpl_hyps
        | H: ~ In _ empty |- _ =>
          clear H;
          notin_simpl_hyps
        | H: ~ In ?x (singleton ?y) |- _ =>
          let F1 := fresh in
          let F2 := fresh in
          assert (F1 := @elim_notin_singleton x y H);
          assert (F2 := @elim_notin_singleton' x y H);
          clear H;
          notin_simpl_hyps
        | H: ~ In ?x (union ?E ?F) |- _ =>
          destruct (@elim_notin_union x E F H);
          clear H;
          notin_simpl_hyps
      end.

(** The tactic [notin_solve] solves goals of them form [(x <> y)] and
    [(~ In x E)] that are provable from hypotheses of the form
    destructed by [notin_simpl_hyps]. *)

Ltac notin_solve :=
  notin_simpl_hyps;
  repeat (progress (  apply notin_empty
                   || apply notin_union
                   || apply notin_singleton));
  solve [ trivial | congruence | intuition auto ].

(* *********************************************************************** *)
(** ** Examples and test cases *)

Lemma test_notin_solve_1 : forall x E F G,
  ~ In x (union E F) -> ~ In x G -> ~ In x (union E G).
Proof.
  intros. notin_solve.
Qed.

(*
Lemma test_notin_solve_2 : forall x y E F G,
  ~ In x (union E (union (singleton y) F)) -> ~ In x G ->
  ~ In x (singleton y) /\ ~ In y (singleton x).
Proof.
  intros. split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_3 : forall x y,
  ~ E.eq x y -> ~ In x (singleton y) /\ ~ In y (singleton x).
Proof.
  intros. split. notin_solve. notin_solve.
Qed.
*)

Lemma test_notin_solve_4 : forall x y E F G,
  ~ In x (union E (union (singleton x) F)) -> ~ In y G.
Proof.
  intros. notin_solve.
Qed.

(*
Lemma test_notin_solve_5 : forall x y E F,
  ~ In x (union E (union (singleton y) F)) -> ~ In y E ->
  ~ E.eq y x /\ ~ E.eq x y.
Proof.
  intros. split. notin_solve. notin_solve.
Qed.
*)

End Notin.


Inductive AExp : Type :=
| ANum  : nat  -> AExp
| AVar  : nat -> AExp
| APlus  : AExp -> AExp -> AExp
| AMinus : AExp -> AExp -> AExp
| AMult  : AExp -> AExp -> AExp.

Inductive BExp : Type :=
| BTrue  : BExp
| BFalse : BExp
| BLess  : AExp -> AExp -> BExp.

Notation "e1 :<: e2" := (BLess e1 e2) (at level 40, left associativity).
Notation "e1 :+: e2" := (APlus e1 e2) (at level 40, left associativity).
Notation "e1 :-: e2" := (AMinus e1 e2) (at level 40, left associativity).
Notation "e1 :*: e2" := (AMult e1 e2) (at level 40, left associativity).


Require Import Logic.Axiom.LEM.

Require Import Logic.Fol.Syntax.

Require Import Logic.Set.Set.
Require Import Logic.Set.Elem.
Require Import Logic.Set.Equal.

Require Import Logic.Lang1.Syntax.
Require Import Logic.Lang1.Semantics.
Require Import Logic.Lang1.Environment.

(* Theorem 'unionAxiom' expressed in set theory abstract syntax.                *)
(* This formulation is correct provided the variables n m p q are distinct.     *)

Definition unionAxiomF (n m p q:nat) : Formula :=
    All n (Exi m (All p (Iff (Elem p m) (Exi q (And (Elem p q) (Elem q n)))))).

(* Evaluating unionAxiomF in any environment 'yields' the theorem unionAxiom.   *)
Lemma evalUnionAxiomF : LEM -> forall (e:Env) (n m p q:nat),
    m <> n ->
    p <> n ->
    p <> m ->
    q <> n ->
    q <> m ->
    q <> p ->
    eval e (unionAxiomF n m p q)
        <->
    forall (x:set), exists (y:set), forall (z:set),
        z :: y <-> exists (u:set), z :: u /\ u :: x.
Proof.
    intros L e n m p q Hmn Hpn Hpm Hqn Hqm Hqp.
    unfold unionAxiomF. rewrite evalAll. split; intros H x.
    - remember (H x) as H' eqn:E. clear E. clear H. rewrite evalExi in H'.
      destruct H' as [y H]. rewrite evalAll in H. exists y. intros z.
      remember (H z) as H' eqn:E. clear E. clear H. rewrite evalIff in H'.
      remember (bind e n x) as e1 eqn:E1. remember (bind e1 m y) as e2 eqn:E2.
      rewrite evalElem in H'. rewrite evalExi in H'. rewrite bindSame in H'.
      rewrite bindDiff in H'. destruct H' as [H1 H2]. split; intros H0.
        + rewrite E2 in H1. rewrite bindSame in H1.
          remember (H1 H0) as H3 eqn:E. clear E. clear H1.
          destruct H3 as [u H3]. exists u. rewrite evalAnd in H3.
          rewrite evalElem in H3. rewrite evalElem in H3.
          rewrite <- E2 in H3. remember (bind e2 p z) as e3 eqn:E3.
          rewrite bindSame in H3. rewrite bindDiff in H3. rewrite bindDiff in H3.
          rewrite E3 in H3. rewrite bindSame in H3. rewrite bindDiff in H3.
          rewrite E2 in H3. rewrite bindDiff in H3. rewrite E1 in H3.
          rewrite bindSame in H3.
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }

        + rewrite E2 in H2. rewrite bindSame in H2. apply H2.
          destruct H0 as [u H3]. exists u. rewrite evalAnd, evalElem, evalElem.
          rewrite <- E2. remember (bind e2 p z) as e3 eqn:E3.
          rewrite bindSame, bindDiff, bindDiff, E3, bindSame, bindDiff, E2.
          rewrite bindDiff, E1, bindSame.
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
        + assumption.
        + assumption.
        + assumption.
        + assumption.
    - remember (H x) as H' eqn:E. clear E. clear H. destruct H' as [y H].
      rewrite evalExi. exists y. rewrite evalAll. intros z.
      rewrite evalIff, evalElem, evalExi.
      remember (bind e n x) as e1 eqn:E1. remember (bind e1 m y) as e2 eqn:E2.
      rewrite bindSame, bindDiff, E2, bindSame. split; intros H'.
        + destruct (H z) as [H1 H2]. destruct (H1 H') as [u H3]. exists u.
          rewrite evalAnd, evalElem, evalElem, <- E2.
          remember (bind e2 p z) as e3 eqn:E3.
          rewrite bindSame, bindDiff, E3, bindSame, bindDiff, bindDiff, E2.
          rewrite bindDiff, E1, bindSame.
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
        + destruct (H z) as [H1 H2]. apply H2. destruct H' as [u H3]. exists u.
          rewrite evalAnd in H3. rewrite evalElem in H3. rewrite evalElem in H3.
          rewrite <- E2 in H3. remember (bind e2 p z) as e3 eqn:E3.
          rewrite bindSame in H3. rewrite bindDiff in H3. rewrite bindDiff in H3.
          rewrite E3 in H3. rewrite bindSame in H3. rewrite bindDiff in H3.
          rewrite E2 in H3. rewrite bindDiff in H3. rewrite E1 in H3.
          rewrite bindSame in H3.
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
            { assumption. }
        + assumption.
        + assumption.
        + assumption.
        + assumption.
Qed.


Require Import Iron.Data.List.Base.
Require Import Iron.Data.List.Map.
Require Import Omega.

Lemma match_option
 : forall {A} {B} (f: A -> B) (xs: list A) ix y
 , f (match get ix xs         with | Some x => x | None  => y   end)
 =   (match get ix (map f xs) with | Some x => x | None  => f y end).
Proof.
 intros.
 remember (get ix xs) as Get.
 destruct Get.
  symmetry in HeqGet.
  apply (get_map f) in HeqGet.
  rewrite HeqGet. auto.

  remember (get ix (map f xs)) as X.
  destruct X.
   symmetry in HeqX.   eapply get_length_more in HeqX.
   symmetry in HeqGet. eapply get_none_length in HeqGet.
   rewrite map_length in HeqX. exfalso. omega.
   auto.
Qed.


(**************************************************************************)
(*                                                                        *)
(*     NDBvector                                                          *)
(*     Copyright (C) 2015                                                 *)
(*                                                                        *)
(*     Tianyi Liang                                                       *)
(*     Chantal Keller                                                     *)
(*                                                                        *)
(*     The University of Iowa                                             *)
(*     LRI - Université Paris Sud - Université Paris Saclay               *)
(*                                                                        *)
(*   TODO: This file is distributed under the terms of SOME licence       *)
(*                                                                        *)
(**************************************************************************)

Require Import List NArith.
Import N.

Local Open Scope list_scope.
Local Open Scope N_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(** Some useful functions *)

Section Map2.

  Variables A B C : Type.
  Variable f : A -> B -> C.

  Fixpoint map2 (l1 : list A) (l2 : list B) : list C :=
    match l1, l2 with
    | b1::tl1, b2::tl2 => (f b1 b2)::(map2 tl1 tl2)
    | _, _ => nil
    end.

End Map2.

(** * Representation of bit vectors and implementation of standard
      operations *)

Module BV.

  (** The type of bit vectors *)
  Definition t := (list bool * N)%type.

  (** The empty bit vector *)
  Definition empty : t := (nil, 0).

  (** Test weither a bit vector is empty *)
  Definition is_empty (bv : t) : bool :=
    let (_, n) := bv in
    match n with
    | N0 => true
    | _ => false
    end.

  (** Test weither a bit vector is zero (this defines the semantics of
      the 0 bit vector) *)
  Definition is_zero (bv : t) : bool :=
    let (b, _) := bv in
    List.forallb (fun x => negb x) b.

  (** Concatenation of two bit vectors *)
  Definition concat (bv1 bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    (b1 ++ b2, n1 + n2).

  (** Bitwise not *)
  Definition not (bv : t) : t :=
    let (b, n) := bv in
    (List.map negb b, n).

  (** Bitwise and *)
  Definition and (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    (map2 andb b1 b2, n1).

  (** Bitwise or *)
  Definition or (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    (map2 orb b1 b2, n1).

  (** Bitwise xor *)
  Definition xor (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    (map2 xorb b1 b2, n1).

  (** Lower weight bit *)
  Definition lower (bv : t) : bool :=
    let (b, _) := bv in
    List.hd false b.

  (** Higher weight bit *)
  Definition high (bv : t) : bool :=
    let (b, _) := bv in
    List.last b false.

  (** Left shift *)
  Definition shiftleft (bv : t) : t :=
    let (b, n) := bv in
    (false::(List.removelast b), n).

  (** Right shift *)
  Definition shiftright (bv : t) : t :=
    let (b, n) := bv in
    ((List.tl b) ++ (false::nil), n).

  (** Left shift of [n] bits *)
  Fixpoint shiftleft_n (bv : t) (n : nat) : t :=
    match n with
      | O => bv
      | S n2 => shiftleft_n (shiftleft bv) n2
    end.

  (** Right shift of [n] bits *)
  Fixpoint shiftright_n (bv : t) (n : nat) : t :=
    match n with
      | O => bv
      | S n2 => shiftright_n (shiftright bv) n2
    end.

  (** Computes the [i]th bit *)
  Definition bb_nth (i : nat) (bv : t) : bool :=
    let (b, _) := bv in
    nth i b false.

  (** Computation of the unsigned integer represented by a bit vector *)
  Fixpoint b2p (b : list bool) : option positive :=
    match b with
    | nil => None
    | false::b =>
      match b2p b with
      | Some p => Some (xO p)
      | None => None
      end
    | true::b =>
      match b2p b with
      | Some p => Some (xI p)
      | None => Some xH
      end
    end.

  Definition bv2n (bv : t) : N :=
    let (b, _) := bv in
    match b2p b with
    | None => N0
    | Some p => Npos p
    end.

  (** Computation of the bit vector representing an integer *)
  Fixpoint p2bv (p : positive) : t :=
    match p with
    | xO p =>
      let (b,n) := p2bv p in
      (false::b, n+1)
    | xI p =>
      let (b,n) := p2bv p in
      (true::b, n+1)
    | xH => (true::nil, 1)
    end.

  Definition n2bv (n : N) : t :=
    match n with
    | N0 => (false::nil, 1)
    | Npos p => p2bv p
    end.

  Definition n2b (n : N) : list bool :=
    let (b, _) := n2bv n in b.

  (* We may want to change the definition of arithmetic operations *)
  (** Addition *)
  Definition add (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n3 := (bv2n bv1) in
    let n4 := (bv2n bv2) in
    let n5 := (n3 + n4) in
    let b3 := (n2b n5) in
    (b3, n1).

  (** Subtraction *)
  Definition sub (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n3 := (bv2n bv1) in
    let n4 := (bv2n bv2) in
    let n5 := (n3 - n4) in
    let b3 := (n2b n5) in
    (b3, n1).

  (** Multiplication *)
  Definition mul (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n3 := (bv2n bv1) in
    let n4 := (bv2n bv2) in
    let n5 := (n3 * n4) in
    let b3 := (n2b n5) in
    (b3, n1).

  (** Negation *)
  Definition neg (bv1 : t) (n : N) : t :=
    let (b1, n1) := bv1 in
    let n2 := 2 ^ n in
    let n3 := (bv2n bv1) in
    let n4 := n2 - n3 in
    ((n2b n4), n).

  (** Division *)
  Definition udiv (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n4 := (bv2n bv2) in
    match n4 with
      | 0 => (nil, 0)
      | _ =>
      let n3 := (bv2n bv1) in
      ((n2b (n3 / n4)), n1)
    end.

  (** Reminder *)
  Definition urem (bv1 : t) (bv2 : t) : t :=
    let (b1, n1) := bv1 in
    let (b2, n2) := bv2 in
    let n4 := (bv2n bv2) in
    match n4 with
      | 0 => (nil, 0)
      | _ =>
      let n3 := (bv2n bv1) in
      ((n2b (n3 mod n4)), n1)
    end.

  (** Unsigned less than *)
  Definition ult (bv1 : t) (bv2 : t) :=
    let n1 := (bv2n bv1) in
    let n2 := (bv2n bv2) in
    (n1 < n2).

  (** Drops the [n] bits of lowest weight *)
  Fixpoint drop_n (l : list bool) (n : nat) : list bool :=
    match n with
      | O => l
      | S n2 => drop_n (@List.tl bool l) n2
    end.

  (** Keep the [n] bits of lowest weight *)
  Fixpoint first_n (l : list bool) (n : nat) : list bool :=
    match n with
      | O => nil
      | S n2 =>
      match l with
        | nil => nil
        | x :: l2 => x :: (first_n l2 n2)
      end
    end.

  (** Extracts the bits between i (included) and j (excluded) *)
  Definition extract (l : list bool) (i : nat) (j : nat) : list bool :=
    let l2 := drop_n l i in
    (first_n l2 j).

End BV.

Module BVProof.

  Import BV.

  (** Bit vectors are well-founded when their length match the length of their list *)
  Definition wf (bv:t) : Prop :=
     let (b,n) := bv in N.of_nat (length b) = n.

  (** All the operations preserve well-foundness *)

  Lemma empty_wf : wf empty.
  Proof. reflexivity. Qed.

  Lemma concat_wf : forall (bv1 bv2:t), wf bv1 -> wf bv2 -> wf (concat bv1 bv2).
  Proof.
    intros [b1 n1] [b2 n2] H1 H2.
    simpl.
    rewrite app_length.
    rewrite Nat2N.inj_add.
    simpl in H1. simpl in H2.
    rewrite H1. rewrite H2.
    reflexivity.
  Qed.

  (** Auxiliary lemmas *)

  Lemma nth_appendl A : forall (l1 l2:list A) (i:nat) (d:A),
    (i < length l1)%nat -> nth i (l1 ++ l2) d = nth i l1 d.
  Proof.
    induction l1 as [ |a l1 IHl1].
    - simpl.
      intros l2 i d H. elim (Lt.lt_n_0 _ H).
    - simpl. intros l2 [ |i] d Hi.
      * reflexivity.
      * apply IHl1. apply Lt.lt_S_n. assumption.
  Qed.

  Lemma Nat2N_inj_lt i j :
    (of_nat i < of_nat j) -> (i < j)%nat.
  Proof.
    now rewrite Compare_dec.nat_compare_lt, Nat2N.inj_compare.
  Qed.

  (** Properties of the operations on well-founded bit vectors *)

  Lemma nth_concat_l : forall(bv1 bv2:t) (i : nat),
    let (b1, n1) := bv1 in
    wf bv1 -> wf bv2 -> (of_nat i < n1) -> bb_nth i (concat bv1 bv2) = bb_nth i bv1.
  Proof.
    intros [b1 n1] [b2 n2]. simpl. intros i H1 H2 Hi.
    rewrite nth_appendl.
    - reflexivity.
    - rewrite <- H1 in Hi.
      apply Nat2N_inj_lt.
      assumption.
  Qed.

End BVProof.


(* https://plv.csail.mit.edu/blog/alectryon.html#using-alectryon *)

Require Import List.

Import ListNotations.

(*|
=======
 Title
=======

Prose. *Emphasis*; **strong emphasis**; ``code``; `coq code`; `link <url>`__.
|*)

(* regular comment *)

(** Coqdoc comment *)

(*|
.. note::

   More text.

.. coq::
|*)
Lemma app_nil : forall T (l1 : list T), l1 ++ [] = l1.
  (* C-c C-a TAB (dans Emacs/PG) *)
  intros T l1.
  induction l1.
  { easy. }
  simpl; rewrite IHl1.
  easy.
Qed.


(** * Examples of calculational proof *)
Require Import CalcNotations CalcNotationsTactic.
Require Import Arith.

Section Examples.

(** This is a notation for lifting rewriting tactic to the term level. It tries both directions and proves the goal by reflexivity afterwards *)
Notation "{{ f }}" := (ltac:((rewrite f;reflexivity) || (rewrite <-f; reflexivity))) (at level 70) : calc_scope.
Notation "{{ <-- f }}" := (ltac:((rewrite <-f; reflexivity))) (at level 70) : calc_scope.
Notation "{{ --> f }}" := (ltac:((rewrite f; reflexivity))) (at level 70) : calc_scope.

(** Terms, witnessing the equality steps (the part that goes after "by") can be built completely, or one can leave underscores and use [Program Definition] if necessary. Also, it is possible to use rewriting using the {{ some_lemma }} notation *)

(** This proof is complete and we don't need to use [Program Definition] *)

Open Scope calc_scope.

Variables n m k a b : nat.

(** ** Proofs using the term notation *)

Definition ex_nat1 : (n + m) + k = k + n + m :=
  calc (n + m) + k = k + (n + m) by Nat.add_comm _ _ ;
     _             = k + n + m  by Nat.add_assoc _ _ _
  end.

(** Note that the second item in the chain of steps starts with the underscore. This term usually can be inferred by Coq. We know that the this underscore must be filled-in with the "target" from the previous step, but there is no way to encode this due to the limitations of recursive notations in Coq *)

(** In this example we use underscores for all terms witnessing the steps *)
Program Definition ex_nat2 : (n + m) + k = (m + k) + n :=
  calc (n + m) + k = n + (m + k) by _ ;
      _           = (m + k) + n by _
  end.
Next Obligation.
  symmetry. apply Nat.add_assoc.
Defined.
Next Obligation.
  apply Nat.add_comm.
Defined.

(** In this example we use use rewriting to prove steps by providing lemmas in double curly braces *)
Definition ex_nat3 : n + (m + 0) + k = k + n + m :=
  calc n + (m + 0) + k = (n + m) + k by {{ plus_n_O }} ;
    _                  = k + (n + m) by {{ Nat.add_comm }} ;
    _                  = k + n + m by {{ Nat.add_assoc }}
end.

(** If one needs more complex manipulations, the "ltac:()" notation can be used directly to justify the reasoning steps *)

Program Definition ex_nat4 : (a + b) * (a + b) = a^2 + 2*a*b + b^2 :=
  calc (a + b) * (a + b)
       = a*a + b*a + a*b + b*b by ltac:(ring);
    _  = a*a + 2*a*b + b*b by ltac:(ring);
    _  = a^2 + 2*a*b + b^2 by ltac:(repeat rewrite Nat.pow_2_r;auto)
end.

(** ** Proofs using the tactic notation *)

(** This notation is sutable for interactive proofs. Can be used at any point in a proof script *)

Lemma ex_nat5 : n + (m + 0) + k = k + n + m.
Proof.
  calc (n + (m + 0) + k) = ((n + m) + k) by now rewrite <- plus_n_O.
    _                    = (k + (n + m)) by now rewrite Nat.add_comm.
    _                    = (k + n + m) by now rewrite Nat.add_assoc
  end.
Qed.

End Examples.

Module ExamplesFail.
  Require Import CalcNotationsRecursive.
  Open Scope calc_scope.

(** In this example, [ltac:(ring)] cannot solve the steps because the "middle points" are still uninstantiated existential variables. One can see the goal that [ltac:()] sees by using this tactic expression:ltac:(match goal with [_ : _ |- ?p] => fail 0 p end); *)
Fail Definition ex_nat_ring_fail a b : (a + b) * (a + b) = a^2 + 2*a*b + b^2 :=
  calc (a + b) * (a + b)
       = a*a + b*a + a*b + b*b by ltac:(ring);
    _  = a*a + 2*a*b + b*b by ltac:(ring);
    _  = a^2 + 2*a*b + b^2 by ltac:(repeat rewrite Nat.pow_2_r;auto)
end.

(** But it's absolutely fine to leave underscores in place of proofs and fill them in later *)
Program Definition ex_nat_ring_success a b : (a + b) * (a + b) = a^2 + 2*a*b + b^2 :=
  calc (a + b) * (a + b)
       = a*a + b*a + a*b + b*b by ltac:(ring);
    _  = a*a + 2*a*b + b*b by _;
    _  = a^2 + 2*a*b + b^2 by ltac:(repeat rewrite Nat.pow_2_r;auto)
end.
Next Obligation.
  ring.
Qed.

End ExamplesFail.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

(** Common definitions of real functions sequences. *)
Require Import Reals.
Require Import Rsequence_def.

Declare Scope RFseq_scope.
Delimit Scope RFseq_scope with Rseq.

Local Open Scope R_scope.
Local Open Scope RFseq_scope.

Implicit Type n : nat.
Implicit Type fn gn : nat -> R -> R.
Implicit Type f g : R -> R.

(** * Morphism of functions on R -> R to sequences. *)

Definition RFseq_plus fn gn n := (fn n + gn n)%F.
Definition RFseq_mult fn gn n := (fn n * gn n)%F.
Definition RFseq_opp fn n := (fun x => Ropp (fn n x))%F.
Definition RFseq_inv fn n := (fun x => Rinv (fn n x))%F.

Infix "+" := RFseq_plus : RFseq_scope.
Infix "*" := RFseq_mult : RFseq_scope.
Notation "- u" := (RFseq_opp u) : RFseq_scope.
Notation "/ u" := (RFseq_inv u) : RFseq_scope.

Definition RFseq_minus fn gn n := (fn n - gn n)%F.
Definition RFseq_div fn gn n := (fn n / gn n)%F.

Infix "-" := RFseq_minus : RFseq_scope.
Infix "/" := RFseq_div : RFseq_scope.

(** * Convergence of functions sequences. *)

Definition RFseq_cv fn f := forall x, Rseq_cv (fun n => fn n x) (f x).
Definition RFseq_cv_interv fn f (lb ub : R) :=
  forall x, lb < x -> x < ub -> Rseq_cv (fun n => fn n x) (f x).

Definition RFseq_cvu fn f (x : R) (r : posreal) := forall eps : R, 0 < eps ->
  exists N : nat, forall n (y : R), (N <= n)%nat -> Boule x r y ->
  R_dist (fn n y) (f y) < eps.


From Coq Require Import
  ZArith.
From DEZ.Has Require Export
  GroupOperation GroupIdentity GroupInverse.
From DEZ.Offers Require Import
  PositivePowers.
From DEZ.ShouldHave Require Import
  AdditiveGroupNotations.

Definition zopr {A : Type} {has_opr : HasOpr A}
  {has_idn : HasIdn A} {has_inv : HasInv A} (n : Z) (x : A) : A :=
  match n with
  | Z0 => 0
  | Zpos p => popr p x
  | Zneg p => - (popr p x)
  end.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import XRbase.
Require Import XRfunctions.
Require Import XRseries.
Require Import XPartSum.
Require Import Omega.
Require Import Setoid Morphisms.
Local Open Scope XR_scope.

Set Implicit Arguments.

Local Open Scope nat_scope.

Lemma plus_S_minus : forall n m : nat, m<=n -> S n = m + S(n - m).
Proof.
  induction n as [ | n i].
  { simpl. intros m le. apply le_n_0_eq in le. subst m. simpl. reflexivity. }
  destruct m.
  { simpl. reflexivity. }
  intros. simpl. rewrite (i m).
  { reflexivity. }
  apply Peano.le_S_n. assumption.
Qed.

Lemma SnPSm_SSnPm : forall n m : nat, S n + S m = S (S n) + m.
Proof.
intros. simpl. rewrite <- plus_n_Sm. reflexivity.
Qed.

Lemma nMSm_nMmM1 : forall n m, n - (S m) = (n - m) - 1.
Proof.
induction n as [ | n i ]. simpl. reflexivity.
intro m. destruct m. simpl. reflexivity.
rewrite Nat.sub_succ.
rewrite (i m). clear i.
rewrite Nat.sub_succ.
reflexivity.
Qed.

Local Close Scope nat_scope.

Section Sigma.

  Variable f : nat -> R.

  Definition sigma (low high:nat) : R :=
    sum_f_R0 (fun k:nat => f (low + k)) (high - low).

  Lemma specific1 : forall (k m:nat),
    sum_f_R0 (fun x:nat => f (S (S k) + x)) m =
    sum_f_R0 (fun x:nat => f (S k + S x))   m.
  Proof.
    intros k m. apply sum_eq. intros i im.
    rewrite <- plus_n_Sm.
    reflexivity.
  Qed.

  Lemma specific2 : forall (k m:nat),
    sum_f_R0 (fun x:nat => f (S (k + x))) m =
    sum_f_R0 (fun x:nat => f (k + S x))   m.
  Proof.
    intros k m. apply sum_eq. intros i im.
    rewrite plus_n_Sm. reflexivity.
  Qed.

  Lemma sigma_S_r : forall (low high:nat),
    (low <= high)%nat ->
    sigma low high + f (S high) = sigma low (S high).
  Proof.
    intros low high h. unfold sigma.
    rewrite <- minus_Sn_m.
    simpl. rewrite <- plus_S_minus.
    reflexivity.
    assumption. assumption.
  Qed.

  Lemma sigma_S_l : forall low high : nat,
    (S low < high)%nat ->
    sigma (S low) high = f (S low) + sigma (S (S low)) high.
  Proof.
    intros low high kh.
    unfold sigma.
    rewrite (Nat.sub_succ_r high (S low)).
    rewrite <- Nat.add_0_r at 2.
    rewrite specific1.
    apply decomp_sum.
    apply lt_minus_O_lt.
    assumption.
  Qed.

  Lemma snn : forall n : nat, sigma n n = f n.
  Proof.
    intro n.
    unfold sigma.
    rewrite <- minus_n_n.
    simpl.
    rewrite <- plus_n_O.
    reflexivity.
  Qed.

  Lemma sigma_0_sumf : forall high :  nat, sigma 0 high = sum_f_R0 f high.
  Proof.
    intro high.
    unfold sigma. simpl. rewrite <- minus_n_O.
    reflexivity.
  Qed.

  Definition shift {T:Type} (f:nat->T) := fun n => f (S n).
  Definition shift' {T:Type} (f:nat->T) (base:nat) := fun n => f (base + S n)%nat.

  Lemma sigma_S_sumf : forall (low high : nat), sigma (S low) high = sum_f_R0 (shift' f low)  (high - S low).
  Proof.
    intros low high.
    unfold sigma. unfold shift'. simpl.
    rewrite specific2. reflexivity.
  Qed.

  Lemma sigma_1_sumf : forall high :  nat, sigma 1 high = sum_f_R0 (shift f) (high-1).
  Proof.
    intro high.
    unfold sigma. simpl. unfold shift.
    reflexivity.
  Qed.

  Lemma decomp_sum_with_shift : forall (An : nat -> R) (N : nat),
       (0 < N)%nat -> sum_f_R0 An N = An 0%nat + sum_f_R0 (shift An) (Nat.pred N).
  Proof.
    apply decomp_sum.
  Qed.

  Theorem sigma_split :
    forall low high k:nat,
      (low <= k)%nat ->
      (k < high)%nat -> sigma low high = sigma low k + sigma (S k) high.
  Proof.
    intros low high k lk kh.
    induction k as [| k i].
    {
      apply le_n_0_eq in lk. (* x <= 0 -> x = 0 *)
      rewrite <- lk. (* low = 0 *)
      rewrite snn.
      rewrite sigma_0_sumf.
      rewrite sigma_1_sumf.
      rewrite decomp_sum_with_shift. (* sum f n = f 0 + sum f' n *)
      {
        rewrite Nat.sub_1_r. (* n - 1 = pred n *)
        reflexivity.
      }
      assumption.
    }
    apply Compare.le_le_S_eq in lk. (* a <= S b -> S a <= S b \/ a = S b *)
    destruct lk as [lk | lk].
    {
      apply Peano.le_S_n in lk. (* S n <= S m -> n <= m *)
      rewrite <- sigma_S_r. (* sum n (S m) = sum n m  + f(S m) *)
      {
        rewrite Rplus_assoc.
        rewrite <- sigma_S_l. (* f n + sum (S n) m = sum n m *)
        {
          apply i. (* induction hypothesis *)
          { assumption. }
          apply lt_trans with (S k).
          { apply lt_n_Sn. }
          assumption.
        }
        assumption.
      }
      assumption.
    }
    rewrite <- lk. (* low = S k *)
    rewrite snn.
    rewrite plus_n_O at 2.
    rewrite sigma_S_sumf.
    simpl.
    rewrite Nat.sub_succ_r. (* n - S m = pred (n - m) *)
    apply decomp_sum.
    apply lt_minus_O_lt. (* 0 < n -m -> n < m *)
    apply le_lt_trans with (S k).
    {
      rewrite lk.
      apply le_n. (* n <= n *)
    }
    assumption.
  Qed.

  Theorem sigma_diff :
    forall low high k:nat,
      (low <= k)%nat ->
      (k < high)%nat -> sigma low high - sigma low k = sigma (S k) high.
  Proof.
    intros low high k H1 H2; symmetry ; rewrite (sigma_split H1 H2).
unfold Rminus.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_l.
reflexivity.
  Qed.

  Theorem sigma_diff_neg :
    forall low high k:nat,
      (low <= k)%nat ->
      (k < high)%nat -> sigma low k - sigma low high = - sigma (S k) high.
  Proof.
    intros low high k H1 H2; rewrite (sigma_split H1 H2).
unfold Rminus.
rewrite Ropp_plus_distr.
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_l.
reflexivity.
  Qed.

  Theorem sigma_first :
    forall low high:nat,
      (low < high)%nat -> sigma low high = f low + sigma (S low) high.
  Proof.
    intros low high H1; generalize (lt_le_S low high H1); intro H2;
      generalize (lt_le_weak low high H1); intro H3;
        replace (f low) with (sigma low low).
    apply sigma_split.
    apply le_n.
    assumption.
    unfold sigma; rewrite <- minus_n_n.
    simpl.
    replace (low + 0)%nat with low; [ reflexivity | ring ].
  Qed.

  Theorem sigma_last :
    forall low high:nat,
      (low < high)%nat -> sigma low high = f high + sigma low (pred high).
  Proof.
    intros low high H1; generalize (lt_le_S low high H1); intro H2;
      generalize (lt_le_weak low high H1); intro H3;
        replace (f high) with (sigma high high).
    rewrite Rplus_comm; cut (high = S (pred high)).
    intro; pattern high at 3; rewrite H.
    apply sigma_split.
    apply le_S_n; rewrite <- H; apply lt_le_S; assumption.
    apply lt_pred_n_n; apply le_lt_trans with low; [ apply le_O_n | assumption ].
    apply S_pred with 0%nat; apply le_lt_trans with low;
      [ apply le_O_n | assumption ].
    unfold sigma; rewrite <- minus_n_n; simpl;
      replace (high + 0)%nat with high; [ reflexivity | ring ].
  Qed.

  Theorem sigma_eq_arg : forall low:nat, sigma low low = f low.
  Proof. apply snn. Qed.

End Sigma.