Require Import XRbase.
Require Import XR_Ifp.
Local Open Scope XR_scope.

Implicit Type r : R.

Definition Rmin (x y:R) : R :=
  match Rle_dec x y with
    | left _ => x
    | right _ => y
  end.

Lemma Rmin_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmin r1 r2).
Proof.
  intros x y p px py.
  unfold Rmin.
  destruct (Rle_dec x y) as [ le | nle ].
  exact px.
  exact py.
Qed.

Lemma Rmin_case_strong : forall r1 r2 (P:R -> Type),
  (r1 <= r2 -> P r1) -> (r2 <= r1 -> P r2) -> P (Rmin r1 r2).
Proof.
  intros x y p hxy hyx.
  unfold Rmin.
  destruct (Rle_dec x y) as [ le | nle ].
  apply hxy. exact le.
  apply hyx.
  left.
  apply Rnot_le_lt.
  exact nle.
Qed.

Lemma Rmin_Rgt_l : forall r1 r2 r, r < Rmin r1 r2 -> r < r1 /\ r < r2.
Proof.
  intros x y z h.
  unfold Rmin in h.
  destruct (Rle_dec x y).
  {
    split.
    { exact h. }
    { destruct r as [ lt | eq ].
      { apply Rlt_trans with x. exact h. exact lt. }
      { subst x. exact h. }
    }
  }
  { apply Rnot_le_lt in n. split.
    { apply Rlt_trans with y. exact h. exact n. }
    { exact h. }
  }
Qed.

Lemma Rmin_Rgt_r : forall r1 r2 r, r < r1 /\ r < r2 -> r < Rmin r1 r2.
Proof.
  intros x y z [hx hy].
  unfold Rmin.
  destruct (Rle_dec x y) as [ h | h ].
  exact hx. exact hy.
Qed.

Lemma Rmin_Rgt : forall r1 r2 r, r < Rmin r1 r2 <-> r < r1 /\ r < r2.
Proof.
  intros x y z.
  split.
  { intro h. apply Rmin_Rgt_l. exact h. }
  { intro h. apply Rmin_Rgt_r. exact h. }
Qed.

Lemma Rmin_l : forall x y:R, Rmin x y <= x.
Proof.
  intros x y.
  unfold Rmin.
  destruct (Rle_dec x y) as [ h | h ].
  right. reflexivity.
  left. apply Rnot_le_lt. exact h.
Qed.

Lemma Rmin_r : forall x y:R, Rmin x y <= y.
Proof.
  intros x y.
  unfold Rmin.
  destruct (Rle_dec x y).
  exact r.
  right. reflexivity.
Qed.

Lemma Rmin_left : forall x y, x <= y -> Rmin x y = x.
Proof.
  intros x y h.
  apply Rmin_case_strong.
  intro same. reflexivity.
  intro converse.
  apply Rle_antisym. exact converse. exact h.
Qed.

Lemma Rmin_right : forall x y, y <= x -> Rmin x y = y.
Proof.
  intros x y h.
  unfold Rmin.
  destruct (Rle_dec x y).
  apply Rle_antisym. exact r. exact h.
  reflexivity.
Qed.

Lemma Rle_min_compat_r : forall x y z, x <= y -> Rmin x z <= Rmin y z.
Proof.
  intros x y z h.
  apply Rmin_case_strong.
  intro hxz. apply Rmin_case_strong.
  intro hyz. exact h.
  intro hzy. exact hxz.
  intro hzx. apply Rmin_case_strong.
  intro hyz. apply Rle_trans with x. exact hzx. exact h.
  intro hzy. right. reflexivity.
Qed.

Lemma Rle_min_compat_l : forall x y z, x <= y -> Rmin z x <= Rmin z y.
Proof.
  intros x y z hxy.
  apply Rmin_case_strong.
  {
    intro hzx. apply Rmin_case_strong.
    {
      intro hzy. right. reflexivity.
    }
    {
      intro hyz. apply Rle_trans with x. exact hzx. exact hxy.
    }
  }
  {
    intro hxz. apply Rmin_case_strong.
    {
      intro hzy. exact hxz.
    }
    {
      intro hyz. exact hxy.
    }
  }
Qed.

Lemma Rmin_comm : forall x y:R, Rmin x y = Rmin y x.
Proof.
  intros x y.
  apply Rmin_case_strong.
  {
    intro hxy. apply Rmin_case_strong.
    {
      intro hyx. apply Rle_antisym. exact hxy. exact hyx.
    }
    {
      intro hxy'. reflexivity.
    }
  }
  {
    intro hyx. apply Rmin_case_strong.
    {
      intro hyx'. reflexivity.
    }
    {
      intro hxy. apply Rle_antisym. exact hyx. exact hxy.
    }
  }
Qed.

Lemma Rmin_stable_in_posreal : forall x y:posreal, R0 < Rmin x y.
Proof.
  intros x y.
  apply Rmin_case.
  apply cond_pos.
  apply cond_pos.
Qed.

Lemma Rmin_pos : forall x y:R, R0 < x -> R0 < y -> R0 < Rmin x y.
Proof.
  intros x y hx hy.
  apply Rmin_case.
  exact hx.
  exact hy.
Qed.

Lemma Rmin_glb : forall x y z:R, z <= x -> z <= y -> z <= Rmin x y.
Proof.
  intros x y z hzx hzy.
  apply Rmin_case.
  exact hzx.
  exact hzy.
Qed.

Lemma Rmin_glb_lt : forall x y z:R, z < x -> z < y -> z < Rmin x y.
Proof.
  intros x y z hzx hzy.
  apply Rmin_case.
  exact hzx. exact hzy.
Qed.

Definition Rmax (x y:R) : R :=
  match Rle_dec x y with
    | left _ => y
    | right _ => x
  end.

Lemma Rmax_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmax r1 r2).
Proof.
  intros x y p px py.
  unfold Rmax. destruct (Rle_dec x y) as [ h | h ].
  exact py. exact px.
Qed.

Lemma Rmax_case_strong : forall r1 r2 (P:R -> Type),
  (r2 <= r1 -> P r1) -> (r1 <= r2 -> P r2) -> P (Rmax r1 r2).
Proof.
  intros x y p px py.
  unfold Rmax. destruct (Rle_dec x y) as [ h | h ].
  apply py. exact h.
  apply px.
  apply Rlt_le. apply Rnot_le_lt. exact h.
Qed.

Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2.
Proof.
  intros x y z.
  split.
  {
    intro h. unfold Rmax in h. destruct (Rle_dec x y) as [ h' | h' ].
    right. exact h.
    left. exact h.
  }
  {
    intros [ hzx | hzy ].
    apply Rmax_case_strong.
    {
      intro hyx. exact hzx.
    }
    {
      intro hxy. apply Rle_trans with x. exact hzx. exact hxy.
    }
    apply Rmax_case_strong.
    { intro yx. apply Rle_trans with y. exact hzy. exact yx. }
    { intro hxy. exact hzy. }
  }
Qed.

Lemma Rmax_comm : forall x y:R, Rmax x y = Rmax y x.
Proof.
  intros x y.
  apply Rmax_case_strong;apply Rmax_case_strong;intros.
  apply Rle_antisym;assumption.
  reflexivity.
  reflexivity.
  apply Rle_antisym;assumption.
Qed.

Notation RmaxSym := Rmax_comm (only parsing).

Lemma Rmax_l : forall x y:R, x <= Rmax x y.
Proof.
  intros x y.
  apply Rmax_case_strong.
  intro. right. reflexivity.
  intro;assumption.
Qed.

Lemma Rmax_r : forall x y:R, y <= Rmax x y.
Proof.
  intros x y.
  apply Rmax_case_strong.
  intro;assumption.
  intro. right. reflexivity.
Qed.

Notation RmaxLess1 := Rmax_l (only parsing).
Notation RmaxLess2 := Rmax_r (only parsing).

Lemma Rmax_left : forall x y, y <= x -> Rmax x y = x.
Proof.
  intros x y h.
  apply Rmax_case_strong.
  intro;reflexivity.
  intro h'. apply Rle_antisym;assumption.
Qed.

Lemma Rmax_right : forall x y, x <= y -> Rmax x y = y.
Proof.
  intros x y h.
  apply Rmax_case_strong.
  intro h'. apply Rle_antisym;assumption.
  reflexivity.
Qed.

Lemma Rle_max_compat_r : forall x y z, x <= y -> Rmax x z <= Rmax y z.
Proof.
  intros x y z hxy.
  apply Rmax_case_strong;apply Rmax_case_strong.
  intros hzy hzx. exact hxy.
  intros hyz hzx. apply Rle_trans with y;assumption.
  intros hzy hxz. exact hzy.
  intros hyz hxz. right. reflexivity.
Qed.

Lemma Rle_max_compat_l : forall x y z, x <= y -> Rmax z x <= Rmax z y.
Proof.
  intros x y z hxy.
  apply Rmax_case_strong;apply Rmax_case_strong.
  intros;right;reflexivity.
  intros;assumption.
  intros hyz hzx. apply Rle_trans with y;assumption.
  intros;assumption.
Qed.

Lemma RmaxRmult :
  forall (p q:R) r, R0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
Proof.
  intros x y z h.
  apply Rmax_case_strong;apply Rmax_case_strong.
  { intros;reflexivity. }
  {
    intros hxy hyx.
    apply Rle_antisym.
    apply Rmult_le_compat_l.
    exact h. exact hxy. exact hyx.
  }
  {
    intros hyx hxy.
    apply Rle_antisym.
    apply Rmult_le_compat_l.
    exact h. exact hyx. exact hxy.
  }
  { intros;reflexivity. }
Qed.

Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < R0.
Proof.
  intros x y.
  apply Rmax_case.
  apply cond_neg.
  apply cond_neg.
Qed.

Lemma Rmax_lub : forall x y z:R, x <= z -> y <= z -> Rmax x y <= z.
Proof.
  intros x y z hxz hyz.
  apply Rmax_case;assumption.
Qed.

Lemma Rmax_lub_lt : forall x y z:R, x < z -> y < z -> Rmax x y < z.
Proof.
  intros x y z hxz hyz.
  apply Rmax_case;assumption.
Qed.

Lemma Rmax_Rlt : forall x y z,
  Rmax x y < z <-> x < z /\ y < z.
Proof.
  intros x y z.
  apply Rmax_case_strong.
  {
    intro hyx. split.
    {
      intro hxz. split.
      { exact hxz. }
      {
        destruct hyx as [ hyx | hyx ].
        apply Rlt_trans with x;assumption.
        subst y. exact hxz.
      }
    }
    {
      intros [ hxz hyz ].
      exact hxz.
    }
  }
  {
    intro hxy.
    split.
    {
      intro hyz. split.
      {
        destruct hxy as [ hlt | heq ].
        apply Rlt_trans with y;assumption.
        subst y. assumption.
      }
      { assumption. }
    }
    { intros [ hxz hyz ] ; assumption. }
  }
Qed.

Lemma Rmax_neg : forall x y:R, x < R0 -> y < R0 -> Rmax x y < R0.
Proof.
  intros x y hx hy.
  apply Rmax_case;assumption.
Qed.

Lemma Rcase_abs : forall r, {r < R0} + {R0 <= r}.
Proof.
  intro x.
  destruct (total_order_T x R0) as [ [ hlt | heq ] | hgt ].
  left. assumption.
  subst x. right. right. reflexivity.
  right;left;assumption.
Qed.

Definition Rabs r : R :=
  match Rcase_abs r with
    | left _ => - r
    | right _ => r
  end.

Lemma Rabs_R0 : Rabs R0 = R0.
Proof.
  unfold Rabs.
  destruct (Rcase_abs R0).
  rewrite Ropp_0. reflexivity.
  reflexivity.
Qed.

Lemma Rabs_R1 : Rabs R1 = R1.
Proof.
  unfold Rabs.
  destruct (Rcase_abs R1).
  exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with R1. apply Rlt_0_1. assumption.
  reflexivity.
Qed.

Lemma Rabs_no_R0 : forall r, r <> R0 -> Rabs r <> R0.
Proof.
  intros x h eq.
  apply h.
  unfold Rabs in eq.
  destruct (Rcase_abs x).
  apply Rplus_eq_reg_l with (-x).
  rewrite Rplus_opp_l.
  rewrite eq.
  rewrite Rplus_0_l.
  reflexivity.
  exact eq.
Qed.

Lemma Rabs_left : forall r, r < R0 -> Rabs r = - r.
Proof.
  intros x h.
  unfold Rabs. destruct (Rcase_abs x).
  reflexivity.
  destruct r.
  exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x;assumption.
  subst x. rewrite Ropp_0. reflexivity.
Qed.

Lemma Rabs_right : forall r, R0 <= r -> Rabs r = r.
Proof.
  intros x h.
  destruct h as [ h | h ].
  unfold Rabs. destruct (Rcase_abs x).
  exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x;assumption.
  reflexivity.
  subst x.
  exact Rabs_R0.
Qed.

Lemma Rabs_left1 : forall a:R, a <= R0 -> Rabs a = - a.
Proof.
  intros x h.
  destruct h as [ lt | eq ].
  {
    unfold Rabs. destruct (Rcase_abs x).
    reflexivity.
    destruct r as [ lt' | eq' ].
    exfalso. apply Rlt_irrefl with x. apply Rlt_trans with R0;assumption.
    subst x. rewrite Ropp_0. reflexivity.
  }
  subst x. rewrite Ropp_0. exact Rabs_R0.
Qed.

Lemma Rabs_pos : forall x:R, R0 <= Rabs x.
Proof.
  intros x.
  unfold Rabs. destruct (Rcase_abs x).
  left. apply Rplus_lt_reg_l with x. rewrite Rplus_0_r.
  rewrite Rplus_opp_r. exact r.
  exact r.
Qed.

Lemma Rle_abs : forall x:R, x <= Rabs x.
Proof.
  intros x.
  unfold Rabs. destruct (Rcase_abs x).
  left. apply Rlt_trans with R0. exact r.
  apply Rplus_lt_reg_l with x. rewrite Rplus_0_r. rewrite Rplus_opp_r.
  exact r.
  right. reflexivity.
Qed.

Definition RRle_abs := Rle_abs.

Lemma Rabs_le : forall a b, -b <= a <= b -> Rabs a <= b.
Proof.
  intros x y [ hyx hxy ].
  unfold Rabs. destruct (Rcase_abs x).
  apply Rplus_le_reg_r with x.
  rewrite Rplus_opp_l.
  apply Rplus_le_reg_l with (-y).
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_l.
  rewrite Rplus_0_r.
  exact hyx.
  exact hxy.
Qed.

Lemma Rabs_pos_eq : forall x:R, R0 <= x -> Rabs x = x.
Proof.
  intros x h.
  destruct h as [ lt | eq ].
  unfold Rabs. destruct (Rcase_abs x).
  exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x;assumption.
  reflexivity.
  subst x. exact Rabs_R0.
Qed.

Lemma Rabs_Rabsolu : forall x:R, Rabs (Rabs x) = Rabs x.
Proof.
  intro x.
  unfold Rabs.
  destruct (Rcase_abs x).
  destruct (Rcase_abs (-x)).
  exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x.
  apply Rplus_lt_reg_l with (-x). rewrite Rplus_opp_l.
  rewrite Rplus_0_r. exact r0. exact r.
  reflexivity.
  destruct (Rcase_abs x).
  destruct r.
  exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x;assumption.
  subst x. rewrite Ropp_0. reflexivity.
  reflexivity.
Qed.

Lemma Rabs_pos_lt : forall x:R, x <> R0 -> R0 < Rabs x.
Proof.
  intros x h.
  unfold Rabs. destruct (Rcase_abs x).
  apply Rplus_lt_reg_l with x.
  rewrite Rplus_0_r.
  rewrite Rplus_opp_r.
  exact r.
  destruct r.
  exact H.
  subst x. exfalso.
  apply h. reflexivity.
Qed.

Lemma Rabs_minus_sym : forall x y:R, Rabs (x - y) = Rabs (y - x).
Proof.
  intros x y.
  unfold Rabs.
  destruct (Rcase_abs (x-y));destruct (Rcase_abs (y-x));
  unfold Rminus;
  repeat (rewrite Ropp_plus_distr);
  repeat (rewrite Ropp_involutive).
  {
    exfalso.
    unfold Rminus in r, r0.
    apply (Rplus_lt_compat_r y) in r.
    rewrite Rplus_assoc in r.
    rewrite Rplus_opp_l in r.
    rewrite Rplus_0_r in r.
    rewrite Rplus_0_l in r.
    apply (Rplus_lt_compat_r x) in r0.
    rewrite Rplus_assoc in r0.
    rewrite Rplus_opp_l in r0.
    rewrite Rplus_0_l in r0.
    rewrite Rplus_0_r in r0.
    apply Rlt_irrefl with x.
    apply Rlt_trans with y;assumption.
  }
  {
    rewrite (Rplus_comm _ y).
    reflexivity.
  }
  {
    rewrite Rplus_comm.
    reflexivity.
  }
  {
    destruct r.
    {
      destruct r0.
      {
        exfalso.
        unfold Rminus in H.
        unfold Rminus in H0.
        apply (Rplus_lt_compat_r y) in H.
        apply (Rplus_lt_compat_r x) in H0.
        repeat (rewrite Rplus_assoc in H, H0).
        rewrite Rplus_opp_l in H, H0.
        rewrite Rplus_0_l in H, H0.
        rewrite Rplus_0_r in H, H0.
        apply Rlt_irrefl with x.
        apply Rlt_trans with y;assumption.
    }
    unfold Rminus in *.
    apply (Rplus_eq_compat_r x) in H0.
    rewrite Rplus_assoc in H0.
    rewrite Rplus_opp_l in H0.
    rewrite Rplus_0_l in H0.
    rewrite Rplus_0_r in H0.
    subst y.
    rewrite Rplus_comm. reflexivity.
  }
  apply (Rplus_eq_compat_r y) in H.
  unfold Rminus in H.
  rewrite Rplus_assoc in H.
  rewrite Rplus_opp_l in H.
  rewrite Rplus_0_r in H.
  rewrite Rplus_0_l in H.
  subst y.
  reflexivity.
  }
Qed.

Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y.
Proof.
  intros x y.
  unfold Rabs.
  destruct (Rcase_abs x);
  destruct (Rcase_abs y);
  destruct (Rcase_abs (x*y)).
  {
    exfalso.
    apply Rlt_irrefl with (x*y).
    apply Rlt_trans with R0.
    assumption.
    rewrite <- Ropp_involutive with (x*y).
    rewrite Ropp_mult_distr_l.
    rewrite Ropp_mult_distr_r.
    apply Rmult_lt_0_compat.
    apply Rplus_lt_reg_l with x.
    rewrite Rplus_0_r.
    rewrite Rplus_opp_r.
    assumption.
    apply Rplus_lt_reg_l with y.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    assumption.
  }
  {
    rewrite <- Ropp_mult_distr_l.
    rewrite <- Ropp_mult_distr_r.
    rewrite Ropp_involutive.
    reflexivity.
  }
  {
    rewrite Ropp_mult_distr_l.
    reflexivity.
  }
  {
    destruct r1.
    destruct r0.
    exfalso.
    apply Rlt_irrefl with (x*y).
    apply Rlt_trans with R0.
    apply Rplus_lt_reg_l with (- (x*y)).
    rewrite Rplus_opp_l.
    rewrite Rplus_0_r.
    rewrite Ropp_mult_distr_l.
    apply Rmult_lt_0_compat.
    apply Rplus_lt_reg_l with x.
    rewrite Rplus_0_r.
    rewrite Rplus_opp_r.
    assumption.
    assumption.
    assumption.
    subst y. do 2 rewrite Rmult_0_r. reflexivity.
    rewrite <- H. rewrite <- Ropp_mult_distr_l.
    rewrite <- H. rewrite Ropp_0. reflexivity.
  }
  {
    rewrite Ropp_mult_distr_r.
    reflexivity.
  }
  {
    destruct r1.
    destruct r.
    exfalso. apply Rlt_irrefl with (x*y).
    apply Rlt_trans with R0.
    apply Rplus_lt_reg_l with (- (x*y)).
    rewrite Rplus_opp_l.
    rewrite Rplus_0_r.
    rewrite Ropp_mult_distr_r.
    apply Rmult_lt_0_compat.
    assumption.
    apply Rplus_lt_reg_l with y.
    rewrite Rplus_0_r.
    rewrite Rplus_opp_r.
    assumption.
    assumption.
    subst x. do 2 rewrite Rmult_0_l. reflexivity.
    rewrite <- H. rewrite <- Ropp_mult_distr_r.
    rewrite <- H. rewrite Ropp_0. reflexivity.
  }
  {
    destruct r. destruct r0.
    exfalso. apply Rlt_irrefl with (x*y).
    apply Rlt_trans with R0.
    assumption.
    apply Rmult_lt_0_compat.
    assumption.
    assumption.
    subst y. rewrite Rmult_0_r. rewrite Ropp_0. reflexivity.
    subst x. rewrite Rmult_0_l. rewrite Ropp_0. reflexivity.
  }
  { reflexivity. }
Qed.

Lemma Rabs_Rinv : forall r, r <> R0 -> Rabs (/ r) = / Rabs r.
Proof.
  intros x h.
  unfold Rabs.
  destruct (Rcase_abs x);destruct (Rcase_abs (/ x)).
  {
    rewrite Ropp_inv_permute.
    reflexivity.
    assumption.
  }
  {
    destruct r0.
    exfalso.
    apply Rinv_lt_0_compat in r.
    apply Rlt_irrefl with R0.
    apply Rlt_trans with (/ x);assumption.
    rewrite <- H.
    rewrite <- Ropp_inv_permute.
    rewrite <- H.
    rewrite Ropp_0. reflexivity. assumption.
  }
  {
    destruct r.
    exfalso.
    apply Rlt_irrefl with R0.
    apply Rlt_trans with x.
    assumption.
    apply Rinv_lt_0_compat in r0.
    rewrite Rinv_involutive in r0.
    assumption. assumption.
    subst x. exfalso. apply h. reflexivity.
  }
  {
    reflexivity.
  }
Qed.

Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x.
Proof.
  intro x.
  unfold Rabs.
  destruct (Rcase_abs (-x));
  destruct (Rcase_abs x).
  {
    exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x.
    apply Rplus_lt_reg_l with (-x).
    rewrite Rplus_0_r. rewrite Rplus_opp_l. assumption.
    assumption.
  }
  {
    rewrite Ropp_involutive.
    reflexivity.
  }
  {
    reflexivity.
  }
  {
    destruct r.
    destruct r0.
    exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x.
    assumption.
    apply Rplus_lt_reg_l with (-x). rewrite Rplus_0_r.
    rewrite Rplus_opp_l. assumption.
    subst x. rewrite Ropp_0. reflexivity.
    rewrite <- H. rewrite <- Ropp_involutive with x. rewrite <- H.
    rewrite Ropp_0. reflexivity.
  }
Qed.

Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b.
Proof.
  intros x y.
  unfold Rabs.
  destruct (Rcase_abs x);
  destruct (Rcase_abs y);
  destruct (Rcase_abs (x+y)).
  {
    rewrite Ropp_plus_distr. right. reflexivity.
  }
  {
    destruct r1.
    exfalso.
    apply Rlt_irrefl with R0.
    apply Rlt_trans with (x+y).
    assumption.
    rewrite <- Rplus_0_l with R0.
    apply Rplus_lt_compat. assumption. assumption.
    rewrite <- H. rewrite <- Ropp_plus_distr. rewrite <- H.
    rewrite Ropp_0. right. reflexivity.
  }
  {
    rewrite Ropp_plus_distr.
    apply Rplus_le_compat_l.
    apply Rplus_le_reg_r with y.
    rewrite Rplus_opp_l.
    apply Rle_trans with y.
    assumption.
    pattern y at 1;rewrite <- Rplus_0_l with y.
    apply Rplus_le_compat_r. assumption.
  }
  {
    apply Rplus_le_compat_r.
    left.
    apply Rlt_trans with R0. assumption.
    apply Rplus_lt_reg_l with x. rewrite Rplus_opp_r. rewrite Rplus_0_r.
    assumption.
  }
  {
    rewrite Ropp_plus_distr.
    apply Rplus_le_compat_r.
    apply Rle_trans with R0.
    apply Rplus_le_reg_l with x.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    assumption.
    assumption.
  }
  {
    apply Rplus_le_compat_l.
    apply Rle_trans with R0.
    left. assumption.
    left. apply Rplus_lt_reg_r with y.
    rewrite Rplus_0_l. rewrite Rplus_opp_l. assumption.
  }
  {
    rewrite Ropp_plus_distr.
    apply Rplus_le_compat.
    apply Rle_trans with R0.
    apply Rplus_le_reg_l with x.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    assumption.
    assumption.
    apply Rle_trans with R0.
    apply Rplus_le_reg_l with y.
    rewrite Rplus_0_r.
    rewrite Rplus_opp_r.
    assumption.
    assumption.
  }
  {
    right. reflexivity.
  }
Qed.

Lemma Rabs_triang_inv : forall a b:R, Rabs a - Rabs b <= Rabs (a - b).
Proof.
  intros a b.
  unfold Rabs.
  destruct (Rcase_abs a);
  destruct (Rcase_abs b);
  destruct (Rcase_abs (a-b));
  unfold Rminus in *;
  try(rewrite Ropp_plus_distr in *);
  try(rewrite Ropp_involutive in *).
  {
    right. reflexivity.
  }
  {
    destruct r1.
    left. apply Rlt_trans with R0.
    apply Rplus_lt_reg_l with a.
    rewrite <- Rplus_assoc.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    rewrite Rplus_0_l.
    apply Rplus_lt_reg_r with (-b).
    rewrite Rplus_opp_r. assumption. assumption.
    rewrite <- H. right.
    apply Rplus_eq_reg_l with a.
    apply Rplus_eq_reg_r with (-b).
    repeat (rewrite Rplus_assoc).
    rewrite Rplus_opp_r.
    repeat (rewrite <- Rplus_assoc).
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    rewrite Rplus_0_r.
    rewrite <- H. reflexivity.
  }
  {
    apply Rplus_le_compat_l.
    apply Rle_trans with R0.
    apply Rplus_le_reg_r with b.
    rewrite Rplus_opp_l. rewrite Rplus_0_l. assumption. assumption.
  }
  {
    apply Rplus_le_compat_r.
    destruct r0.
    destruct r1.
    exfalso.
    apply (Rplus_lt_compat_r b) in H0.
    rewrite Rplus_0_l in H0.
    rewrite Rplus_assoc in H0.
    rewrite Rplus_opp_l in H0.
    rewrite Rplus_0_r in H0.
    apply Rlt_irrefl with R0.
    apply Rlt_trans with b.
    assumption. apply Rlt_trans with a.
    assumption. assumption.
    apply (Rplus_eq_compat_r b) in H0.
    rewrite Rplus_assoc in H0.
    rewrite Rplus_opp_l in H0.
    rewrite Rplus_0_r in H0.
    rewrite Rplus_0_l in H0.
    subst b.
    exfalso. apply Rlt_irrefl with R0.
    apply Rlt_trans with a; assumption.
    subst b.
    rewrite Ropp_0 in r1.
    rewrite Rplus_0_r in r1.
    destruct r1.
    exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with a;assumption.
    subst a. exfalso. apply Rlt_irrefl with R0;assumption.
  }
  {
    apply Rplus_le_compat_r.
    apply (Rplus_lt_compat_r b) in r1.
    rewrite Rplus_assoc in r1.
    rewrite Rplus_opp_l in r1.
    rewrite Rplus_0_r in r1.
    rewrite Rplus_0_l in r1.
    destruct r.
    exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with a. assumption.
    apply Rlt_trans with b. assumption. assumption.
    subst a. exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with b;assumption.
  }
  {
    apply Rplus_le_compat_l.
    left. apply Rlt_trans with R0. assumption.
    apply Rplus_lt_reg_l with b. rewrite Rplus_0_r.
    rewrite Rplus_opp_r. assumption.
  }
  {
    destruct r.
    destruct r0.
    apply (Rplus_lt_compat_r b) in r1.
    rewrite Rplus_assoc in r1.
    rewrite Rplus_opp_l in r1.
    rewrite Rplus_0_r in r1.
    rewrite Rplus_0_l in r1.
    left.
    apply Rplus_lt_reg_l with a.
    repeat (rewrite <- Rplus_assoc).
    rewrite Rplus_opp_r. rewrite Rplus_0_l.
    apply Rplus_lt_reg_r with b.
    repeat (rewrite Rplus_assoc).
    rewrite Rplus_opp_l. rewrite Rplus_0_r.
    apply Rplus_lt_compat. assumption. assumption.
    subst b. rewrite Ropp_0 in *. rewrite Rplus_0_r in *.
    exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with a;assumption.
    subst a. rewrite Ropp_0 in *. rewrite Rplus_0_l in *.
    rewrite Rplus_0_l. left.
    apply Rlt_trans with R0. assumption.
    apply Rplus_lt_reg_l with (-b). rewrite Rplus_0_r.
    rewrite Rplus_opp_l. assumption.
  }
  { right. reflexivity. }
Qed.

Lemma Rabs_case : forall x:R, Rabs x = x /\ R0 <= x \/ Rabs x = -x /\ x < R0.
  intro x.
  unfold Rabs. destruct (Rcase_abs x).
  right. split. reflexivity. assumption.
  left. split. reflexivity. assumption.
Qed.

Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b).
Proof.
  intros x y.
  unfold Rminus.
  destruct (Rabs_case x) as [ [ eqx hx ] | [ eqx hx ] ];
  destruct (Rabs_case y) as [ [ eqy hy ] | [ eqy hy ] ].
  {
    rewrite eqx. rewrite eqy.
    right. reflexivity.
  }
  {
    rewrite eqx. rewrite eqy.
    rewrite Ropp_involutive.
    destruct (Rabs_case (x+y)) as [ [ eqxy hxy ] | [ eqxy hxy ] ];
    destruct (Rabs_case (x+-y)) as [ [ eqxym hxym ] | [ eqxym hxym ] ].
    {
      rewrite eqxy. rewrite eqxym.
      apply Rplus_le_compat_l.
      left. apply Rlt_trans with R0. assumption.
      rewrite <- Ropp_0.
      apply Ropp_lt_contravar.
      assumption.
    }
    {
      rewrite eqxy;rewrite eqxym.
      rewrite Ropp_plus_distr. rewrite Ropp_involutive.
      apply Rplus_le_compat_r.
      clear eqx eqy eqxy eqxym.
      destruct hx as [ lt | eq ].
      exfalso. apply Rlt_irrefl with R0. apply Rlt_trans with x.
      assumption. apply Rlt_trans with y.
      apply Rplus_lt_reg_r with (-y).
      rewrite Rplus_opp_r. assumption.
      assumption.
      subst x. right. rewrite Ropp_0. reflexivity.
    }
    {
      rewrite eqxy;rewrite eqxym.
      rewrite Ropp_plus_distr.
      apply Rplus_le_compat_r.
      apply Rle_trans with R0.
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      assumption. assumption.
    }
    {
      rewrite eqxy;rewrite eqxym.
      rewrite Ropp_plus_distr.
      rewrite Ropp_plus_distr.
      rewrite Ropp_involutive.
      apply Rplus_le_compat_l.
      clear eqx eqy eqxy eqxym.
      destruct hx as [ hx | hx ].
      exfalso. apply Rlt_irrefl with R0.
      apply Rlt_trans with x. assumption.
      apply Rlt_trans with y.
      apply Rplus_lt_reg_r with (-y).
      rewrite Rplus_opp_r.
      assumption.
      assumption.
      subst x. rewrite Rplus_0_l in *.
      exfalso. apply Rlt_irrefl with y. apply Rlt_trans with R0.
      assumption.
      apply Ropp_lt_cancel.
      rewrite Ropp_0. assumption.
    }
  }
  {
    destruct hy as [ hy | hy ].
    {
      rewrite eqx;rewrite eqy.
      rewrite <- Ropp_plus_distr.
      rewrite Rabs_Ropp.
      destruct (Rabs_case (x+y)) as [ [ eqxy hxy ] | [ eqxy hxy ] ];
      destruct (Rabs_case (x+-y)) as [ [ eqxym hxym ] | [ eqxym hxym ] ].
      {
        rewrite eqxy. rewrite eqxym.
        apply Rplus_le_compat_l.
        clear eqx eqy eqxy eqxym.
        destruct hxym.
        {
          exfalso.
          apply Rlt_irrefl with R0.
          apply Rlt_trans with y.
          assumption.
          apply Rlt_trans with x.
          apply Rplus_lt_reg_r with (-y).
          rewrite Rplus_opp_r. assumption.
          assumption.
        }
        {
          apply (Rplus_eq_compat_r y) in H.
          rewrite Rplus_assoc in H.
          rewrite Rplus_opp_l in H.
          rewrite Rplus_0_l in H.
          rewrite Rplus_0_r in H.
          subst y. exfalso. apply Rlt_irrefl with R0.
          apply Rlt_trans with x;assumption.
        }
      }
      {
        rewrite eqxy;rewrite eqxym.
        rewrite Ropp_plus_distr. rewrite Ropp_involutive.
        apply Rplus_le_compat_r.
        left. apply Rlt_trans with R0.
        assumption. rewrite <- Ropp_0.
        apply Ropp_lt_contravar. assumption.
      }
      {
        rewrite eqxy;rewrite eqxym.
        rewrite Ropp_plus_distr.
        apply Rplus_le_compat_r.
        destruct hxym.
        exfalso. apply Rlt_irrefl with R0.
        apply Rlt_trans with y.
        assumption.
        apply Rlt_trans with x.
        apply Rplus_lt_reg_r with (-y).
        rewrite Rplus_opp_r. assumption.
        assumption.
        apply (Rplus_eq_compat_r y) in H.
        rewrite Rplus_assoc in H.
        rewrite Rplus_opp_l in H.
        rewrite Rplus_0_r in H.
        rewrite Rplus_0_l in H.
        subst x. exfalso. apply Rlt_irrefl with R0.
        apply Rlt_trans with y.
        assumption.
        apply Rlt_trans with (y+y).
        apply Rplus_lt_reg_l with (-y).
        rewrite <- Rplus_assoc.
        rewrite Rplus_opp_l.
        rewrite Rplus_0_l. assumption. assumption.
      }
      {
        rewrite eqxy;rewrite eqxym.
        rewrite Ropp_plus_distr.
        rewrite Ropp_plus_distr.
        rewrite Ropp_involutive.
        apply Rplus_le_compat_l.
        left. apply Rlt_trans with R0.
        rewrite <- Ropp_0. apply Ropp_lt_contravar. assumption.
        assumption.
      }
    }
    {
      subst y.
      rewrite eqx. rewrite eqy.
      rewrite Ropp_0.
      rewrite Rplus_0_r.
      rewrite Rplus_0_r.
      rewrite Rabs_Ropp.
      right. reflexivity.
    }
  }
  {
    rewrite eqx. rewrite eqy.
    rewrite <- Ropp_plus_distr.
    rewrite Rabs_Ropp.
    right. reflexivity.
  }
Qed.

Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a.
Proof.
  intros x a hu hl.
  unfold Rabs. destruct (Rcase_abs x).
  apply Ropp_lt_cancel. rewrite Ropp_involutive. assumption.
  assumption.
Qed.

Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
Proof.
  intros x a.
  split.
  unfold Rabs in H. destruct (Rcase_abs x).
  apply Rlt_trans with R0. assumption.
  apply Rlt_trans with (-x).
  apply Ropp_lt_cancel. rewrite Ropp_involutive. rewrite Ropp_0.
  assumption. assumption.
  assumption.
  unfold Rabs in H. destruct (Rcase_abs x).
  apply Ropp_lt_cancel. rewrite Ropp_involutive. assumption.
  destruct r.
  apply Rlt_trans with R0.
  apply Ropp_lt_cancel. rewrite Ropp_involutive. rewrite Ropp_0.
  apply Rlt_trans with x. assumption. assumption. assumption.
  subst x. apply Ropp_lt_cancel. rewrite Ropp_involutive. rewrite Ropp_0.
  assumption.
Qed.

Lemma RmaxAbs :
  forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).
Proof.
  intros x y z.
  intros hxy hyz.
  unfold Rabs, Rmax.
  destruct (Rcase_abs y) as [ hy | hy ];
  destruct (Rcase_abs x) as [ hx | hx ];
  destruct (Rcase_abs z) as [ hz | hz ].
  {
    destruct (Rle_dec (-x) (-z)) as [ hxz | hxz ].
    {
      apply Ropp_le_cancel in hxz.
      assert (eq:z=x).
      {
        apply Rle_antisym.
        { assumption. }
        { apply Rle_trans with y;assumption. }
      }
      subst z.
      assert (eq:x=y).
      {
        apply Rle_antisym;assumption.
      }
      subst y.
      right. reflexivity.
    }
    {
      apply Rnot_le_lt in hxz.
      apply Ropp_le_contravar.
      assumption.
    }
  }
  {
    destruct (Rle_dec (-x) z) as [ hxz | hxz ].
    {
      apply Rle_trans with (-x).
      { apply Ropp_le_contravar. assumption. }
      { assumption. }
    }
    {
      apply Rnot_le_lt in hxz.
      apply Ropp_le_contravar.
      assumption.
    }
  }
  {
    destruct (Rle_dec x (-z)) as [ hxz | hxz ].
    {
      apply Ropp_le_contravar.
      apply Rle_trans with x.
      2:assumption.
      apply Rle_trans with (-x).
      { apply Ropp_le_cancel. rewrite Ropp_involutive. assumption. }
      {
        apply Rle_trans with R0.
        2:assumption.
        rewrite <- Ropp_0.
        apply Ropp_le_contravar.
        assumption.
      }
    }
    {
      apply Rnot_le_lt in hxz.
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rlt_trans with z.
      2:exact hz. clear hz.
      apply Rlt_trans with (-x).
      2:{
        apply Ropp_lt_cancel.
        rewrite Ropp_involutive.
        exact hxz.
      }
      clear hxz.
      apply Ropp_lt_cancel.
      rewrite Ropp_involutive.
      rewrite Ropp_0.
      apply Rle_lt_trans with y.
      { exact hxy. }
      { exact hy. }
    }
  }
  {
    exfalso.
    apply Rlt_irrefl with x.
    apply Rle_lt_trans with y.
    exact hxy.
    clear hxy.
    apply Rlt_le_trans with R0.
    exact hy.
    exact hx.
  }
  {
    destruct (Rle_dec (-x) (-z)) as [ hxz | hxz ].
    {
      apply Ropp_le_cancel in hxz.
      assert (eq : z = x).
      {
        apply Rle_antisym;try assumption.
        apply Rle_trans with y;assumption.
      }
      subst z.
      assert (eq : x = y).
      { apply Rle_antisym; assumption. }
      subst y.
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with x;assumption.
    }
    {
      apply Rnot_le_lt in hxz.
      apply Ropp_lt_cancel in hxz.
      clear hxy.
      clear hx.
      clear hxz.
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with z;try assumption.
      apply Rle_trans with y;assumption.
    }
  }
  {
    destruct (Rle_dec (-x) z) as [ hxz | hxz ].
    { assumption. }
    {
      apply Rnot_le_lt in hxz.
      apply Rle_trans with z.
      exact hyz.
      clear hyz.
      left. exact hxz.
    }
  }
  {
    exfalso.
    apply Rlt_irrefl with R0.
    apply Rle_lt_trans with z.
    2:exact hz.
    clear hz.
    apply Rle_trans with y; assumption.
  }
  {
    destruct (Rle_dec x z) as [ hxz | hxz ].
    { assumption. }
    {
      apply Rnot_le_lt in hxz.
      exfalso.
      apply Rlt_irrefl with z.
      apply Rlt_le_trans with x; try assumption.
      apply Rle_trans with y;assumption.
    }
  }
Qed.

Lemma abs_IZR : forall z, IZR (Z.abs z) = Rabs (IZR z).
Proof.
  intro z.
  unfold Rabs.
  destruct (Rcase_abs (IZR z)) as [ h | h ].
  {
    unfold Z.abs.
    destruct z.
    { change (IZR 0) with R0. rewrite Ropp_0. reflexivity. }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rlt_trans with (IZR (Z.pos p)).
      {
        change R0 with (IZR 0).
        apply IZR_lt.
        apply Pos2Z.pos_is_pos.
      }
      { assumption. }
    }
    {
      rewrite <- opp_IZR.
      rewrite Pos2Z.opp_neg.
      reflexivity.
    }
  }
  {
    unfold Z.abs.
    destruct z.
    { reflexivity. }
    { reflexivity. }
    {
      exfalso.
      apply Rlt_irrefl with R0.
      apply Rle_lt_trans with (IZR (Z.neg p)).
      { assumption. }
      {
        change R0 with (IZR 0).
        apply IZR_lt.
        apply Pos2Z.neg_is_neg.
      }
    }
  }
Qed.

Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Z.abs z).
Proof.
  intro z.
  symmetry.
  apply abs_IZR.
Qed.

Lemma Ropp_Rmax : forall x y, - Rmax x y = Rmin (-x) (-y).
Proof.
  intros x y.
  unfold Rmax, Rmin.
  destruct (Rle_dec x y) as [ hxy | hxy ];
  destruct (Rle_dec (-x) (-y)) as [ hxy' | hxy' ].
  {
    apply Rle_antisym.
    apply Ropp_le_contravar. assumption.
    assumption.
  }
  { reflexivity. }
  { reflexivity. }
  {
    apply Rnot_le_lt in hxy.
    apply Rnot_le_lt in hxy'.
    apply Rle_antisym.
    left. apply Ropp_lt_contravar. assumption.
    left. assumption.
  }
Qed.

Lemma Ropp_Rmin : forall x y, - Rmin x y = Rmax (-x) (-y).
Proof.
intros x y.
unfold Rmax.
unfold Rmin.
destruct (Rle_dec x y) as [ hmin | hmin ];
destruct (Rle_dec (-x) (-y)) as [ hmax | hmax ].
{
  apply Rle_antisym.
  assumption.
  apply Ropp_le_contravar.
  assumption.
}
{ reflexivity. }
{ reflexivity. }
{
  apply Rnot_le_lt in hmin.
  apply Rnot_le_lt in hmax.
  apply Rle_antisym.
  left. assumption.
  left. apply Ropp_lt_contravar. assumption.
}
Qed.

Lemma Rmax_assoc : forall x y z, Rmax x (Rmax y z) = Rmax (Rmax x y) z.
Proof.
intros x y z.
unfold Rmax.
destruct (Rle_dec y z) as [ hyz | hyz ] eqn:eqyz.
{
  destruct (Rle_dec x y) as [ hxy | hxy ] eqn:eqxy.
  {
    destruct (Rle_dec x z) as [ hxz | hxz ] eqn:eqxz.
    {
      rewrite eqyz. reflexivity.
    }
    {
      rewrite eqyz. apply Rle_antisym.
      apply Rle_trans with y;assumption.
      clear eqxz.
      apply Rnot_le_lt in hxz.
      left. assumption.
    }
  }
  {
    destruct (Rle_dec x z) as [ hxz | hxz ] eqn:eqxz.
    { reflexivity. }
    { reflexivity. }
  }
}
{
  destruct (Rle_dec x y) as [ hxy | hxy ] eqn:eqxy.
  {
    rewrite eqyz. reflexivity.
  }
  {
    destruct (Rle_dec x z) as [ hxz | hxz ] eqn:eqxz.
    {
      apply Rle_antisym.
      assumption.
      left.
      clear eqyz. apply Rnot_le_lt in hyz.
      clear eqxy. apply Rnot_le_lt in hxy.
      apply Rlt_trans with y;assumption.
    }
    { reflexivity. }
  }
}
Qed.

Lemma Rminmax : forall a b, Rmin a b <= Rmax a b.
Proof.
  intros x y.
  unfold Rmin, Rmax.
  destruct (Rle_dec x y) as [ hxy | hxy ].
  { assumption. }
  {
    apply Rnot_le_lt in hxy.
    left. assumption.
  }
Qed.

Lemma Rmin_assoc : forall x y z, Rmin x (Rmin y z) =
  Rmin (Rmin x y) z.
Proof.
intros x y z.
unfold Rmin.
destruct (Rle_dec y z) as [ hyz | hyz ] eqn:eqyz.
{
  destruct (Rle_dec x y) as [ hxy | hxy ] eqn:eqxy.
  {
    destruct (Rle_dec x z) as [ hxz | hxz ] eqn:eqxz.
    { reflexivity. }
    {
      apply Rle_antisym.
      apply Rle_trans with y;assumption.
      clear eqxz; apply Rnot_le_lt in hxz.
      left.
      assumption.
    }
  }
  { rewrite eqyz. reflexivity. }
}
{
  destruct (Rle_dec x y) as [ hxy | hxy ] eqn:eqxy.
  {
    destruct (Rle_dec x z) as [ hxz | hxz ] eqn:eqxz.
    { reflexivity. }
    { reflexivity. }
  }
  {
    destruct (Rle_dec x z) as [ hxz | hxz ] eqn:eqxz.
    {
      rewrite eqyz.
      apply Rle_antisym.
      assumption.
      left.
      clear eqxy. apply Rnot_le_lt in hxy.
      clear eqyz. apply Rnot_le_lt in hyz.
      apply Rlt_trans with y;assumption.
    }
    { rewrite eqyz. reflexivity. }
  }
}
Qed.
(*
completeness
     : forall E : R -> Prop, bound E -> (exists x : R, E x) -> {m : R | is_lub E m}
*)

Definition tada x s := s * s <= x.

Definition tada' x s := s * s = x \/ s * s = R0.

Lemma Rsqr_le_1 : forall x, R0 < x -> x <= R1 -> x * x <= x.
Proof.
  intros x hl hr .
  destruct hr as [ hr | hr ].
  {
    left.
    pattern x at 3;rewrite <- Rmult_1_r.
    apply Rmult_lt_compat_l.
    exact hl.
    exact hr.
  }
  {
    subst x.
    rewrite Rmult_1_l.
    right.
    reflexivity.
  }
Qed.

Lemma Rsqr_le_0 : forall x, Rsqr x <= R0 -> x = R0.
Proof.
  intros x h.
  destruct h as [ h | h ].
  {
    exfalso.
    apply Rlt_irrefl with R0.
    apply Rle_lt_trans with (Rsqr x).
    { apply Rle_0_sqr. }
    { exact h. }
  }
  {
    unfold Rsqr in h.
    apply Rmult_integral in h.
    destruct h as [ h | h ].
    { exact h. }
    { exact h. }
  }
Qed.

Lemma tada_bound : forall x, R0 <= x -> bound (tada x).
Proof.
  intros x hx.
  unfold bound.
  unfold is_upper_bound.
  unfold tada.
  destruct hx as [ hx | hx ].
  {
    destruct (Rtotal_order x R1) as [ ho | [ ho | ho ] ].
    {
      exists R1.
      intros y hy.
      destruct (Rtotal_order y R0) as [ hoy | [ hoy | hoy ] ].
      {
        destruct (Rtotal_order y (-R1)) as [ hoy' | [ hoy' | hoy' ] ].
        {
          apply Rle_trans with (-R1).
          left. exact hoy'.
          apply Rle_trans with R0.
          rewrite <- Ropp_0. apply Ropp_le_contravar. left. exact Rlt_0_1.
          left. exact Rlt_0_1.
        }
        {
          subst y.
          apply Rle_trans with R0.
          { rewrite <- Ropp_0. apply Ropp_le_contravar. left. exact Rlt_0_1. }
          { left. exact Rlt_0_1. }
        }
        {
          apply Rle_trans with R0.
          left. exact hoy.
          left. exact Rlt_0_1.
        }
      }
      {
        subst y.
        left.
        exact Rlt_0_1.
      }
      {
        destruct (Rtotal_order y R1) as [ hoy' | [ hoy' | hoy' ] ].
        {
          left.
          exact hoy'.
        }
        {
          subst y.
          right.
          reflexivity.
        }
        {
          exfalso.
          eapply Rlt_irrefl.
          eapply Rlt_le_trans.
          { exact hoy'. }
          {
            eapply Rle_trans.
            2:{
              left.
              exact ho.
            }
            {
              clear ho.
              apply Rmult_le_reg_r with y.
              { exact hoy. }
              {
                eapply Rle_trans.
                { exact hy. }
                {
                  pattern x at 1;rewrite <- Rmult_1_r.
                  apply Rmult_le_compat_l.
                  { left. exact hx. }
                  { left. exact hoy'. }
                }
              }
            }
          }
        }
      }
    }
    {
      subst x.
      exists R1.
      intros y hy.
      destruct (Rtotal_order y R0) as [ hoy | [ hoy | hoy ] ].
      {
        apply Rle_trans with R0.
        left. exact hoy.
        left. exact Rlt_0_1.
      }
      {
        subst y.
        left.
        exact Rlt_0_1.
      }
      {
        destruct (Rtotal_order y R1) as [ hoy' | [ hoy' | hoy' ] ].
        { left. exact hoy'. }
        { subst y. right. reflexivity. }
        {
          exfalso.
          eapply Rlt_irrefl.
          eapply Rle_lt_trans.
          { apply hy. }
          {
            pattern R1;rewrite <- Rmult_1_r.
            apply Rmult_gt_0_lt_compat.
            { exact Rlt_0_1. }
            { exact hoy. }
            { exact hoy'. }
            { exact hoy'. }
          }
        }
      }
    }
    {
      exists x.
      intros y hy.
      destruct (Rtotal_order y R0) as [ hoy | [ hoy | hoy ] ].
      {
        left.
        apply Rlt_trans with R0.
        exact hoy.
        exact hx.
      }
      {
        subst y.
        left.
        exact hx.
      }
      {
        destruct (Rtotal_order y R1) as [ hoy' | [ hoy' | hoy' ] ].
        {
          left.
          apply Rlt_trans with R1.
          exact hoy'.
          exact ho.
        }
        {
          subst y .
          left.
          exact ho.
        }
        {
          apply Rmult_le_reg_r with y.
          exact hoy.
          apply Rle_trans with x.
          exact hy.
          pattern x at 1;rewrite <- Rmult_1_r.
          apply Rmult_le_compat_l.
          left. exact hx.
          left. exact hoy'.
        }
      }
    }
  }
  {
    subst x.
    exists R0.
    intros x hx.
    apply Rsqr_le_0 in hx.
    right.
    exact hx.
  }
Qed.


From Coq Require Export Setoid.
Set Implicit Arguments.

(** * Preliminaries *)
(** ** Definition of iterator [comp]
   [comp f u n x] is defined as $(f~(u~(n-1)).. (f (u~ 0)~x))$ *)

Fixpoint comp (A:Type) (f : A -> A -> A) (x : A) (u : nat -> A) (n:nat) {struct n}: A :=
   match n with O => x| (S p) => f (u p) (comp f x u p) end.

Lemma comp0 : forall (A:Type) (f : A -> A -> A) (x : A) (u : nat -> A), comp f x u 0 = x.
trivial.
Qed.

Lemma compS : forall (A:Type) (f : A -> A -> A) (x : A) (u : nat -> A) (n:nat),
              comp f x u (S n) = f (u n) (comp f x u n).
trivial.
Qed.

(** ** Reducing if constructs *)

Lemma if_then : forall (P:Prop) (b:{P}+{ ~P})(A:Type)(p q:A), P -> (if b then p else q) =p.
destruct b; simpl; intuition.
Qed.

Lemma if_else : forall (P:Prop) (b:{P}+{ ~P})(A:Type)(p q:A), ~P -> (if b then p else q) =q.
destruct b; simpl; intuition.
Qed.

(** ** Classical reasoning *)

Definition class (A:Prop) := ~ ~A -> A.

Lemma class_neg : forall A:Prop, class ( ~ A).
unfold class; intuition.
Qed.

Lemma class_false : class False.
unfold class; intuition.
Qed.
Hint Resolve class_neg class_false: core.

Definition orc (A B:Prop) := forall C:Prop, class C -> (A ->C) -> (B->C) -> C.

Lemma orc_left : forall A B:Prop, A -> orc A B.
red;intuition.
Qed.

Lemma orc_right : forall A B:Prop, B -> orc A B.
red;intuition.
Qed.

Hint Resolve orc_left orc_right: core.

Lemma class_orc : forall A B, class (orc A B).
repeat red; intros.
apply H0; red; intro.
apply H; red; intro.
apply H3; apply H4; auto.
Qed.

Arguments class_orc : clear implicits.

Lemma orc_intro : forall A B, ( ~A -> ~B -> False) -> orc A B.
intros; apply class_orc; red; intros.
apply H; red; auto.
Qed.

Lemma class_and : forall A B, class A -> class B -> class (A /\ B).
unfold class; intuition.
Qed.

Lemma excluded_middle : forall A, orc A ( ~A).
red; intros.
apply H; red; intro.
intuition.
Qed.

Definition exc (A :Type)(P:A->Prop) :=
   forall C:Prop, class C -> (forall x:A, P x ->C) -> C.

Lemma exc_intro : forall (A :Type)(P:A->Prop) (x:A), P x -> exc P.
red;firstorder.
Qed.

Lemma class_exc : forall (A :Type)(P:A->Prop), class (exc P).
repeat red; intros.
apply H0; clear H0; red; intro.
apply H; clear H; red; intro H2.
apply H2; intros; auto.
apply H0; apply (H1 x); auto.
Qed.

Lemma exc_intro_class : forall (A:Type) (P:A->Prop), ((forall x, ~P x) -> False) -> exc P.
intros; apply class_exc; red; intros.
apply H; red; intros; auto.
apply H0; apply exc_intro with (x:=x);auto.
Qed.

Lemma not_and_elim_left : forall A B, ~ (A /\ B) -> A -> ~B.
intuition.
Qed.

Lemma not_and_elim_right : forall A B, ~ (A /\ B) -> B -> ~A.
intuition.
Qed.

Hint Resolve class_orc class_and class_exc excluded_middle: core.

Lemma class_double_neg : forall P Q: Prop, class Q -> (P -> Q) -> ~~P -> Q.
intros.
apply (excluded_middle (A:=P)); auto.
Qed.

(** ** Extensional equality *)

Definition feq A B (f g : A -> B) := forall x, f x = g x.

Lemma feq_refl : forall A B (f:A->B), feq f f.
red; trivial.
Qed.

Lemma feq_sym : forall A B (f g : A -> B), feq f g -> feq g f.
unfold feq; auto.
Qed.

Lemma feq_trans : forall A B (f g h: A -> B), feq f g -> feq g h -> feq f h.
unfold feq; intros.
transitivity (g x); auto.
Qed.

Hint Resolve feq_refl: core.
Hint Immediate feq_sym: core.
Hint Unfold feq: core.

Add Parametric Relation (A B : Type) : (A -> B) (feq (A:=A) (B:=B))
  reflexivity proved by (feq_refl (A:=A) (B:=B))
  symmetry proved by (feq_sym (A:=A) (B:=B))
  transitivity proved by (feq_trans (A:=A) (B:=B))
as feq_rel.


(** ** intro

この forall (P : Prop), P -> P という命題を、今度は
intro と exact を使って証明してみましょう。
*)

Goal forall (P : Prop), P -> P.
Proof.
(**
1 subgoal
______________________________________(1/1)
forall P : Prop, P -> P
*)
  Show Proof.
(**
<<
?Goal
>>
ここでは証明を始めたばかりなので、Goal に与えた
forall P : Prop, P -> P という命題そのものを証明せよ、と Coq から要求されています。
そこで Show Proof とすると ?Goal と表示されます。
つまり、証明項はまったく構築されておらず、
forall P : Prop, P -> P という型の
値をどうにか作ってここに埋めていかなければならないというわけです。
*)
  intro P.
(**
<<
1 subgoal
P : Prop
______________________________________(1/1)
P -> P
>>
*)
  Show Proof.
(**
<<
(fun P : Prop => ?Goal)
>>
intro P により、証明すべき命題 forall P : Prop, P -> P の左側の
forall P : Prop という部分が前提に移動して前提に P : Prop が入り、
証明すべき命題は P -> P に変化します。
ここで Show Proof とすると、(fun P : Prop => ?Goal) と表示されます。
つまり、intro P は証明項を Prop型の値Pを受け取る関数抽象として構築せよ、
という指示です。
関数抽象の本体はまだ不明なので ?Goal となっていますが、
この部分の型は (forall P : Prop, P -> P から左側の forall P : Prop を取り除いた型である)
P -> P です。
そのため、P -> P という型である ?Goal の部分をこれから構築しなければならない、
という状態であることがわかります。

なお、この段階で Display notations を無効にすると、証明すべき命題は
P -> P から、forall _ : P, P に変化します。
これにより、P -> P というのは forall _ : P, P の省略形であることがわかります。

前提に P が入ったのでここからは P を自由に使えますが、このことを
証明項の構造から説明すると、?Goal の部分の外側で P が束縛されているため、
?Goal の中では P を参照できる、という意味になります。
*)
  intro H.
(**
<<
1 subgoal
P : Prop
H : P
______________________________________(1/1)
P
>>
*)
  Show Proof.
(**
<<
(fun (P : Prop) (H : P) => ?Goal)
>>
intro H により、証明すべき命題 P -> P の左側の P -> が消えて
前提に H : P に移動し、証明すべき命題は P に変化します。

Show Proof とすると、(fun (P : Prop) (H : P) => ?Goal) と表示されます。
つまり、?Goal を（また）関数抽象として構築せよ、という指示を行ったので、
証明項は関数抽象が2段ネストしたものとして (fun (P : Prop) (H : P) => ?Goal) という形に
なり、関数抽象の本体の P という型である ?Goal の部分をこれから構築しなければならない、
という状態であることが分かります。

Display notations が無効にするとわかるように、
これは証明すべき命題 forall _ : P, P の左側の
forall _ : P が前提に移動した、というわけで、
最初の intro P が forall P : Prop を前提に移動したのと
同様なことをしていることがわかるでしょう。
ただし、forall P : Prop では、Prop 型の値に P という名前がついていましたが、
今回の forall _ : P では、P 型の値に名前がついておらず、_ になっています。
どちらにしても、intro で指定した名前が関数抽象で導入される変数の名前として使われます。

前提に H が入ったのでここからは H を自由に使えますが、このことを
証明項の構造から説明すると、?Goal の部分の外側で H が束縛されているため、
?Goal の中では H を参照できる、という意味になります。
*)
  exact H.
(**
<<
No more subgoals.
>>
*)
  Show Proof.
(**
<<
(fun (P : Prop) (H : P) => H)
>>
P という型の値としては H が存在する（参照できる）ので、
それを証明項として与えれば証明は終わりです。
exact H により H を証明項として直接与えると No more subgoals. と表示されて
証明が終ったことがわかります。
ここで Show Proof とすると、(fun (P : Prop) (H : P) => H) と表示され、
上で ?Goal だったところに H が埋められていることが分かります。
証明項に不明な部分はもうないので、やることはもうありません。
Qed で証明を終りましょう。
*)
Qed.


Require Import Frap.

(** * Finite sets as inductive predicates *)

Inductive my_favorite_numbers : nat -> Prop :=
| ILike17 : my_favorite_numbers 17
| ILike23 : my_favorite_numbers 23
| ILike42 : my_favorite_numbers 42.

Check my_favorite_numbers_ind.

Theorem favorites_below_50 : forall n, my_favorite_numbers n -> n < 50.
Proof.
Admitted.

(** * Transitive closure of relations *)

Inductive tc {A} (R : A -> A -> Prop) : A -> A -> Prop :=
| TcBase : forall x y, R x y -> tc R x y
| TcTrans : forall x y z, tc R x y -> tc R y z -> tc R x z.

(** ** Less-than reimagined *)

Definition oneApart (n m : nat) : Prop :=
  n + 1 = m.

Definition lt' : nat -> nat -> Prop := tc oneApart.

Theorem lt'_lt : forall n m, lt' n m -> n < m.
Proof.
Admitted.

Theorem lt_lt' : forall n m, n < m -> lt' n m.
Proof.
Admitted.

(** ** Transitive closure is idempotent. *)

Theorem tc_tc2 : forall A (R : A -> A -> Prop) x y, tc R x y -> tc (tc R) x y.
Proof.
Admitted.

Theorem tc2_tc : forall A (R : A -> A -> Prop) x y, tc (tc R) x y -> tc R x y.
Proof.
Admitted.

(** * Permutation *)

(* Lifted from the Coq standard library: *)
Inductive Permutation {A} : list A -> list A -> Prop :=
| perm_nil :
    Permutation [] []
| perm_skip : forall x l l',
    Permutation l l' -> Permutation (x::l) (x::l')
| perm_swap : forall x y l,
    Permutation (y::x::l) (x::y::l)
| perm_trans : forall l l' l'',
    Permutation l l' -> Permutation l' l'' -> Permutation l l''.

Theorem Permutation_rev : forall A (ls : list A),
    Permutation ls (rev ls).
Proof.
Admitted.

Theorem Permutation_length : forall A (ls1 ls2 : list A),
    Permutation ls1 ls2 -> length ls1 = length ls2.
Proof.
Admitted.

Theorem Permutation_app : forall A (ls1 ls1' ls2 ls2' : list A),
    Permutation ls1 ls1'
    -> Permutation ls2 ls2'
    -> Permutation (ls1 ++ ls2) (ls1' ++ ls2').
Proof.
Admitted.

(** * Simple propositional logic *)

Inductive prop :=
| Truth
| Falsehood
| And (p1 p2 : prop)
| Or (p1 p2 : prop).

Inductive valid : prop -> Prop :=
| ValidTruth :
    valid Truth
| ValidAnd : forall p1 p2,
    valid p1
    -> valid p2
    -> valid (And p1 p2)
| ValidOr1 : forall p1 p2,
    valid p1
    -> valid (Or p1 p2)
| ValidOr2 : forall p1 p2,
    valid p2
    -> valid (Or p1 p2).

Fixpoint interp (p : prop) : Prop :=
  match p with
  | Truth => True
  | Falsehood => False
  | And p1 p2 => interp p1 /\ interp p2
  | Or p1 p2 => interp p1 \/ interp p2
  end.

Theorem interp_valid : forall p, interp p -> valid p.
Proof.
Admitted.

Theorem valid_interp : forall p, valid p -> interp p.
Proof.
Admitted.

Fixpoint commuter (p : prop) : prop :=
  match p with
  | Truth => Truth
  | Falsehood => Falsehood
  | And p1 p2 => And (commuter p2) (commuter p1)
  | Or p1 p2 => Or (commuter p2) (commuter p1)
  end.

Theorem valid_commuter_fwd : forall p, valid p -> valid (commuter p).
Proof.
Admitted.

Theorem valid_commuter_bwd : forall p, valid (commuter p) -> valid p.
Proof.
Admitted.

(* Proofs for an extension I hope we'll get to:

Fixpoint interp (vars : var -> Prop) (p : prop) : Prop :=
  match p with
  | Truth => True
  | Falsehood => False
  | Var x => vars x
  | And p1 p2 => interp vars p1 /\ interp vars p2
  | Or p1 p2 => interp vars p1 \/ interp vars p2
  | Imply p1 p2 => interp vars p1 -> interp vars p2
  end.

Theorem valid_interp : forall vars hyps p,
    valid hyps p
    -> (forall h, hyps h -> interp vars h)
    -> interp vars p.
Proof.
  induct 1; simplify.

  apply H0.
  assumption.

  propositional.

  propositional.

  propositional.

  propositional.

  propositional.

  propositional.

  propositional.

  propositional.
  apply IHvalid2.
  propositional.
  equality.
  apply H2.
  assumption.
  apply IHvalid3.
  propositional.
  equality.
  apply H2.
  assumption.

  apply IHvalid.
  propositional.
  equality.
  apply H0.
  assumption.

  propositional.

  excluded_middle (interp vars p); propositional.
  (* Note that use of excluded middle is a bit controversial in Coq,
   * and we'll generally be trying to avoid it,
   * but it helps enough with this example that we don't sweat the details. *)
Qed.

Lemma valid_weaken : forall hyps1 p,
    valid hyps1 p
    -> forall hyps2 : prop -> Prop,
      (forall h, hyps1 h -> hyps2 h)
      -> valid hyps2 p.
Proof.
  induct 1; simplify.

  apply ValidHyp.
  apply H0.
  assumption.

  apply ValidTruthIntro.

  apply ValidFalsehoodElim.
  apply IHvalid.
  assumption.

  apply ValidAndIntro.
  apply IHvalid1.
  assumption.
  apply IHvalid2.
  assumption.

  apply ValidAndElim1 with p2.
  apply IHvalid.
  assumption.

  apply ValidAndElim2 with p1.
  apply IHvalid.
  assumption.

  apply ValidOrIntro1.
  apply IHvalid.
  assumption.

  apply ValidOrIntro2.
  apply IHvalid.
  assumption.

  apply ValidOrElim with p1 p2.
  apply IHvalid1.
  assumption.
  apply IHvalid2.
  first_order.
  apply IHvalid3.
  first_order.

  apply ValidImplyIntro.
  apply IHvalid.
  propositional.
  right.
  apply H0.
  assumption.

  apply ValidImplyElim with p1.
  apply IHvalid1.
  assumption.
  apply IHvalid2.
  assumption.

  apply ValidExcludedMiddle.
Qed.

Lemma valid_cut : forall hyps1 p p',
    valid hyps1 p
    -> forall hyps2, valid hyps2 p'
                     -> (forall h, hyps1 h -> hyps2 h \/ h = p')
                     -> valid hyps2 p.
Proof.
  induct 1; simplify.

  apply H1 in H.
  propositional.
  apply ValidHyp.
  assumption.
  equality.

  apply ValidTruthIntro.

  apply ValidFalsehoodElim.
  apply IHvalid; assumption.

  apply ValidAndIntro.
  apply IHvalid1; assumption.
  apply IHvalid2; assumption.

  apply ValidAndElim1 with p2.
  apply IHvalid; assumption.

  apply ValidAndElim2 with p1.
  apply IHvalid; assumption.

  apply ValidOrIntro1.
  apply IHvalid; assumption.

  apply ValidOrIntro2.
  apply IHvalid; assumption.

  apply ValidOrElim with p1 p2.
  apply IHvalid1; assumption.
  apply IHvalid2.
  apply valid_weaken with hyps2.
  assumption.
  propositional.
  first_order.
  apply IHvalid3.
  apply valid_weaken with hyps2.
  assumption.
  propositional.
  first_order.

  apply ValidImplyIntro.
  apply IHvalid.
  apply valid_weaken with hyps2.
  assumption.
  propositional.
  first_order.

  apply ValidImplyElim with p1.
  apply IHvalid1; assumption.
  apply IHvalid2; assumption.

  apply ValidExcludedMiddle.
Qed.

Fixpoint varsOf (p : prop) : list var :=
  match p with
  | Truth
  | Falsehood => []
  | Var x => [x]
  | And p1 p2
  | Or p1 p2
  | Imply p1 p2 => varsOf p1 ++ varsOf p2
  end.

Lemma interp_valid'' : forall p hyps,
    (forall x, In x (varsOf p) -> hyps (Var x) \/ hyps (Not (Var x)))
    -> (forall x, hyps (Var x) -> ~hyps (Not (Var x)))
    -> IFF interp (fun x => hyps (Var x)) p
       then valid hyps p
       else valid hyps (Not p).
Proof.
  induct p; unfold IF_then_else; simplify.

  left; propositional.
  apply ValidTruthIntro.

  right; propositional.
  apply ValidImplyIntro.
  apply ValidHyp.
  propositional.

  specialize (H x); propositional.
  left; propositional.
  apply ValidHyp.
  assumption.
  right; first_order.
  apply ValidHyp.
  assumption.

  excluded_middle (interp (fun x => hyps (Var x)) p1).
  excluded_middle (interp (fun x => hyps (Var x)) p2).
  left; propositional.
  apply ValidAndIntro.
  assert (IFF interp (fun x : var => hyps (Var x)) p1 then valid hyps p1 else valid hyps (Not p1)).
  apply IHp1; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H3; propositional.
  assert (IFF interp (fun x : var => hyps (Var x)) p2 then valid hyps p2 else valid hyps (Not p2)).
  apply IHp2; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H3; propositional.
  right; propositional.
  assert (IFF interp (fun x : var => hyps (Var x)) p2 then valid hyps p2 else valid hyps (Not p2)).
  apply IHp2; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H3; propositional.
  apply ValidImplyIntro.
  apply ValidImplyElim with p2.
  apply valid_weaken with hyps.
  assumption.
  propositional.
  apply ValidAndElim2 with p1.
  apply ValidHyp.
  propositional.
  right; propositional.
  assert (IFF interp (fun x : var => hyps (Var x)) p1 then valid hyps p1 else valid hyps (Not p1)).
  apply IHp1; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H2; propositional.
  apply ValidImplyIntro.
  apply ValidImplyElim with p1.
  apply valid_weaken with hyps.
  assumption.
  propositional.
  apply ValidAndElim1 with p2.
  apply ValidHyp.
  propositional.

  excluded_middle (interp (fun x => hyps (Var x)) p1).
  left; propositional.
  apply ValidOrIntro1.
  assert (IFF interp (fun x : var => hyps (Var x)) p1 then valid hyps p1 else valid hyps (Not p1)).
  apply IHp1; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H2; propositional.
  excluded_middle (interp (fun x => hyps (Var x)) p2).
  left; propositional.
  apply ValidOrIntro2.
  assert (IFF interp (fun x : var => hyps (Var x)) p2 then valid hyps p2 else valid hyps (Not p2)).
  apply IHp2; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H3; propositional.
  right; propositional.
  apply ValidImplyIntro.
  apply ValidOrElim with p1 p2.
  apply ValidHyp.
  propositional.
  assert (IFF interp (fun x : var => hyps (Var x)) p1 then valid hyps p1 else valid hyps (Not p1)).
  apply IHp1; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H3; propositional.
  apply ValidImplyElim with p1.
  apply valid_weaken with hyps.
  assumption.
  propositional.
  apply ValidHyp.
  propositional.
  assert (IFF interp (fun x : var => hyps (Var x)) p2 then valid hyps p2 else valid hyps (Not p2)).
  apply IHp2; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H3; propositional.
  apply ValidImplyElim with p2.
  apply valid_weaken with hyps.
  assumption.
  propositional.
  apply ValidHyp.
  propositional.

  excluded_middle (interp (fun x => hyps (Var x)) p1).
  excluded_middle (interp (fun x => hyps (Var x)) p2).
  left; propositional.
  apply ValidImplyIntro.
  assert (IFF interp (fun x : var => hyps (Var x)) p2 then valid hyps p2 else valid hyps (Not p2)).
  apply IHp2; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H3; propositional.
  apply valid_weaken with hyps.
  assumption.
  propositional.
  right; propositional.
  apply ValidImplyIntro.
  assert (IFF interp (fun x : var => hyps (Var x)) p1 then valid hyps p1 else valid hyps (Not p1)).
  apply IHp1; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H3; propositional.
  assert (IFF interp (fun x : var => hyps (Var x)) p2 then valid hyps p2 else valid hyps (Not p2)).
  apply IHp2; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H4; propositional.
  apply ValidImplyElim with p2.
  apply valid_weaken with hyps.
  assumption.
  propositional.
  apply ValidImplyElim with p1.
  apply ValidHyp.
  propositional.
  apply valid_weaken with hyps.
  assumption.
  propositional.
  left; propositional.
  apply ValidImplyIntro.
  assert (IFF interp (fun x : var => hyps (Var x)) p1 then valid hyps p1 else valid hyps (Not p1)).
  apply IHp1; propositional.
  apply H.
  apply in_or_app; propositional.
  unfold IF_then_else in H2; propositional.
  apply ValidFalsehoodElim.
  apply ValidImplyElim with p1.
  apply valid_weaken with hyps.
  assumption.
  propositional.
  apply ValidHyp.
  propositional.
Qed.

Lemma interp_valid' : forall p leftToDo alreadySplit,
    (forall x, In x (varsOf p) -> In x (alreadySplit ++ leftToDo))
    -> forall hyps, (forall x, In x alreadySplit -> hyps (Var x) \/ hyps (Not (Var x)))
    -> (forall x, hyps (Var x) \/ hyps (Not (Var x)) -> In x alreadySplit)
    -> (forall x, hyps (Var x) -> ~hyps (Not (Var x)))
    -> (forall vars : var -> Prop,
           (forall x, hyps (Var x) -> vars x)
           -> (forall x, hyps (Not (Var x)) -> ~vars x)
           -> interp vars p)
    -> valid hyps p.
Proof.
  induct leftToDo; simplify.

  rewrite app_nil_r in H.
  assert (IFF interp (fun x : var => hyps (Var x)) p then valid hyps p else valid hyps (Not p)).
  apply interp_valid''; first_order.
  unfold IF_then_else in H4; propositional.
  exfalso.
  apply H4.
  apply H3.
  propositional.
  first_order.

  excluded_middle (In a alreadySplit).

  apply IHleftToDo with alreadySplit; simplify.
  apply H in H5.
  apply in_app_or in H5.
  simplify.
  apply in_or_app.
  propositional; subst.
  propositional.
  first_order.
  first_order.
  first_order.
  first_order.

  apply ValidOrElim with (Var a) (Not (Var a)).
  apply ValidExcludedMiddle.

  apply IHleftToDo with (alreadySplit ++ [a]); simplify.
  apply H in H5.
  apply in_app_or in H5.
  simplify.
  apply in_or_app.
  propositional; subst.
  left; apply in_or_app; propositional.
  left; apply in_or_app; simplify; propositional.
  apply in_app_or in H5.
  simplify.
  propositional; subst.
  apply H0 in H6.
  propositional.
  propositional.
  propositional.
  invert H5.
  apply in_or_app.
  simplify.
  propositional.
  apply in_or_app.
  simplify.
  first_order.
  invert H5.
  apply in_or_app.
  simplify.
  first_order.
  propositional.
  invert H5.
  invert H7.
  first_order.
  invert H5.
  first_order.
  apply H3.
  first_order.
  first_order.

  apply IHleftToDo with (alreadySplit ++ [a]); simplify.
  apply H in H5.
  apply in_app_or in H5.
  simplify.
  apply in_or_app.
  propositional; subst.
  left; apply in_or_app; propositional.
  left; apply in_or_app; simplify; propositional.
  apply in_app_or in H5.
  simplify.
  propositional; subst.
  apply H0 in H6.
  propositional.
  propositional.
  propositional.
  invert H5.
  apply in_or_app.
  simplify.
  first_order.
  invert H5.
  apply in_or_app.
  simplify.
  propositional.
  apply in_or_app.
  simplify.
  first_order.
  propositional.
  invert H7.
  invert H7.
  invert H5.
  first_order.
  first_order.
  apply H3.
  first_order.
  first_order.
Qed.

Theorem interp_valid : forall p,
    (forall vars, interp vars p)
    -> valid (fun _ => False) p.
Proof.
  simplify.
  apply interp_valid' with (varsOf p) []; simplify; first_order.
Qed.
*)


Require Import Bool Setoid ZArith.
Require Export List.
Require Omega.

(*********************************firstn/skipn*********************************)

Lemma firstn_nil : forall {A : Type} (n : nat), firstn n (@nil A) = @nil A.
Proof.
  intros ? []; reflexivity.
Qed.

Lemma skipn_nil : forall {A : Type} (n : nat), skipn n (@nil A) = @nil A.
Proof.
  intros ? []; reflexivity.
Qed.

Notation length_firstn := firstn_length.

Lemma length_skipn : forall {A : Type} (n : nat) (l : list A),
  length (skipn n l) = length l - n.
Proof.
  intros ? n; induction n as [| n' IHn']; intro l.
  - apply minus_n_O.
  - destruct l.
    + reflexivity.
    + apply IHn'.
Qed.

Lemma skipn_whole : forall {A : Type} (n : nat) (l : list A),
  n >= length l -> skipn n l = nil.
Proof.
  intros ? n l ?.
  assert (length (skipn n l) = 0). {
    rewrite length_skipn.
    omega.
  }
  destruct (skipn n l).
  - reflexivity.
  - discriminate.
Qed.

Lemma firstn_whole : forall {A : Type} (n : nat) (l : list A),
  n >= length l -> firstn n l = l.
Proof.
  intros ? n l ?.
  rewrite <- (firstn_skipn n l) at 2.
  rewrite skipn_whole; try assumption.
  apply app_nil_end.
Qed.

Lemma firstn_firstn : forall {A : Type} (n m : nat) (l : list A),
  firstn n (firstn m l) = firstn (min n m) l.
Proof.
  intros ? n m l; destruct (le_ge_dec n m).
  - rewrite min_l; try assumption.
    generalize dependent m; generalize dependent n;
    induction l as [| h t IHt]; intros n m ?.
    + rewrite (firstn_nil m). reflexivity.
    + destruct n.
      * reflexivity.
      *{destruct m.
        - omega.
        - simpl. f_equal.
          apply IHt. omega.
      }
  - rewrite min_r; try assumption.
    apply firstn_whole.
    rewrite length_firstn.
    apply (le_trans _ m).
    + apply NPeano.Nat.le_min_l.
    + assumption.
Qed.

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

(**********************************list bool***********************************)

Delimit Scope word_scope with word.

Local Open Scope word_scope.

Notation "l ~ b" := (b :: l)
 (at level 7, left associativity, format "l '~' b") : word_scope.
Notation "l ~ 0" := (false :: l)
 (at level 7, left associativity, format "l '~' '0'") : word_scope.
Notation "l ~ 1" := (true :: l)
 (at level 7, left associativity, format "l '~' '1'") : word_scope.

Notation "w1 # w2" := (w2 ++ w1)
 (at level 60, right associativity) : word_scope.

Fixpoint list_bool_to_N (l : list bool) : N :=
  match l with
  | nil => N0
  | t~0 => N.double (list_bool_to_N t)
  | t~1 => N.succ_double (list_bool_to_N t)
  end.

Fixpoint list_bool_of_N (len : nat) (n : N) : list bool :=
  match len with
  | 0 => nil
  | S len' => match n with
              | N0 => (list_bool_of_N len' N0)~0
              | Npos xH => (list_bool_of_N len' N0)~1
              | Npos (xO p) => (list_bool_of_N len' (Npos p))~0
              | Npos (xI p) => (list_bool_of_N len' (Npos p))~1
              end
  end.

Notation falsen := (fun n : nat => nat_iter n (cons false) nil).
Notation truen := (fun n : nat => nat_iter n (cons true) nil).

Fixpoint blist {A B C : Type} (f : A -> B -> C) (l1 : list A) (l2 : list B) :=
  match l1, l2 with
  | nil, _ => nil
  | _, nil => nil
  | h1 :: t1, h2 :: t2 => f h1 h2 :: blist f t1 t2
  end.

Lemma length_of_N : forall (len : nat) (n : N),
  length (list_bool_of_N len n) = len.
Proof.
  intro len; induction len; intro n.
  - reflexivity.
  - destruct n as [| []]; simpl; f_equal; trivial.
Qed.

Lemma length_iter_cons : forall {A : Type} (n : nat) (h : A) (t : list A),
  length (nat_iter n (cons h) t) = n + length t.
Proof.
  intros ? n ? ?; induction n.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Lemma iter_cons_split : forall {A : Type} (n m : nat) (h : A),
  nat_iter (n + m) (cons h) nil = nat_iter n (cons h) nil ++
                                  nat_iter m (cons h) nil.
Proof.
  intros ? n ? ?; induction n.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Lemma firstn_iter_cons : forall {A : Type} (n m : nat) (h : A),
  firstn n (nat_iter m (cons h) nil) = nat_iter (min n m) (cons h) nil.
Proof.
  intros ? n m ?.
  generalize dependent m;
  induction n; intro m.
  - reflexivity.
  - destruct m.
    + reflexivity.
    + simpl. f_equal. trivial.
Qed.

Lemma length_blist :
  forall {A B C : Type} (f : A -> B -> C) (l1 : list A) (l2 : list B),
  length (blist f l1 l2) = min (length l1) (length l2).
Proof.
  intros ? ? ? ? l1; induction l1; intro l2.
  - reflexivity.
  - destruct l2.
    + reflexivity.
    + simpl. f_equal. trivial.
Qed.

Lemma blist_firstn :
  forall {A B C : Type} (f : A -> B -> C) (l1 : list A) (l2 : list B) n m,
  blist f (firstn n l1) (firstn m l2) = firstn (min n m) (blist f l1 l2).
Proof.
  intros ? ? ? ? l1 l2 n.
  generalize dependent l2; generalize dependent l1;
  induction n; intros l1 l2 m.
  - reflexivity.
  - destruct l1, l2, m; try reflexivity.
    simpl. f_equal. trivial.
Qed.

Lemma blist_app :
  forall {A B C : Type} (f : A -> B -> C) (l1 l1' : list A) (l2 l2' : list B),
  length l1 = length l2 ->
  blist f (l1 ++ l1') (l2 ++ l2') = (blist f l1 l2) ++ (blist f l1' l2').
Proof.
  intros ? ? ? ? l1 ? l2 ?.
  generalize dependent l2;
  induction l1; intros l2 ?.
  - destruct l2; reflexivity || discriminate.
  - destruct l2.
    + discriminate.
    + simpl. f_equal. auto.
Qed.

Lemma blist_andb_falsen_l : forall (n : nat) (l : list bool),
  blist andb (falsen n) l = falsen (min n (length l)).
Proof.
  intro n; induction n; intro l.
  - reflexivity.
  - destruct l.
    + reflexivity.
    + simpl. f_equal. trivial.
Qed.

Lemma blist_andb_falsen_r : forall (l : list bool) (n : nat),
  blist andb l (falsen n) = falsen (min (length l) n).
Proof.
  intro l; induction l; intro n.
  - reflexivity.
  - destruct n.
    + reflexivity.
    + simpl. f_equal.
      * apply andb_false_r.
      * trivial.
Qed.

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

(*************************************word*************************************)

Definition word (n : nat) : Set := {l : list bool | length l = n}.

Definition weq {n m : nat} (w1 : word n) (w2 : word m) : Prop :=
  match w1, w2 with exist l1 _, exist l2 _ => l1 = l2 end.
Infix "==" := weq (at level 80, no associativity) : word_scope.

Lemma weq_refl : forall {n : nat} (w : word n), w == w.
Proof.
  intros ? w; destruct w.
  reflexivity.
Qed.

Lemma weq_sym : forall {n m : nat} (w1 : word n) (w2 : word m),
  w1 == w2 -> w2 == w1.
Proof.
  intros ? ? w1 w2; destruct w1, w2.
  apply eq_sym.
Qed.

Lemma weq_trans :
  forall {n m l : nat} (w1 : word n) (w2 : word m) (w3 : word l),
  w1 == w2 -> w2 == w3 -> w1 == w3.
Proof.
  intros ? ? ? w1 w2 w3; destruct w1, w2, w3.
  apply eq_trans.
Qed.

Add Parametric Relation (n : nat) : (word n) weq
  reflexivity proved by weq_refl
  symmetry proved by weq_sym
  transitivity proved by weq_trans as weq_rel.

Definition wto_N {n : nat} (w : word n) : N :=
  let (l, _) := w in list_bool_to_N l.

Definition wof_N (len : nat) (n : N) : word len.
  refine (exist _ (list_bool_of_N len n) _).
  apply length_of_N.
Defined.

Lemma wto_N_id : forall {n : nat} (w : word n), wof_N n (wto_N w) == w.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l as [| h t IHt].
  - reflexivity.
  - destruct h; simpl; destruct (list_bool_to_N t); simpl; congruence.
Qed.

Lemma wof_N_mod : forall (len : nat) (n : N),
  wto_N (wof_N len n) = (n mod (Npos (shift_nat len xH)))%N.
Proof.
  intro len; simpl; induction len as [| len' IHlen']; intro n.
  - symmetry; apply N.mod_1_r.
  - destruct n as [| []]; simpl; rewrite IHlen'; simpl.
    + symmetry; apply N.mod_0_l. discriminate.
    + rewrite <- (N.mod_small (N.succ_double _) (Npos (shift_nat (S len') 1))).
      Focus 2.
        change (Npos (shift_nat (S len') 1))
        with (N.double (Npos (shift_nat len' 1))).
        apply N.succ_double_lt. apply N.mod_lt. discriminate.
      rewrite N.succ_double_spec.
      rewrite <- N.mul_mod_distr_l; try discriminate.
      rewrite N.add_mod_idemp_l; try discriminate.
      reflexivity.
    + rewrite N.double_spec.
      rewrite <- N.mul_mod_distr_l; try discriminate.
      reflexivity.
    + symmetry; apply N.mod_1_l. reflexivity.
Qed.

Lemma wof_N_weq : forall {len : nat} (n : N) (w : word len),
  (n mod (Npos (shift_nat len xH)))%N = wto_N w -> wof_N len n == w.
Proof.
  assert (H0 : forall n1 n2 : N, N.succ_double n1 <> N.double n2)
  by (intros [] []; discriminate).
  intros ? n w; destruct w as [l Hl]; subst; simpl.
  generalize dependent n;
  induction l as [| h t IHt]; intros n H.
  - reflexivity.
  - destruct n as [| [p | p |]].
    + rewrite N.mod_0_l in H; try discriminate.
      destruct h; simpl in *.
      * destruct (list_bool_to_N t); discriminate.
      * f_equal. apply IHt. rewrite N.mod_0_l; try discriminate.
        destruct (list_bool_to_N t); reflexivity || discriminate.
    + replace (_ mod _)%N
      with (N.succ_double (Npos p mod Npos (shift_nat (length t) 1))) in H.
      Focus 2.
        rewrite <- (N.mod_small (N.succ_double _)
                                (N.pos (shift_nat (S (length t)) 1))). Focus 2.
          change (N.pos (shift_nat (S (length t)) 1))
          with (N.double (N.pos (shift_nat (length t) 1))).
          apply N.succ_double_lt. apply N.mod_lt. discriminate.
        rewrite N.succ_double_spec.
        rewrite <- N.mul_mod_distr_l; try discriminate.
        apply N.add_mod_idemp_l. discriminate.
      destruct h; simpl in *.
      * f_equal. apply IHt. apply N.succ_double_inj. assumption.
      * elim (H0 _ _ H).
    + replace (_ mod _)%N
      with (N.double (Npos p mod Npos (shift_nat (length t) 1))) in H.
      Focus 2.
        rewrite N.double_spec. rewrite <- N.mul_mod_distr_l; try discriminate.
        reflexivity.
      destruct h; simpl in *.
      * elim (H0 _ _ (eq_sym H)).
      * f_equal. apply IHt. apply N.double_inj. assumption.
    + rewrite N.mod_1_l in H; try reflexivity.
      destruct h; simpl in *.
      * f_equal. apply IHt. rewrite N.mod_0_l; try discriminate.
        destruct (list_bool_to_N t); reflexivity || discriminate.
      * destruct (list_bool_to_N t); discriminate.
Qed.

Lemma weq_iff_Neq : forall {n : nat} (w1 w2 : word n),
  w1 == w2 <-> wto_N w1 = wto_N w2.
Proof.
  intros ? w1 w2; split; intro H.
  - destruct w1, w2; simpl in *; subst. reflexivity.
  - rewrite <- (wto_N_id w1). rewrite H. apply wto_N_id.
Qed.

Definition wfalse (n : nat) : word n.
  refine (exist _ (falsen n) _).
  rewrite length_iter_cons.
  apply plus_0_r.
Defined.

Lemma wto_N_wfalse : forall n : nat, wto_N (wfalse n) = N0.
Proof.
  intro n; simpl; induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite IHn'. reflexivity.
Qed.

Lemma wof_N_0 : forall n : nat, wof_N n 0 == wfalse n.
Proof.
  intro n; induction n.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Definition wtrue (n : nat) : word n.
  refine (exist _ (truen n) _).
  rewrite length_iter_cons.
  apply plus_0_r.
Defined.

Definition wnot {n : nat} (w : word n) : word n.
  refine (let (l, _) := w in exist _ (map negb l) _).
  rewrite map_length.
  assumption.
Defined.
Notation "~ w" := (wnot w) (at level 75, right associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wnot n) with
  signature weq ==> weq as wnot_mor.
Proof.
  intros w w'; destruct w, w'; simpl; intro.
  subst. reflexivity.
Qed.

Definition wor {n : nat} (w1 w2 : word n) : word n.
  refine (match w1, w2 with
            exist l1 H1, exist l2 H2 => exist _ (blist orb l1 l2) _
          end).
  rewrite length_blist.
  rewrite H1. rewrite H2.
  apply NPeano.Nat.min_id.
Defined.
Infix "|" := wor (at level 77, left associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wor n) with
  signature weq ==> weq ==> weq as wor_mor.
Proof.
  intros w1 w1' ? w2 w2' ?; destruct w1, w1', w2, w2'; simpl in *.
  subst. reflexivity.
Qed.

Definition wand {n : nat} (w1 w2 : word n) : word n.
  refine (match w1, w2 with
            exist l1 H1, exist l2 H2 => exist _ (blist andb l1 l2) _
          end).
  rewrite length_blist.
  rewrite H1. rewrite H2.
  apply NPeano.Nat.min_id.
Defined.
Infix "&" := wand (at level 76, left associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wand n) with
  signature weq ==> weq ==> weq as wand_mor.
Proof.
  intros w1 w1' ? w2 w2' ?; destruct w1, w1', w2, w2'; simpl in *.
  subst. reflexivity.
Qed.

Definition wshl {n : nat} (w1 w2 : word n) : word n.
  refine (let (l1, _) := w1 in
            exist _ (firstn n (l1 # falsen (N.to_nat (wto_N w2)))) _).
  rewrite length_firstn. rewrite app_length. rewrite length_iter_cons.
  apply min_l. omega.
Defined.
Infix "<<" := wshl (at level 65, left associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wshl n) with
  signature weq ==> weq ==> weq as wshl_mor.
Proof.
  intros w1 w1' ? w2 w2' ?; destruct w1, w1', w2, w2'; simpl in *.
  subst. reflexivity.
Qed.

Definition wshr {n : nat} (w1 w2 : word n) : word n.
  refine (let (l1, _) := w1 in
            exist _ (skipn (N.to_nat (wto_N w2))
                           (falsen (N.to_nat (wto_N w2)) # l1)) _).
  rewrite length_skipn. rewrite app_length. rewrite length_iter_cons.
  simpl; omega.
Defined.
Infix ">>" := wshr (at level 65, left associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wshr n) with
  signature weq ==> weq ==> weq as wshr_mor.
Proof.
  intros w1 w1' ? w2 w2' ?; destruct w1, w1', w2, w2'; simpl in *.
  subst. reflexivity.
Qed.

Definition wsar {n : nat} (w1 w2 : word n) : word n.
  refine (let (l1, _) := w1 in
            exist _ (skipn (N.to_nat (wto_N w2))
                           ((nat_iter (N.to_nat (wto_N w2))
                                      (cons (last l1 false)) nil)
                           # l1)) _).
  rewrite length_skipn. rewrite app_length. rewrite length_iter_cons.
  simpl; omega.
Defined.
Infix ">->" := wsar (at level 65, left associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wsar n) with
  signature weq ==> weq ==> weq as wsar_mor.
Proof.
  intros w1 w1' ? w2 w2' ?; destruct w1, w1', w2, w2'; simpl in *.
  subst. reflexivity.
Qed.

Definition wopp {n : nat} (w : word n) : word n :=
  wof_N n (N.succ (wto_N (~w))).
Notation "- w" := (wopp w) (at level 35, right associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wopp n) with
  signature weq ==> weq as wopp_mor.
Proof.
  intros w w'; destruct w, w'; simpl; intro.
  subst. reflexivity.
Qed.

Definition wadd {n : nat} (w1 w2 : word n) : word n :=
  wof_N n (wto_N w1 + wto_N w2).
Infix "+" := wadd (at level 50, left associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wadd n) with
  signature weq ==> weq ==> weq as wadd_mor.
Proof.
  intros w1 w1' ? w2 w2' ?; destruct w1, w1', w2, w2'; simpl in *.
  subst. reflexivity.
Qed.

Definition wsub {n : nat} (w1 w2 : word n) : word n := w1 + (- w2).
Infix "-" := wsub (at level 50, left associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wsub n) with
  signature weq ==> weq ==> weq as wsub_mor.
Proof.
  unfold wsub. intros w1 w1' H1 w2 w2' H2.
  rewrite H1. rewrite H2. reflexivity.
Qed.

Definition wmul {n : nat} (w1 w2 : word n) : word n :=
  wof_N n (wto_N w1 * wto_N w2).
Infix "*" := wmul (at level 40, left associativity) : word_scope.

Add Parametric Morphism (n : nat) : (@wmul n) with
  signature weq ==> weq ==> weq as wmul_mor.
Proof.
  intros w1 w1' ? w2 w2' ?; destruct w1, w1', w2, w2'; simpl in *.
  subst. reflexivity.
Qed.

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

(***********************************boolean************************************)

Lemma wand_assoc : forall {n : nat} (w1 w2 w3 : word n),
  w1 & (w2 & w3) == w1 & w2 & w3.
Proof.
  intros ? w1 w2 w3;
  destruct w1 as [l1 Hl1], w2 as [l2 Hl2], w3 as [l3 Hl3]; simpl.
  clear; generalize dependent l3; generalize dependent l2;
  induction l1; intros l2 l3.
  - reflexivity.
  - destruct l2, l3; try reflexivity; simpl. f_equal.
    + apply andb_assoc.
    + trivial.
Qed.

Lemma wand_comm : forall {n : nat} (w1 w2 : word n),
  w1 & w2 == w2 & w1.
Proof.
  intros ? w1 w2; destruct w1 as [l1 Hl1], w2 as [l2 Hl2]; simpl.
  clear; generalize dependent l2;
  induction l1; intro l2; destruct l2; try reflexivity.
  simpl. f_equal.
  - apply andb_comm.
  - trivial.
Qed.

Lemma wand_wnot_r : forall {n : nat} (w : word n), w & ~w == wfalse n.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l.
  - reflexivity.
  - simpl. f_equal.
    + apply andb_negb_r.
    + assumption.
Qed.

Lemma weq_iff : forall {n : nat} (w1 w2 : word n),
  w1 == w2 <-> w1 & ~w2 == wfalse n /\ w2 & ~w1 == wfalse n.
Proof.
  intros ? w1 w2; split.
  - intro H. rewrite <- H.
    refine ((fun p => conj p p) _).
    clear; destruct w1 as [l1 Hl1]; subst; simpl; induction l1.
    + reflexivity.
    + simpl. f_equal.
      * apply andb_negb_r.
      * assumption.
  - destruct w1 as [l1 Hl1], w2 as [l2 Hl2]; subst; simpl.
    generalize dependent l2;
    induction l1 as [| h1 t1 IHt1]; intros l2 H [H1 H2].
    + destruct l2.
      * reflexivity.
      * discriminate.
    + destruct l2 as [| h2 t2].
      * discriminate.
      * destruct h1, h2; try discriminate; f_equal;
        inversion H; inversion H1; inversion H2; auto.
Qed.

Lemma wnot_involutive : forall {n : nat} (w : word n), ~~w == w.
Proof.
  intros ? w; destruct w as [l Hl]; simpl; clear; induction l.
  - reflexivity.
  - simpl. f_equal.
    + apply negb_involutive.
    + assumption.
Qed.

Lemma wnot_wor : forall {n : nat} (w1 w2 : word n), ~(w1 | w2) == ~w1 & ~w2.
Proof.
  intros ? w1 w2; destruct w1 as [l1 Hl1], w2 as [l2 Hl2]; simpl.
  clear; generalize dependent l2;
  induction l1; intro l2.
  - reflexivity.
  - destruct l2.
    + reflexivity.
    + simpl. f_equal.
      * apply negb_orb.
      * trivial.
Qed.

Lemma wnot_wand : forall {n : nat} (w1 w2 : word n), ~(w1 & w2) == ~w1 | ~w2.
Proof.
  intros ? w1 w2; destruct w1 as [l1 Hl1], w2 as [l2 Hl2]; simpl.
  clear; generalize dependent l2;
  induction l1; intro l2.
  - reflexivity.
  - destruct l2.
    + reflexivity.
    + simpl. f_equal.
      * apply negb_andb.
      * trivial.
Qed.

Lemma wand_wor_distrib_l : forall {n : nat} (w1 w2 w3 : word n),
  (w1 | w2) & w3 == w1 & w3 | w2 & w3.
Proof.
  intros ? w1 w2 w3;
  destruct w1 as [l1 Hl1], w2 as [l2 Hl2], w3 as [l3 Hl3]; simpl.
  clear; generalize dependent l3; generalize dependent l2;
  induction l1; intros l2 l3.
  - reflexivity.
  - destruct l2, l3; try reflexivity.
    simpl. f_equal.
    + apply andb_orb_distrib_l.
    + trivial.
Qed.

Lemma wand_wor_distrib_r : forall {n : nat} (w1 w2 w3 : word n),
  w1 & (w2 | w3) == w1 & w2 | w1 & w3.
Proof.
  intros ? w1 w2 w3;
  destruct w1 as [l1 Hl1], w2 as [l2 Hl2], w3 as [l3 Hl3]; simpl.
  clear; generalize dependent l3; generalize dependent l2;
  induction l1; intros l2 l3.
  - reflexivity.
  - destruct l2, l3; try reflexivity.
    simpl. f_equal.
    + apply andb_orb_distrib_r.
    + trivial.
Qed.

Lemma wnot_wfalse : forall n : nat, ~wfalse n == wtrue n.
Proof.
  intro n; induction n.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Lemma wnot_wtrue : forall n : nat, ~wtrue n == wfalse n.
Proof.
  intro n; induction n.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Lemma wand_wfalse_l : forall {n : nat} (w : word n), wfalse n & w == wfalse n.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Lemma wand_wfalse_r : forall {n : nat} (w : word n), w & wfalse n == wfalse n.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l.
  - reflexivity.
  - simpl. f_equal.
    + apply andb_false_r.
    + assumption.
Qed.

Lemma wand_wtrue_l : forall {n : nat} (w : word n), wtrue n & w == w.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Lemma wand_wtrue_r : forall {n : nat} (w : word n), w & wtrue n == w.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l.
  - reflexivity.
  - simpl. f_equal.
    + apply andb_true_r.
    + assumption.
Qed.

Lemma wor_wtrue_l : forall {n : nat} (w : word n), wtrue n | w == wtrue n.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Lemma wor_wtrue_r : forall {n : nat} (w : word n), w | wtrue n == wtrue n.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l.
  - reflexivity.
  - simpl. f_equal.
    + apply orb_true_r.
    + assumption.
Qed.

Lemma wor_wfalse_l : forall {n : nat} (w : word n), wfalse n | w == w.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Lemma wor_wfalse_r : forall {n : nat} (w : word n), w | wfalse n == w.
Proof.
  intros ? w; destruct w as [l Hl]; subst; simpl; induction l.
  - reflexivity.
  - simpl. f_equal.
    + apply orb_false_r.
    + assumption.
Qed.

Lemma wor_wfalse_intro : forall {n : nat} (w1 w2 : word n),
  w1 == wfalse n -> w2 == wfalse n -> w1 | w2 == wfalse n.
Proof.
  intros ? ? ? H1 H2. rewrite H1. rewrite H2. apply wor_wfalse_l.
Qed.

Lemma wand_wfalse_intro1 : forall {n : nat} (w1 w2 : word n),
  w1 == wfalse n -> w1 & w2 == wfalse n.
Proof.
  intros ? ? ? H. rewrite H. apply wand_wfalse_l.
Qed.

Ltac wand_weqf :=
  lazymatch goal with
    |- context [wnot _] => repeat rewrite wand_assoc;
        lazymatch goal with
        | |- ?E & ~?W == _ =>
              lazymatch E with
              | W => apply wand_wnot_r
              | ?E' & W => rewrite <- (wand_assoc E' W (~W));
                           rewrite (wand_wnot_r W);
                           apply wand_wfalse_r
              | context [W & _] =>
                  lazymatch E with
                    ?E1 & ?E2 => rewrite (wand_comm E1 E2); wand_weqf
                  end
              | context [_ & W] =>
                  lazymatch E with
                    ?E1 & ?E2 => rewrite (wand_comm E1 E2); wand_weqf
                  end
              | _ => apply wand_wfalse_intro1; wand_weqf
              end
        | |- ?E & ?W == _ => rewrite (wand_comm E W); wand_weqf
        end
  end.

Ltac weq_bool :=
  intros; apply weq_iff;
  repeat (rewrite wnot_involutive || rewrite wnot_wor || rewrite wnot_wand);
  repeat (rewrite wand_wor_distrib_l || rewrite wand_wor_distrib_r);
  try rewrite wnot_wfalse; try rewrite wnot_wtrue;
  repeat (rewrite wand_wfalse_l || rewrite wand_wfalse_r);
  repeat (rewrite wand_wtrue_l || rewrite wand_wtrue_r);
  repeat (rewrite wor_wtrue_l || rewrite wor_wtrue_r);
  repeat (rewrite wor_wfalse_l || rewrite wor_wfalse_r);
  split; repeat apply wor_wfalse_intro; try reflexivity; try wand_weqf.

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

(************************************shift*************************************)

Lemma wand_1_wshl : forall {n : nat} (w1 w2 : word n),
  ~ (w1 == w2) -> ((wof_N n 1) << w1) & ((wof_N n 1) << w2) == wfalse n.
Proof.
  intros ? w1 w2 H. rewrite weq_iff_Neq in H.
  rewrite <- Nnat.N2Nat.inj_iff in H.
  destruct n as [| n'].
  - reflexivity.
  - change (blist andb
      (firstn (S n') (((list_bool_of_N n' 0) # nil~1) #
                      nat_iter (N.to_nat (wto_N w1)) (cons false) nil))
      (firstn (S n') (((list_bool_of_N n' 0) # nil~1) #
                      nat_iter (N.to_nat (wto_N w2)) (cons false) nil)) =
      nat_iter (S n') (cons false) nil).
    rewrite blist_firstn. rewrite NPeano.Nat.min_id. rewrite wof_N_0.
    apply not_eq in H; destruct H.
    + rewrite (app_assoc (nat_iter (N.to_nat (wto_N w1)) (cons false) nil)).
      replace (N.to_nat (wto_N w2))
      with (S (N.to_nat (wto_N w1)) +
            (N.to_nat (wto_N w2) - S (N.to_nat (wto_N w1))))%nat by omega.
      rewrite iter_cons_split.
      rewrite <- (app_assoc (nat_iter (S (N.to_nat (wto_N w1)))
                                      (cons false) nil)).
      rewrite blist_app. Focus 2.
        rewrite app_length. repeat rewrite length_iter_cons. simpl; omega.
      rewrite blist_andb_falsen_l. rewrite blist_andb_falsen_r.
      rewrite <- iter_cons_split. rewrite firstn_iter_cons. f_equal.
      apply min_l. repeat rewrite app_length. repeat rewrite length_iter_cons.
      repeat rewrite min_l; simpl; omega.
    + rewrite (app_assoc (nat_iter (N.to_nat (wto_N w2)) (cons false) nil)).
      replace (N.to_nat (wto_N w1))
      with (S (N.to_nat (wto_N w2)) +
            (N.to_nat (wto_N w1) - S (N.to_nat (wto_N w2))))%nat by omega.
      rewrite iter_cons_split.
      rewrite <- (app_assoc (nat_iter (S (N.to_nat (wto_N w2)))
                                      (cons false) nil)).
      rewrite blist_app. Focus 2.
        rewrite app_length. repeat rewrite length_iter_cons. simpl; omega.
      rewrite blist_andb_falsen_l. rewrite blist_andb_falsen_r.
      rewrite <- iter_cons_split. rewrite firstn_iter_cons. f_equal.
      apply min_l. repeat rewrite app_length. repeat rewrite length_iter_cons.
      repeat rewrite min_r; simpl; omega.
Qed.

Ltac wand_1_wshl_weqf w1 w2 :=
  lazymatch goal with
    |- context [(wof_N _ 1) << w2] => repeat rewrite wand_assoc;
        lazymatch goal with
        | |- ?E & ((wof_N _ 1) << w2) == _ =>
              lazymatch E with
              | (wof_N _ 1) << w1 => apply wand_1_wshl
              | ?E' & ((wof_N _ 1) << w1) => rewrite <- (wand_assoc E' _ _);
                                             rewrite (wand_1_wshl w1 w2);
                                             try apply wand_wfalse_r
              | context [((wof_N _ 1) << w1) & _] =>
                  lazymatch E with
                    ?E1 & ?E2 => rewrite (wand_comm E1 E2);
                                 wand_1_wshl_weqf w1 w2
                  end
              | context [_ & ((wof_N _ 1) << w1)] =>
                  lazymatch E with
                    ?E1 & ?E2 => rewrite (wand_comm E1 E2);
                                 wand_1_wshl_weqf w1 w2
                  end
              end
        | |- ?E & ?W == _ => rewrite (wand_comm E W); wand_1_wshl_weqf w1 w2
        end
  end.

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

(*************************************ring*************************************)

Lemma wadd_0_l : forall {n : nat} (w : word n), wfalse n + w == w.
Proof.
  unfold wadd. intros. rewrite wto_N_wfalse. apply wto_N_id.
Qed.

Lemma wadd_sym : forall {n : nat} (w1 w2 : word n), w1 + w2 == w2 + w1.
Proof.
  unfold wadd. intros. rewrite N.add_comm. reflexivity.
Qed.

Lemma wadd_assoc : forall {n : nat} (w1 w2 w3 : word n),
  w1 + (w2 + w3) == w1 + w2 + w3.
Proof.
  unfold wadd. intros. apply wof_N_weq. repeat rewrite wof_N_mod.
  rewrite N.add_mod_idemp_l; try discriminate.
  rewrite N.add_mod_idemp_r; try discriminate.
  rewrite N.add_assoc. reflexivity.
Qed.

Lemma wmul_1_l : forall {n : nat} (w : word n), (wof_N n 1) * w == w.
Proof.
  unfold wmul. intros n w. rewrite wof_N_mod.
  destruct n as [| n'].
  - destruct w as [l Hl]. destruct l; reflexivity || discriminate.
  - rewrite N.mod_1_l; try reflexivity. rewrite N.mul_1_l. apply wto_N_id.
Qed.

Lemma wmul_sym : forall {n : nat} (w1 w2 : word n), w1 * w2 == w2 * w1.
Proof.
  unfold wmul. intros. rewrite N.mul_comm. reflexivity.
Qed.

Lemma wmul_assoc : forall {n : nat} (w1 w2 w3 : word n),
  w1 * (w2 * w3) == w1 * w2 * w3.
Proof.
  unfold wmul. intros. apply wof_N_weq. repeat rewrite wof_N_mod.
  rewrite N.mul_mod_idemp_l; try discriminate.
  rewrite N.mul_mod_idemp_r; try discriminate.
  rewrite N.mul_assoc. reflexivity.
Qed.

Lemma wdistr_l : forall {n : nat} (w1 w2 w3 : word n),
  (w1 + w2) * w3 == w1 * w3 + w2 * w3.
Proof.
  unfold wadd, wmul. intros. apply wof_N_weq. repeat rewrite wof_N_mod.
  rewrite N.mul_mod_idemp_l; try discriminate.
  rewrite <- N.add_mod; try discriminate.
  rewrite N.mul_add_distr_r. reflexivity.
Qed.

Lemma wsub_def : forall {n : nat} (w1 w2 : word n), w1 - w2 == w1 + (- w2).
Proof.
  reflexivity.
Qed.

Lemma wopp_def : forall {n : nat} (w : word n), w + (- w) == wfalse n.
Proof.
  unfold wopp, wadd. intros ? w. rewrite wof_N_mod. apply wof_N_weq.
  rewrite wto_N_wfalse. rewrite N.add_mod_idemp_r; try discriminate.
  replace (wto_N w + N.succ (wto_N (~ w)))%N with (N.pos (shift_nat n 1)).
  - apply N.mod_same. discriminate.
  - destruct w as [l Hl]; subst; simpl; induction l as [| h t IHt].
    + reflexivity.
    + destruct h; simpl.
      * rewrite N.succ_double_spec. rewrite <- N.add_assoc.
        rewrite <- N.add_1_l. rewrite (N.add_assoc 1).
        change (1 + 1)%N with (2 * 1)%N. repeat rewrite <- N.mul_add_distr_l.
        rewrite N.add_1_l. rewrite <- IHt. reflexivity.
      * rewrite N.succ_double_spec. rewrite <- N.add_1_r.
        rewrite <- (N.add_assoc _ 1). change (1 + 1)%N with (2 * 1)%N.
        rewrite N.double_spec. repeat rewrite <- N.mul_add_distr_l.
        rewrite N.add_1_r. rewrite <- IHt. reflexivity.
Qed.

Module Type Word.
  Parameter n : nat.
End Word.

Module RingWord (Import W : Word).
Add Ring word_ring : (mk_rt (wfalse n) _ _ _ _ _ _
  wadd_0_l wadd_sym wadd_assoc
  wmul_1_l wmul_sym wmul_assoc
  wdistr_l wsub_def wopp_def).
End RingWord.

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


Require Import List Omega.

Require Import bigstep.
Require Import coinduction.
Require Import datatypes.
Require Import streams_vs_lists.

(* Function div2(n) = n/2       if n is even
                      undefined otherwise

   Example machine:
      1 1 -> 1 B
      1 B -> 2 R
      2 1 -> 3 R
      3 B -> 3 R
      3 1 -> 4 B
      4 B -> 2 R
*)

Definition div2: Spec := (1, one, 1, W B) ::
                         (1, B  , 2,   R) ::
                         (2, one, 3,   R) ::
                         (3, B  , 3,   R) ::
                         (3, one, 4, W B) ::
                         (4, B  , 2,   R) :: nil.

(************************ Divergence proof ************************)

Fixpoint ones (n:nat) {struct n}: list Sym :=
         match n with
         | 0 => nil
         | (S m) => (cons one (ones m))
         end.

(*
loop from state 3, if Bs on the right
*)

Lemma div2_loops_3B: forall l,
      bi div2 (pair l Bs) 3.
cofix co_hp.
intro. apply biR with 3.
auto.
simpl. apply co_hp.
Qed.

(*
loop from state 2, if an odd number of "1"
*)

Lemma div2_loops_2odd: forall n l,
      bi div2 (pair l (app_ls (ones (2*n + 1)) Bs)) 2.
induction n; intro.

simpl. apply biR with 3.
auto.
simpl. apply div2_loops_3B.

replace (2*S n + 1) with (S (S (2*n + 1))).
simpl. apply biR with 3.
auto.
simpl. apply biW with 4 B.
auto.
simpl. apply biR with 2.
auto.
simpl. replace (n + (n + 0) + 1) with (2*n + 1). apply IHn.
omega. omega.
Qed.

(*
loop from the initial state 1
*)

Lemma div2_loops: forall n,
      bi div2 (pair Bs (Cons one (app_ls (ones (2*n + 1)) Bs))) 1.
intros. apply biW with 1 B.
auto.
simpl. apply biR with 2.
auto.
simpl. replace (n + (n + 0) + 1) with (2*n + 1). apply div2_loops_2odd.
omega.
Qed.


Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import ListExt.

Require Import folProp.
Require Import folProof.
Require Export folLogic.
Require Import subProp.
Require Import folReplace.
Require Import Arith.

Section More_Logic_Rules.

Variable L : Language.
Let Formula := Formula L.
Let Formulas := Formulas L.
Let System := System L.
Let Term := Term L.
Let Terms := Terms L.
Let Prf := Prf L.
Let SysPrf := SysPrf L.

Lemma rebindForall (T : System) (a b : nat) (f : Formula):
  ~ In b (freeVarFormula L (forallH a f)) ->
  SysPrf T (iffH (forallH a f)
              (forallH b (substituteFormula L f a (var b)))).
Proof.
  intros H; eapply (sysExtend L) with (Empty_set Formula).
  - intros x H0; destruct H0.
  - apply (iffI L).
    + apply (impI L), (forallI L).
      intros [x [H0 H1]].
      destruct H1 as [x H1| x H1]; [ induction H1 | induction H1 ].
      * auto.
      * apply forallE; apply Axm; right; constructor.
    + apply (impI L), (forallI L).
      intros [x [H0 H1]] ; destruct H1 as [x H1| x H1];
        [induction H1 | induction H1].
     * assert (H1: In a (freeVarFormula L (substituteFormula L f a (var b))))
       by (eapply in_remove; apply H0).
       induction (freeVarSubFormula3 _ _ _ _ _ H1).
       elim (in_remove_neq _ _ _ _ _ H2).
       -- auto.
       -- elim (in_remove_neq _ _ _ _ _ H0).
          destruct H2 as [H2| H2].
          auto.
          elim H2.
     * set (A1 := forallH b (substituteFormula L f a (var b))) in *.
       rewrite <- (subFormulaId L f a).
       apply (impE L) with
         (substituteFormula L (substituteFormula L f a (var b)) b
            (var a)).
       -- apply (iffE1 L).
          apply (subFormulaTrans L); apply H.
       -- apply forallE, Axm; right; constructor.
Qed.

Lemma rebindExist (T : System) (a b : nat) (f : Formula):
  ~ In b (freeVarFormula L (existH a f)) ->
  SysPrf T (iffH (existH a f) (existH b (substituteFormula L f a (var b)))).
Proof.
  intro H; unfold existH.
  apply (reduceNot L); eapply (iffTrans L).
  - apply (rebindForall T a b (notH f)), H.
  - rewrite (subFormulaNot L); apply (iffRefl L).
Qed.

Lemma subSubTerm (t : Term) (v1 v2 : nat) (s1 s2 : Term):
  v1 <> v2 ->
  ~ In v1 (freeVarTerm L s2) ->
  substituteTerm L (substituteTerm L t v1 s1) v2 s2 =
    substituteTerm L
      (substituteTerm L t v2 s2) v1 (substituteTerm L s1 v2 s2).
Proof.
  intros H H0.
  elim t using Term_Terms_ind with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
             substituteTerms L n (substituteTerms L n ts v1 s1) v2 s2 =
               substituteTerms L n (substituteTerms L n ts v2 s2) v1
                 (substituteTerm L s1 v2 s2)); simpl in |- *.
  - intros n.
    destruct (eq_nat_dec v1 n)  as [ e | n0].
    + destruct (eq_nat_dec v2 n)  as [e0 | n0].
      * elim H; transitivity n; auto.
      * simpl in |- *; destruct (eq_nat_dec v1 n)as [e0 | n1].
        -- reflexivity.
        -- elim n1;auto.
    + simpl in |- *; destruct (eq_nat_dec v2 n) as [e | n1].
      * rewrite subTermNil; easy.
      * simpl in |- *; destruct (eq_nat_dec v1 n) as [e | ].
        --  elim n0; auto.
        -- reflexivity.
  - intros f t0 H1;  rewrite H1; reflexivity.
  - reflexivity.
  - intros  n t0 H1 t1 H2; rewrite H1, H2; easy.
Qed.

Lemma subSubTerms (n : nat) (ts : Terms n) (v1 v2 : nat) (s1 s2 : Term):
  v1 <> v2 ->
  ~ In v1 (freeVarTerm L s2) ->
  substituteTerms L n (substituteTerms L n ts v1 s1) v2 s2 =
    substituteTerms L n (substituteTerms L n ts v2 s2) v1
      (substituteTerm L s1 v2 s2).
Proof.
  intros H H0; induction ts as [| n t ts Hrects].
  - reflexivity.
  - simpl in |- *; rewrite Hrects, subSubTerm.
    + reflexivity.
    + assumption.
    + assumption.
Qed.

Lemma subSubFormula (f : Formula) (v1 v2 : nat) (s1 s2 : Term):
 v1 <> v2 ->
 ~ In v1 (freeVarTerm L s2) ->
 forall T : System,
 SysPrf T
   (iffH (substituteFormula L (substituteFormula L f v1 s1) v2 s2)
      (substituteFormula L (substituteFormula L f v2 s2) v1
         (substituteTerm L s1 v2 s2))).
Proof.
  intros H H0 T; apply (sysExtend L) with (Empty_set Formula).
  - intros x H1; destruct H1.
  - elim f using Formula_depth_ind2; intros.
    + repeat rewrite (subFormulaEqual L).
      rewrite subSubTerm; auto.
      rewrite (subSubTerm t0); auto.
      apply (iffRefl L).
    + repeat rewrite (subFormulaRelation L).
      rewrite subSubTerms; auto.
      apply (iffRefl L).
    + repeat rewrite (subFormulaImp L).
      apply (reduceImp L); auto.
    + repeat rewrite (subFormulaNot L).
      apply (reduceNot L); auto.
    + set (v' :=
             newVar
               (v1
                  :: v2
                  :: freeVarFormula L (forallH v a) ++
                  freeVarTerm L s1 ++ freeVarTerm L s2)) in *.
      assert (H2: v' <> v1).
      { intro H2;
        elim
          (newVar1
             (v1
                :: v2
                :: freeVarFormula L (forallH v a) ++
                freeVarTerm L s1 ++ freeVarTerm L s2)).
        fold v' ; simpl; auto.
      }
      assert (H3: v' <> v2).
      { intro H3;
        elim
          (newVar1
             (v1
                :: v2
                :: freeVarFormula L (forallH v a) ++
                freeVarTerm L s1 ++ freeVarTerm L s2)).
        fold v'; simpl; auto.
      }
      assert (H4: ~ In v' (freeVarFormula L (forallH v a))).
      { intro H4;
        elim
          (newVar1
             (v1
                :: v2
                :: freeVarFormula L (forallH v a) ++
                freeVarTerm L s1 ++ freeVarTerm L s2)).
        fold v' ;simpl; auto with datatypes.
      }
      assert (H5: ~ In v' (freeVarTerm L s1)).
      { intro H5;
        elim
          (newVar1
             (v1
                :: v2
                :: freeVarFormula L (forallH v a) ++
                freeVarTerm L s1 ++ freeVarTerm L s2)).
        fold v' ;  simpl; repeat right; auto with datatypes.
      }
      assert (H6: ~ In v' (freeVarTerm L s2)).
      { intro H6;
          elim
            (newVar1
               (v1
                  :: v2
                  :: freeVarFormula L (forallH v a) ++
                  freeVarTerm L s1 ++ freeVarTerm L s2)).
       fold v' ; simpl;  repeat right; auto with datatypes.
     }
     apply impE with
       (iffH
          (substituteFormula L
             (substituteFormula L
                (forallH v' (substituteFormula L a v (var v'))) v1 s1) v2
             s2)
          (substituteFormula L
             (substituteFormula L
                (forallH v' (substituteFormula L a v (var v'))) v2 s2) v1
             (substituteTerm L s1 v2 s2))).
     apply (iffE2 L).
      * assert
          (H7: folProof.SysPrf L (Empty_set Formula)
                 (iffH (forallH v a)
                    (forallH v' (substituteFormula L a v (var v')))))
          by (apply rebindForall; auto).
       repeat first
       [ apply (reduceIff L)
       | apply (reduceSub L)
       | apply (notInFreeVarSys L) ]; auto.
       * assert (H7:
                  forall (f : Formula) (x v : nat) (s : Term),
                    x <> v ->
                    ~ In x (freeVarTerm L s) ->
                    substituteFormula L (forallH x f) v s =
                      forallH x (substituteFormula L f v s)).
         { intros f0 x v0 s H7; rewrite (subFormulaForall L).
           destruct (eq_nat_dec x v0) as [e | n0].
           - elim H7; auto.
           - destruct (In_dec eq_nat_dec x (freeVarTerm L s)) as [i | n1].
         + intro H8; elim H8; auto.
         + reflexivity.
     }
     repeat rewrite H7; try easy.
     --  apply (reduceForall L).
         apply (notInFreeVarSys L).
         apply H1.
         apply eqDepth with a.
         symmetry  in |- *.
         apply subFormulaDepth.
         apply depthForall.
     --  intro H8; induction (freeVarSubTerm3 _ _ _ _ _ H8).
         elim H5; eapply in_remove.
         apply H9.
         now apply H6.
Qed.

End More_Logic_Rules.