(** * Triangular Numbers over Binary Natural Numbers *)

From Coq Require Import
  Classes.Morphisms Lia Lists.List NArith.NArith.
From DEZ.Justifies Require Export
  LogicalTheorems NTheorems OptionTheorems ProductTheorems.
From DEZ.Provides Require Import
  DatatypeTactics RewritingTactics.

Import ListNotations N.

#[local] Open Scope N_scope.

(** A generating function.
    Sequence A000217. *)

Equations tri (n : N) : N :=
  tri n := shiftr (n * succ n) 1.

Lemma tri_eqn (n : N) : tri n =
  n * (1 + n) / 2.
Proof. simp tri. arithmetize. auto. Qed.

(** An inverse of the generating function, with a remainder. *)

Equations untri_rem (n : N) : N * N :=
  untri_rem n := let (s, t) := sqrtrem (succ (shiftl n 3)) in
    let (q, r) := div_eucl (pred s) 2 in
    (q, shiftr (t + r * pred (shiftl s 1)) 3).

Lemma untri_rem_eqn (n : N) : untri_rem n =
  let (s, t) := sqrtrem (1 + 8 * n) in
  let (q, r) := div_eucl (s - 1) 2 in
  (q, (t + r * (2 * s - 1)) / 8).
Proof.
  simp untri_rem.
  arithmetize. destruct_sqrtrem s t est es e0st l1st.
  arithmetize. destruct_div_eucl q r eqr eq e0qr l1qr.
  arithmetize. auto.
Qed.

(** A weak inverse of the generating function, rounding down.
    Sequence A003056. *)

Equations untri (n : N) : N :=
  untri n := shiftr (pred (sqrt (succ (shiftl n 3)))) 1.

Lemma untri_eqn (n : N) : untri n =
  (sqrt (1 + 8 * n) - 1) / 2.
Proof. simp untri. arithmetize. auto. Qed.

(** A weak inverse of the generating function, rounding up. *)

Equations untri_up (n : N) : N :=
  untri_up n := match n with
    | N0 => 0
    | Npos p => succ (untri (Pos.pred_N p))
    end.

Lemma untri_up_eqn (n : N) : untri_up n =
  if n =? 0 then 0 else 1 + (sqrt (1 + 8 * (n - 1)) - 1) / 2.
Proof.
  destruct n as [| p].
  - auto.
  - simp untri_up. rewrite pos_pred_spec.
    arithmetize. rewrite untri_eqn. auto.
Qed.

(** A partial inverse of the generating function. *)

Equations untri_error (n : N) : option N :=
  untri_error n := let (s, t) := sqrtrem (succ (shiftl n 3)) in
    if t =? 0 then Some (shiftr (pred s) 1) else None.

Lemma untri_error_eqn (n : N) : untri_error n =
  let (s, t) := sqrtrem (1 + 8 * n) in
  if t =? 0 then Some ((s - 1) / 2) else None.
Proof.
  simp untri_error.
  arithmetize. destruct_sqrtrem s t est es e0st l1st.
  arithmetize. auto.
Qed.

(** TODO These should emerge from the more general inversion stuff. *)

From Coq Require Import Program.Wf.

Program Fixpoint untri_rem' (a n : N) {measure (to_nat n)} : N * N :=
  match untri_error n with
  | Some p => (p, a)
  | None => untri_rem' (1 + a) (n - 1)
  end.
Next Obligation.
  intros a n f x e.
  destruct n as [| p].
  - subst x. inversion e.
  - lia.
Qed.

Program Fixpoint untri_down' (n : N) {measure (to_nat n)} : N :=
  match untri_error n with
  | Some p => p
  | None => untri_down' (n - 1)
  end.
Next Obligation.
  intros n f x e.
  destruct n as [| p].
  - subst x. inversion e.
  - lia.
Qed.

(** This is obvious. *)

Lemma tri_succ (n : N) : tri (1 + n) = (1 + n) + tri n.
Proof.
  do 2 rewrite tri_eqn. destruct (Even_mul_consecutive (1 + n)) as [p ep].
  rewrite ep. rewrite div_Even.
  destruct (Even_mul_consecutive n) as [q eq].
  rewrite eq. rewrite div_Even. lia.
Qed.

(** This is strange. *)

Lemma tri_what (n p : N) : untri (p + tri (n + p)) = n + p.
Proof.
  rewrite untri_eqn, tri_eqn.
  destruct (Even_mul_consecutive (n + p)) as [q eq].
  rewrite eq. rewrite div_Even.
  remember (1 + 8 * (p + q)) as r eqn : er.
  destruct (Even_or_Odd (sqrt r - 1)) as [[s es] | [s es]]; arithmetize.
  - rewrite es. rewrite div_Even.
    destruct (sqrt_spec' r) as [l0 l1]; arithmetize. nia.
  - rewrite es. rewrite div_Odd.
    destruct (sqrt_spec' r) as [l0 l1]; arithmetize. nia.
Qed.

(** This is also strange. *)

Lemma tri_why (a b : N) (l : b <= a) : untri (b + tri a) = a.
Proof.
  assert (x : exists c : N, a = c + b).
  { exists (a - b). lia. }
  destruct x as [c e]. rewrite e. apply tri_what.
Qed.

(** The function [tri] is injective. *)

Lemma tri_inj (n p : N) (e : tri n = tri p) : n = p.
Proof.
  do 2 rewrite tri_eqn in e.
  destruct (Even_mul_consecutive n) as [q eq],
  (Even_mul_consecutive p) as [r er]; arithmetize.
  rewrite eq, er in e. do 2 rewrite div_Even in e. nia.
Qed.

(** The function [tri] is not surjective. *)

Lemma tri_nsurj : exists n : N, forall p : N, n <> tri p.
Proof.
  exists 2. intros p. rewrite tri_eqn.
  destruct p as [| q _] using peano_ind; arithmetize.
  - lia.
  - destruct (Even_mul_consecutive (1 + q)) as [r er]; arithmetize.
    rewrite er. rewrite div_Even. nia.
Qed.

(** The function [tri] is monotonic. *)

Lemma tri_le_mono (n p : N) (l : n <= p) : tri n <= tri p.
Proof.
  do 2 rewrite tri_eqn.
  apply div_le_mono; [lia |].
  apply mul_le_mono; [lia |].
  apply add_le_mono; [lia |]. lia.
Qed.

(** The function [tri] is strictly monotonic. *)

Lemma tri_lt_mono (n p : N) (l : n < p) : tri n < tri p.
Proof.
  assert (l' : n <= p) by lia.
  pose proof tri_le_mono n p l' as l''.
  destruct (eqb_spec (tri n) (tri p)) as [e | f].
  - apply tri_inj in e.
    subst p.
    lia.
  - lia.
Qed.

Local Lemma tri_le_expand_le (n p : N) (l : n <= p) :
  dist n p <= dist (tri n) (tri p).
Proof.
  pose proof tri_le_mono n p l as l'.
  do 2 rewrite dist_eqn.
  destruct (leb_spec n p) as [_ | ?l]; [| lia].
  destruct (leb_spec (tri n) (tri p)) as [_ | ?l]; [| lia].
  revert l'.
  do 2 rewrite tri_eqn.
  destruct (Even_mul_consecutive n) as [q eq],
  (Even_mul_consecutive p) as [r er].
  rewrite eq, er. do 2 rewrite div_Even.
  intros l'.
  nia.
Qed.

(** The function [tri] is expansive. *)

Lemma tri_le_expand (n p : N) : dist n p <= dist (tri n) (tri p).
Proof.
  destruct (leb_spec n p) as [l | l].
  - apply tri_le_expand_le.
    lia.
  - rewrite (dist_comm n p), (dist_comm (tri n) (tri p)).
    apply tri_le_expand_le.
    lia.
Qed.

(** The function [tri] is expansive around zero. *)

Lemma tri_le_expand_0 (n : N) : n <= tri n.
Proof.
  pose proof tri_le_expand n 0 as l.
  cbv [dist] in l.
  change (tri 0) with 0 in l.
  do 2 rewrite max_0_r in l. do 2 rewrite min_0_r in l.
  lia.
Qed.

(** The function [untri] is monotonic. *)

Lemma untri_le_mono (n p : N) (l : n <= p) : untri n <= untri p.
Proof.
  do 2 rewrite untri_eqn.
  apply div_le_mono; [lia |].
  apply sub_le_mono_r.
  apply sqrt_le_mono.
  apply add_le_mono; [lia |].
  apply mul_le_mono; [lia |]. lia.
Qed.

(** The function [untri] is contractive. *)

Lemma untri_le_contract (n p : N) : dist (untri n) (untri p) <= dist n p.
Proof.
  do 2 rewrite untri_eqn.
  remember (1 + 8 * n) as q eqn : eq.
  remember (1 + 8 * p) as r eqn : er. Admitted.

(** The function [untri] is contractive around zero. *)

Lemma untri_le_contract_0 (n : N) : untri n <= n.
Proof.
  rewrite untri_eqn.
  remember (1 + 8 * n) as p eqn : ep.
  destruct (Even_or_Odd (sqrt p - 1)) as [[q eq] | [q eq]]; arithmetize.
  - rewrite eq. rewrite div_Even.
    destruct (sqrt_spec' p) as [l0 l1]; arithmetize. clear l1; nia.
  - rewrite eq. rewrite div_Odd.
    destruct (sqrt_spec' p) as [l0 l1]; arithmetize. clear l1; nia.
Qed.

(** The function [untri] is an inverse of [tri]. *)

Theorem untri_tri (n : N) : untri (tri n) = n.
Proof.
  rewrite untri_eqn, tri_eqn. destruct (Even_mul_consecutive n) as [p ep].
  rewrite ep. rewrite div_Even.
  replace (8 * p) with (4 * (2 * p)) by lia.
  rewrite <- ep. clear ep.
  replace (1 + 4 * (n * (1 + n))) with ((1 + 2 * n) * (1 + 2 * n)) by lia.
  rewrite sqrt_square.
  replace (1 + 2 * n - 1) with (2 * n) by lia.
  rewrite div_Even. auto.
Qed.

(** The function [untri_up] is an inverse of [tri]. *)

Theorem untri_up_tri (n : N) : untri_up (tri n) = n.
Proof.
  rewrite untri_up_eqn.
  destruct (eqb_spec (tri n) 0) as [e | f].
  - apply tri_inj. auto.
  - change 0 with (tri 0) in f. apply f_nequal in f.
    rewrite tri_eqn. destruct (Even_mul_consecutive n) as [p ep].
    rewrite ep. rewrite div_Even.
    remember (1 + 8 * (p - 1)) as q eqn : eq.
    destruct (Even_or_Odd (sqrt q - 1)) as [[r er] | [r er]]; arithmetize.
    + rewrite er. rewrite div_Even.
      destruct (sqrt_spec' q) as [l0 l1]; arithmetize. nia.
    + rewrite er. rewrite div_Odd.
      destruct (sqrt_spec' q) as [l0 l1]; arithmetize. nia.
Qed.

(** The function [tri] provides a lower bound for inverses of [untri]. *)

Lemma tri_untri (n : N) : tri (untri n) <= n.
Proof.
  rewrite tri_eqn, untri_eqn.
  remember (1 + 8 * n) as p eqn : ep.
  destruct (Even_or_Odd (sqrt p - 1)) as [[q eq] | [q eq]]; arithmetize.
  - rewrite eq. rewrite div_Even.
    destruct (Even_mul_consecutive q) as [r er].
    rewrite er. rewrite div_Even.
    destruct (sqrt_spec' p) as [l0 l1]; arithmetize. clear l1; nia.
  - rewrite eq. rewrite div_Odd.
    destruct (Even_mul_consecutive q) as [r er].
    rewrite er. rewrite div_Even.
    destruct (sqrt_spec' p) as [l0 l1]; arithmetize. clear l1; nia.
Qed.

(** The function [tri] provides an upper bound for inverses of [untri]. *)

Lemma tri_untri_up (n : N) : n <= tri (untri_up n).
Proof.
  rewrite tri_eqn, untri_up_eqn.
  destruct (eqb_spec n 0) as [e | f]; arithmetize.
  - lia.
  - remember (1 + 8 * (n - 1)) as p eqn : ep.
    destruct (Even_or_Odd (sqrt p - 1)) as [[q eq] | [q eq]]; arithmetize.
    + rewrite eq. rewrite div_Even.
      destruct (Even_mul_consecutive (1 + q)) as [r er]; arithmetize.
      rewrite er. rewrite div_Even.
      destruct (sqrt_spec' p) as [l0 l1]; arithmetize. clear l0; nia.
    + rewrite eq. rewrite div_Odd.
      destruct (Even_mul_consecutive (1 + q)) as [r er]; arithmetize.
      rewrite er. rewrite div_Even.
      destruct (sqrt_spec' p) as [l0 l1]; arithmetize. clear l0; nia.
Qed.

(** The function [tri] provides bounds
    for inverses of [untri] and [untri_up]. *)

Theorem tri_untri_untri_up (n : N) : tri (untri n) <= n <= tri (untri_up n).
Proof. auto using tri_untri, tri_untri_up. Qed.

(** The function [untri_rem] can be defined in terms of [tri] and [untri]. *)

Lemma untri_rem_tri_untri (n : N) : untri_rem n = (untri n, n - tri (untri n)).
Proof.
  rewrite untri_rem_eqn, tri_eqn, untri_eqn.
  repeat rewrite <- sqrtrem_sqrt. cbv [fst snd].
  destruct_sqrtrem s t est es e0st l1st.
  clear est es l1st.
  repeat rewrite <- (div_eucl_div (s - 1) 2). cbv [fst snd].
  destruct_div_eucl q r eqr eq e0qr l1qr.
  clear eqr eq. f_equal.
  destruct (Even_mul_consecutive q) as [u eu].
  rewrite eu. rewrite div_Even.
  assert (or' : r = 0 \/ r = 1) by lia. clear l1qr.
  (** This case analysis is technically unnecessary,
      but speeds up [nia] considerably. *)
  destruct or' as [er | er]; subst r; arithmetize.
  - change 8 with (2 * (2 * 2)). repeat rewrite <- (div_div _ 2) by lia.
    rename t into t0.
    destruct (Even_or_Odd t0) as [[t1 et1] | [t1 et1]]; arithmetize.
    + rewrite et1. rewrite div_Even.
      destruct (Even_or_Odd t1) as [[t2 et2] | [t2 et2]]; arithmetize.
      * rewrite et2. rewrite div_Even.
        destruct (Even_or_Odd t2) as [[t3 et3] | [t3 et3]]; arithmetize.
        -- rewrite et3. rewrite div_Even. subst t0 t1 t2. nia.
        -- rewrite et3. rewrite div_Odd. subst t0 t1 t2. nia.
      * rewrite et2. rewrite div_Odd.
        destruct (Even_or_Odd t2) as [[t3 et3] | [t3 et3]]; arithmetize.
        -- rewrite et3. rewrite div_Even. subst t0 t1 t2. nia.
        -- rewrite et3. rewrite div_Odd. subst t0 t1 t2. nia.
    + rewrite et1. rewrite div_Odd.
      destruct (Even_or_Odd t1) as [[t2 et2] | [t2 et2]]; arithmetize.
      * rewrite et2. rewrite div_Even.
        destruct (Even_or_Odd t2) as [[t3 et3] | [t3 et3]]; arithmetize.
        -- rewrite et3. rewrite div_Even. subst t0 t1 t2. nia.
        -- rewrite et3. rewrite div_Odd. subst t0 t1 t2. nia.
      * rewrite et2. rewrite div_Odd.
        destruct (Even_or_Odd t2) as [[t3 et3] | [t3 et3]]; arithmetize.
        -- rewrite et3. rewrite div_Even. subst t0 t1 t2. nia.
        -- rewrite et3. rewrite div_Odd. subst t0 t1 t2. nia.
  - change 8 with (2 * (2 * 2)). repeat rewrite <- (div_div _ 2) by lia.
    rewrite add_sub_assoc by lia.
    remember (t + 2 * s - 1) as t0 eqn : et0.
    destruct (Even_or_Odd t0) as [[t1 et1] | [t1 et1]]; arithmetize.
    + rewrite et1. rewrite div_Even.
      destruct (Even_or_Odd t1) as [[t2 et2] | [t2 et2]]; arithmetize.
      * rewrite et2. rewrite div_Even.
        destruct (Even_or_Odd t2) as [[t3 et3] | [t3 et3]]; arithmetize.
        -- rewrite et3. rewrite div_Even. subst t0 t1 t2. nia.
        -- rewrite et3. rewrite div_Odd. subst t0 t1 t2. nia.
      * rewrite et2. rewrite div_Odd.
        destruct (Even_or_Odd t2) as [[t3 et3] | [t3 et3]]; arithmetize.
        -- rewrite et3. rewrite div_Even. subst t0 t1 t2. nia.
        -- rewrite et3. rewrite div_Odd. subst t0 t1 t2. nia.
    + rewrite et1. rewrite div_Odd.
      destruct (Even_or_Odd t1) as [[t2 et2] | [t2 et2]]; arithmetize.
      * rewrite et2. rewrite div_Even.
        destruct (Even_or_Odd t2) as [[t3 et3] | [t3 et3]]; arithmetize.
        -- rewrite et3. rewrite div_Even. subst t0 t1 t2. nia.
        -- rewrite et3. rewrite div_Odd. subst t0 t1 t2. nia.
      * rewrite et2. rewrite div_Odd.
        destruct (Even_or_Odd t2) as [[t3 et3] | [t3 et3]]; arithmetize.
        -- rewrite et3. rewrite div_Even. subst t0 t1 t2. nia.
        -- rewrite et3. rewrite div_Odd. subst t0 t1 t2. nia.
Qed.

(** The function [untri_rem] truly produces a remainder. *)

Lemma tri_untri_untri_rem (n : N) : n - tri (untri n) <= untri n.
Proof.
  rewrite tri_eqn, untri_eqn.
  remember (1 + 8 * n) as p eqn : ep.
  destruct (Even_or_Odd (sqrt p - 1)) as [[q eq] | [q eq]]; arithmetize.
  - rewrite eq. rewrite div_Even.
    destruct (Even_mul_consecutive q) as [r er].
    rewrite er. rewrite div_Even.
    destruct (sqrt_spec' p) as [l0 l1]; arithmetize. clear l0; nia.
  - rewrite eq. rewrite div_Odd.
    destruct (Even_mul_consecutive q) as [r er].
    rewrite er. rewrite div_Even.
    destruct (sqrt_spec' p) as [l0 l1]; arithmetize. clear l0; nia.
Qed.

(** The function [untri_rem] is an inverse of [tri]. *)

Theorem untri_rem_tri (n : N) : untri_rem (tri n) = (n, 0).
Proof. rewrite untri_rem_tri_untri. rewrite untri_tri. f_equal. lia. Qed.

(** The function [tri] is an inverse of [untri_rem]. *)

Theorem tri_untri_rem (n : N) : prod_uncurry (flip add o tri) (untri_rem n) = n.
Proof.
  rewrite untri_rem_tri_untri.
  cbv [prod_uncurry compose flip fst snd].
  pose proof tri_untri n as l.
  lia.
Qed.

(** The function [untri_error] can be defined in terms of [untri_rem]. *)

Lemma untri_error_untri_rem (n : N) :
  untri_error n =
  let (u, t1) := untri_rem n in
  if t1 =? 0 then Some u else None.
Proof.
  pose proof tri_untri n as l. revert l.
  rewrite untri_error_eqn. rewrite untri_rem_tri_untri.
  rewrite untri_eqn. rewrite tri_eqn.
  rewrite <- sqrtrem_sqrt. cbv [fst snd].
  destruct_sqrtrem s t est es e0st l1st.
  clear est es.
  rewrite <- (div_eucl_div (s - 1) 2). cbv [fst snd].
  destruct_div_eucl q r eqr eq e0qr l1qr.
  clear eqr eq.
  destruct (Even_mul_consecutive q) as [u eu].
  rewrite eu. rewrite div_Even. intros l.
  assert (or' : r = 0 \/ r = 1) by lia. clear l1qr.
  destruct (eqb_spec t 0) as [e0 | f0],
  (eqb_spec (n - u) 0) as [e1 | f1]; arithmetize.
  + auto.
  + exfalso. clear l; nia.
  + exfalso. clear l; nia.
  + auto.
Qed.

(** The function [untri_error] is a lifted inverse of [tri]. *)

Theorem untri_error_tri (n : N) : untri_error (tri n) = Some n.
Proof. rewrite untri_error_untri_rem. rewrite untri_rem_tri. auto. Qed.

(** A lifting of the function [tri] is an inverse of [untri_error]. *)

Theorem tri_untri_error (n p : N)
  (e : option_map tri (untri_error n) = Some p) : n = p.
Proof.
  rewrite untri_error_untri_rem in e.
  rewrite untri_rem_tri_untri in e.
  destruct (eqb_spec (n - tri (untri n)) 0) as [e0 | f0].
  - cbv [option_map] in e.
    injection e; intros e1. clear e.
    rewrite <- e1. clear e1.
    pose proof sub_add _ _ (tri_untri n) as e2. lia.
  - cbv [option_map] in e.
    inversion e.
Qed.

(** An inverse of the generating function,
    with a remainder as an exact quotient. *)

Program Definition untri_quotrem (n : N) :
  {x : N * N $ Squash (let (p, q) := x in tri p + q < tri (1 + p))} :=
  Sexists _ (untri_rem n) _.
Next Obligation.
  intros n. cbv beta. apply squash. rewrite untri_rem_tri_untri.
  rewrite tri_succ.
  pose proof tri_untri_untri_rem n as e.
  lia.
Qed.

Global Instance tri_wd : Proper (Logic.eq ==> Logic.eq) tri.
Proof. intros n p e. auto using f_equal. Qed.

Global Instance untri_wd : Proper (Logic.eq ==> Logic.eq) untri.
Proof. intros n p e. auto using f_equal. Qed.

Global Instance le_tri_wd : Proper (N.le ==> N.le) tri.
Proof. intros n p l. apply tri_le_mono. lia. Qed.

Global Instance le_untri_wd : Proper (N.le ==> N.le) untri.
Proof. intros n p l. apply untri_le_mono. lia. Qed.


(*|
################################################
Understanding the ``intros`` keyword work in Coq
################################################

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

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

Theorem law_of_contradiction : forall (P Q : Prop), P /\ ~P -> Q.
Proof.
  intros P Q P_and_not_P.
  destruct P_and_not_P as [P_holds not_P].
Abort. (* .none *)

(*|
I'm trying to reaaaally understand the ``intros`` keyword. Let's say
that we want to prove ``P /\ ~P -> Q``. Ok, somehow ``intros P Q``
introduce ``P`` and ``Q``. But what does it mean? Does it recognize
the ``P`` and ``Q`` from the thing to be proven? What about
``P_and_not_P``? What is it? Why for ``P`` and ``Q`` it uses the same
name, but for ``P_and_not_P`` is defining a name?

UPDATE:
=======

It looks like it's matching term by term:
|*)

Theorem modus_tollens : forall (P Q : Prop), (P -> Q) -> ~Q -> ~P.
Proof.
  intro P. intro Q. intro P_implies_Q. intro not_q. intro not_p.

(*| gives |*)

  Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
Answer
******

What ``intro A`` (equivalent to ``intros A``) does: if you have a goal
of the form ``forall (P : _), ...``, it renames ``P`` to ``A``,
removes the ``forall`` from the beginning of the goal and puts an
assumption ``A`` into the goal.
|*)

Theorem law_of_contradiction : forall (P Q : Prop), P /\ ~P -> Q. (* .none *)
Proof. (* .none *)
  (* Starting goal *)
  Show. (* .unfold .messages *)
  (* Goal after [intros A] *)
  intros A. (* .none *) Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
If you do ``intros P Q``, by picking the names already in the goal, no
renaming is necessary so there is no change in names.

The other cases of ``intros`` you mention are special cases of that
one behavior.

**Implications** in Coq are quantifications where the assumption is
not named: ``P /\ ~ P -> Q`` is equivalent to ``forall (H : P /\ ~P),
Q``, noting that ``H`` is not used in the body ``Q``. Hence, when you
do ``intros P_and_not_P``, you are renaming ``H``, which is not used
so you don't see a change in the goal. You can disable pretty printing
to see that.
|*)

Unset Printing Notations.
Theorem law_of_contradiction : forall (P Q : Prop), P /\ ~P -> Q. (* .none *)
Proof. (* .none *)
  (* Starting goal; a name that is not used becomes "_" *)
  Show. (* .unfold .messages *)
  (* After [intros P Q R] *)
  intros P Q R. (* .none *) Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
The **negation** of ``P``, denoted ``~P``, is defined as ``P ->
False`` in Coq (this is typical in intuitionistic logic, other logics
might differ). You can see that in action with the tactic ``unfold
not``
|*)

Set Printing Notations. (* .none *)
Theorem modus_tollens : forall (P Q : Prop), (P -> Q) -> ~Q -> ~P. (* .none *)
Proof. (* .none *)
  (* Starting goal *)
  Show. (* .unfold .messages *)
  (* After [unfold not] *)
  unfold not. (* .none *) Show. (* .unfold .messages *)
  (* After [intros P Q R S T] *)
  intros P Q R S T. (* .none *) Show. (* .unfold .messages *)


(** matrix_analysis.v: stability analysis for leapfrog integration
  of a simple harmonic oscillator.
 Copyright (C) 2021-2022  Ariel Eileen Kellison.
*)
From Coq Require Import ZArith Reals Psatz.
From Coq Require Import Bool Arith.Arith.
Require Import real_lemmas real_model matrix_lemmas.

From Coquelicot Require Import Coquelicot.
Require Import Interval.Tactic.

Import Bool.

Set Bullet Behavior "Strict Subproofs".

Lemma prod_equal: forall {A B} (x y: A*B) x1 x2 y1 y2,
  x = (x1,x2) ->
  y = (y1,y2) ->
  x1=y1 -> x2 = y2 -> x=y.
Proof.
destruct x,y; simpl; intros; congruence.
Qed.

Ltac matrix_ext :=
  lazymatch goal with
  | |- @eq (matrix _ _) _ _ => idtac
  | _ => fail "matrix_ext must be applied to a goal of the form, @eq (matrix _ _) _ _"
 end;
repeat
(lazymatch goal with |- @eq ?t _ _ =>
  lazymatch t with
  | matrix _ _ => idtac
  | Tn _ _ => idtac
  | prod _ unit => idtac
  end
 end;
 eapply prod_equal; [reflexivity | reflexivity | | try apply (eq_refl tt)]).

(** An upper bound σb on the singular values of a square matrix A ∈ Mn(C)
      is given by an upper bound on the eigenvalues of A'A *)
Definition sv_bound (n: nat ) (A : @matrix C n n) (σb : R):=
  let ATA := Mmult (matrix_conj_transpose n n A) A (* the Gram matrix A'A *) in
  let λb := σb^2 in
  0 <= σb /\
  exists (V Λ : @matrix C n n),
         Mmult ATA V = Mmult V Λ
      /\ is_orthogonal_matrix n V
      /\ diag_pred n Λ
      /\ (forall (i : nat), (i < n)%nat ->
         (coeff_mat zero Λ i i) = RtoC (Re (coeff_mat zero Λ i i)) (* elements of Λ are real *)
         /\ 0 <= Re (coeff_mat zero Λ i i) <= λb) (* λb is positive and at least as large as all elements of Λ *)
.

Definition two_norm_bound (n: nat ) (A : @matrix C n n) (σ : R):=
  forall (u : @matrix C n 1),
  vec_two_norm n (Mmult A u) <=  σ * vec_two_norm n u
.

(** any vector x ∈ Cn can be written as a linear combination of columns of an
    orthogonal matrix V ∈ Cnxn *)
Lemma vectors_in_basis (n : nat) :
 forall (x : @matrix C n 1),
 forall (V : @matrix C n n), is_orthogonal_matrix n V ->
 exists (a: @matrix C n 1),  x = Mmult V a.
Proof.
intros.
unfold is_orthogonal_matrix in H; destruct H as (Ha & Hb).
exists (Mmult (matrix_conj_transpose n n V) x).
rewrite Mmult_assoc.
rewrite Hb.
rewrite Mmult_one_l; auto.
Qed.

(** the leapfrog transition matrix *)
Definition M (h: R) : @matrix C 2 2 :=
  let a := 0.5 * h^2 in
   [ [ (1-a, 0),  (-0.5 * h * (2 - a), 0) ],
     [ (h, 0),      (1-a, 0) ] ].

(** ideal solution vector *)
Definition pq_vector (h: R) (p q : R -> R) (t : R) : @matrix C 2 1 :=
   [ [ (p t, 0) ] ,
     [ (q t, 0) ] ].

(** arbitrary solution vector *)
Definition s_vector (ic: R * R) : @matrix C 2 1 :=
 [ [ (fst ic, 0) ] ,
   [ (snd ic, 0) ] ].

(** equivalence between matrix update and leapfrog step*)
Lemma transition_matrix_equiv:
  forall (ic : R * R) (h : R),
  Mmult (M h) (s_vector ic) = s_vector (leapfrog_stepR h ic).
Proof.
intros. destruct ic.
matrix_ext; cbv [sum_n sum_n_m Iter.iter_nat Iter.iter coeff_mat]; simpl;
unfold plus, mult; simpl; unfold Cplus, Cmult, zero; simpl;
unfold ω; f_equal; nra.
Qed.

Lemma transition_matrix_equiv_iternR:
  forall (ic : R * R) (h : R) (n : nat),
  Mmult (Mpow 2 n (M h)) (s_vector ic) = s_vector (iternR ic h n).
Proof.
induction n.
-
unfold Mpow.
rewrite M_ID_equiv_M1, Mmult_one_l.
reflexivity.
-
change (S n) with (1+n)%nat.
rewrite <- Mpow_pows_plus.
unfold Mpow at 1.
rewrite M_ID_equiv_M1, Mmult_one_l.
rewrite <- Mmult_assoc. rewrite IHn.
rewrite transition_matrix_equiv.
rewrite step_iternR. auto.
Qed.

(** The eigenvalues of the transition matrix *)
Definition lambda_1 (h : R) : C := (1 -0.5 * h^2 , -h * sqrt(2 - h) * 0.5 * sqrt(h + 2)).
Definition lambda_2 (h : R) : C := (1 -0.5 * h^2 ,  h * sqrt(2 - h) * 0.5 * sqrt(h + 2)).
Definition eigenvalue_vector (h : R) : @matrix C 2 1 :=
 [ [ lambda_1 h ],
   [ lambda_2 h ] ].

Definition eigenvalue_matrix (h : R) : @matrix C 2 2 :=
  [ [ lambda_1 h , C0 ] , [ C0 , lambda_2 h ] ].

(** The eigenvectors of the transition matrix *)
Definition eV_1 (h : R) : @matrix C 2 1 :=
 [ [ (0 , -0.5 * sqrt(4 - h^2)) ] ,
   [ C1 ] ].

Definition eV_2 (h : R) : @matrix C 2 1 :=
 [ [ (0 ,  0.5 * sqrt(4 - h^2))] ,
   [ C1 ] ].

Definition eigenvector_matrix (h : R) : @matrix C 2 2 :=
 [ [ (0 , -0.5 * sqrt(4 - h^2)), (0 ,  0.5 * sqrt(4 - h^2)) ],
   [ C1,                                 C1 ]].

(** We define the Gram matrix MTM for the transition matrix. The eigenvalues of the matrix MTM are the
    singular values of the transition matrix *)
Definition MTM (h : R) : @matrix C 2 2 :=
 [ [  (0.25 * h^4 + 1, 0), (0.125 * h^3*(2 - h^2),0) ],
   [ (0.125 * h^3*(2 - h^2),0),  (0.0625 * h^6 - 0.25*h^4 + 1, 0)] ].

(** The eigenvalues of MTM *)
Definition MTM_lambda_1 (h : R) : R :=
let a:= sqrt(h^6 + 64) in
let A:= (h^10 - h^7*a + 4*h^6 + 64*h^4 - 4*h^3*a - 32*h*a + 256) * (h^2 -2)^2 in
let b:= (h^3 - 8*h + a)^2 in
A / (2*(h^4  - 4*h^2 + 4) * (b + 16 * (h^2 - 2)^2))
.

Definition MTM_lambda_2 (h : R) : R :=
let a:= sqrt(h^6 + 64) in
let A:= (h^10 + h^7*a + 4*h^6 + 64*h^4 + 4*h^3*a + 32*h*a + 256) * (h^2 -2)^2 in
let b:= (-h^3 + 8*h + a)^2 in
A / (2*(h^4  - 4*h^2 + 4) * (b + 16 * (h^2 - 2)^2))
.

Definition MTM_eigenvalue_vector (h : R) : @matrix R 2 1 :=
 [ [ MTM_lambda_1 h ],
   [ MTM_lambda_2 h ] ].

Definition MTM_eigenvalue_matrix (h : R) : @matrix C 2 2 :=
  [ [ RtoC (MTM_lambda_1 h), C0 ],
    [ C0,   RtoC (MTM_lambda_2 h) ] ].

(** The eigenvectors of MTM, numbered to match their eigenvalues *)
Definition MTM_eV_1 (h: R) : @matrix C 2 1 := mk_matrix 2 1 ( fun i _ =>
  if (Nat.eqb i 0) then RtoC((h^3 - 8*h + sqrt(h^6 + 64))/((h^2 - 2)*sqrt(Rabs((h^3 - 8*h + sqrt(h^6 + 64))/(h^2 - 2))^2 + 16))) else
    RtoC(4/sqrt(Rabs((h^3 - 8*h + sqrt(h^6 + 64))/(h^2 - 2))^2 + 16)))
.
Definition MTM_eV_2 (h: R) : @matrix C 2 1 := mk_matrix 2 1 ( fun i _ =>
  if (Nat.eqb i 0) then RtoC((h^3 - 8*h - sqrt(h^6 + 64))/((h^2 - 2)*sqrt(Rabs((-h^3 + 8*h + sqrt(h^6 + 64))/(h^2 - 2))^2 + 16))) else
    RtoC(4/sqrt(Rabs((-h^3 + 8*h + sqrt(h^6 + 64))/(h^2 - 2))^2 + 16)))
.

(** we use MTM_eigenvector_matrix as the matrix V in e.g. M V = V L , where L is the diagonal matrix of eigenvalues
   and M is the transition matrix.*)
Definition MTM_eigenvector_matrix (h : R) : @matrix C 2 2 :=
  [ [ coeff_mat zero (MTM_eV_1 h) 0 0,  coeff_mat zero (MTM_eV_2 h) 0 0 ],
    [ coeff_mat zero (MTM_eV_1 h) 1 0, coeff_mat zero (MTM_eV_2 h) 1 0 ] ].

(* M * V = V * L *)
Lemma eigens_correct (h : R) :
  0 <= h <= 2 ->
  Mmult (M h) (eigenvector_matrix h) =
  Mmult (eigenvector_matrix h) (eigenvalue_matrix h).
Proof.
intros.
assert (sqrt (2-h) * sqrt (h+2) = sqrt (4-h*h))
  by (rewrite <- sqrt_mult by lra; f_equal; lra).
pose proof (sqrt_def (4-h*h) ltac:(nra)).
matrix_ext.
all: change (Init.Nat.pred 2) with (S 0);
repeat rewrite sum_Sn;
repeat rewrite sum_O;
unfold M, eigenvector_matrix, eigenvalue_matrix,
  eV_1, eV_2, lambda_1, lambda_2, matrix_lemmas.C1,
 coeff_mat; simpl.
all:
unfold mult, plus; simpl;
rewrite ?mult_aux1, ?mult_aux2, ?mult_aux3;
rewrite ?Cmult_0_r, ?Cplus_0_r;
unfold Cplus; simpl;
rewrite ?Rmult_0_l, ?Rmult_0_r, ?Rmult_1_r, ?Rplus_0_l, ?Rplus_0_r, ?Rminus_0_l;
rewrite <- H0 in *;
f_equal; try nra.
Qed.

Lemma MTM_aux  (h : R) :
  Mmult (matrix_conj_transpose _ _ (M h)) (M h) = MTM h.
Proof.
unfold MTM.
matrix_ext;
change (Init.Nat.pred 2) with (S 0);
rewrite ?sum_Sn, ?sum_O;
unfold M, matrix_conj_transpose, Cconj;
repeat rewrite coeff_mat_bij by lia;
unfold coeff_mat; simpl;
unfold plus, mult; simpl;
cbv [Cmult Cplus]; simpl;
f_equal; nra.
Qed.

Lemma div_eq_0 :
forall a b , b <> 0 -> a = 0 -> a / b = 0.
Proof.
intros.
subst.
field.
auto.
Qed.

Lemma sqr_def : forall x, x^2 = x*x.
Proof. intros; nra. Qed.

Lemma pow2'_sqrt : forall x n,
  0 <= x ->
  sqrt x ^ (S (S n)) = x * sqrt x ^ n.
Proof.
intros.
simpl.
rewrite <- Rmult_assoc.
f_equal.
apply sqrt_def; auto.
Qed.

(* MTM * V = V * L *)
Theorem MTM_eigens_correct (h : R) :
  0 < h  < 1.41 ->
  Mmult (MTM h) (MTM_eigenvector_matrix h) =
  Mmult (MTM_eigenvector_matrix h) (MTM_eigenvalue_matrix h).
Proof.
intros.
matrix_ext;
change (Init.Nat.pred 2) with (S 0);
rewrite ?sum_Sn, ?sum_O;
unfold MTM, MTM_eigenvector_matrix, MTM_eigenvalue_matrix;
repeat rewrite coeff_mat_bij;
unfold coeff_mat; simpl;
change mult with Cmult;
change plus with Cplus;
unfold RtoC;
cbv [Cplus Cmult]; simpl;
rewrite ?Rmult_0_l, ?Rmult_0_r;
unfold C0;
rewrite ?Rminus_0_r, ?Rplus_0_r, ?Rmult_1_r.
-
f_equal.
unfold MTM_lambda_1, MTM_eV_1.
rewrite <- Rabs_mult.
repeat match goal with |-context [Rabs( (?a / ?b) * (?a / ?b)) ] =>
replace ( (a / b) * (a / b)) with ( (a/b)^2) by nra
end.
repeat rewrite Rabs_sqr_le.
repeat rewrite pow2_abs.
apply Rminus_diag_uniq.
field_simplify.
repeat rewrite pow2_sqrt; try nra.
field_simplify.
replace (sqrt (h * (h * (h * (h * (h * h)))) + 64))
with (sqrt (h ^ 6 + 64)).
repeat rewrite Rmult_assoc.
repeat rewrite sqrt_def.
field_simplify.
apply div_eq_0.
set (x := sqrt _).
set (y := sqrt _).
interval with ( i_bisect h, i_taylor h, i_degree 7).
set (x := sqrt _). nra.
set (x := sqrt _).
set (y := sqrt _).
interval with ( i_bisect h, i_taylor h, i_degree 3).
all: try repeat split; try interval with ( i_bisect h, i_taylor h, i_degree 3).
f_equal; nra.
-
f_equal.
unfold MTM_lambda_1, MTM_lambda_2.
rewrite <- Rabs_mult.
repeat match goal with |-context [Rabs( (?a / ?b) * (?a / ?b)) ] =>
replace ( (a / b) * (a / b)) with ( (a/b)^2) by nra
end.
repeat rewrite Rabs_sqr_le.
repeat rewrite pow2_abs.
apply Rminus_diag_uniq.
field_simplify.
repeat rewrite pow2_sqrt; try nra.
field_simplify.
replace (sqrt (h * (h * (h * (h * (h * h)))) + 64))
with (sqrt (h ^ 6 + 64)).
repeat rewrite Rmult_assoc.
repeat rewrite sqrt_def.
field_simplify.
apply div_eq_0.
set (x := sqrt _).
set (y := sqrt _).
interval with ( i_bisect h, i_taylor h, i_degree 3).
set (x := sqrt _). nra.
set (x := sqrt _).
set (y := sqrt _).
interval with ( i_bisect h, i_taylor h, i_degree 3).
all: try repeat split; try interval with ( i_bisect h, i_taylor h, i_degree 3).
f_equal; nra.
-
f_equal.
unfold MTM_lambda_1, MTM_lambda_2.
rewrite <- Rabs_mult.
repeat match goal with |-context [Rabs( (?a / ?b) * (?a / ?b)) ] =>
replace ( (a / b) * (a / b)) with ( (a/b)^2) by nra
end.
repeat rewrite Rabs_sqr_le.
repeat rewrite pow2_abs.
apply Rminus_diag_uniq.
field_simplify.
repeat rewrite pow2_sqrt; try nra.
field_simplify.
replace (sqrt (h * (h * (h * (h * (h * h)))) + 64))
with (sqrt (h ^ 6 + 64)).
repeat rewrite Rmult_assoc.
repeat rewrite sqrt_def.
field_simplify.
apply div_eq_0.
set (x := sqrt _).
set (y := sqrt _).
interval with ( i_bisect h, i_taylor h, i_degree 3).
set (x := sqrt _). nra.
set (x := sqrt _).
set (y := sqrt _).
interval with ( i_bisect h, i_taylor h, i_degree 3).
all: try repeat split; try interval with ( i_bisect h, i_taylor h, i_degree 3).
f_equal; nra.
-
f_equal.
unfold MTM_lambda_1, MTM_lambda_2.
rewrite <- Rabs_mult.
repeat match goal with |-context [Rabs( (?a / ?b) * (?a / ?b)) ] =>
replace ( (a / b) * (a / b)) with ( (a/b)^2) by nra
end.
repeat rewrite Rabs_sqr_le.
repeat rewrite pow2_abs.
apply Rminus_diag_uniq.
field_simplify.
repeat rewrite pow2_sqrt; try nra.
field_simplify.
replace (sqrt (h * (h * (h * (h * (h * h)))) + 64))
with (sqrt (h ^ 6 + 64)).
repeat rewrite Rmult_assoc.
repeat rewrite sqrt_def.
field_simplify.
apply div_eq_0.
set (x := sqrt _).
set (y := sqrt _).
interval with ( i_bisect h, i_taylor h, i_degree 3).
set (x := sqrt _). nra.
set (x := sqrt _).
set (y := sqrt _).
interval with ( i_bisect h, i_taylor h, i_degree 3).
all: try repeat split; try interval with ( i_bisect h, i_taylor h, i_degree 3).
f_equal; nra.
Qed.

Lemma Cmod_RtoC (a : R):
  0 <= a ->
Cmod (RtoC a) = a.
Proof.
unfold RtoC.
unfold Cmod, fst, snd.
rewrite pow_i by lia.
rewrite Rplus_0_r.
apply sqrt_pow2.
Qed.

Lemma sv_vector_implies (A V Λ : matrix 2 2):
   is_orthogonal_matrix 2 V ->
   diag_pred 2 Λ ->
   Mmult (Mmult (matrix_conj_transpose 2 2 A) A) V = Mmult V Λ ->
  forall (k :nat), (k < 2)%nat ->
  let x := mk_matrix 2 1
  (fun i0 _ : nat =>
     (coeff_mat zero V i0 k)) in
  (Mmult (matrix_conj_transpose 2 1 x) (Mmult (Mmult (matrix_conj_transpose 2 2 A) A) x)) =
  (Mmult (matrix_conj_transpose 2 1 x) (mat_coeff_mult (coeff_mat zero Λ k k) 2 1 x)).
Proof.
intros.
unfold Mmult at 1 3 in H1.
rewrite <- mk_matrix_ext in H1.
apply mk_matrix_ext; intros.
apply sum_n_ext_loc => m Hm.
assert (i = 0)%nat by lia; subst i.
assert (j = 0)%nat by lia; subst j.
subst x.
red in H0.
change (@zero C_AbelianGroup) with (@zero C_Ring) in *.
unfold Mmult at 1.
rewrite coeff_mat_bij by lia.
simpl.
f_equal.
etransitivity; [apply H1; lia | simpl ].
unfold mat_coeff_mult.
rewrite !coeff_mat_bij by lia.
rewrite !sum_Sn, !sum_O.
destruct m as [|[|]]; try lia;
destruct k as [|[|]]; try lia;
match goal with |- context [coeff_mat _ Λ ?x ?y] =>  rewrite (H0 x y) by lia end;
rewrite ?mult_zero_l, ?mult_zero_r, ?plus_zero_l, ?plus_zero_r;
apply Cmult_comm.
Qed.

Lemma orthgonal_matrix_no_zero_columns:
 forall (V: matrix 2 2),
  is_orthogonal_matrix 2 V ->
  forall i,
  (i < 2)%nat ->
 0 < vec_two_norm 2 [[coeff_mat zero V 0 i], [coeff_mat zero V 1 i]].
Proof.
intros V H2 i Hi.
assert (0 <> vec_two_norm 2 [ [ coeff_mat zero V 0 i ] , [ coeff_mat zero V 1 i ] ]).
2: assert (0 <= vec_two_norm 2 [[coeff_mat zero V 0 i], [coeff_mat zero V 1 i]])
      by apply sqrt_pos;
      lra.
intro.
assert (   [[coeff_mat zero V 0 i], [coeff_mat zero V 1 i]] = [ [C0], [C0] ]). {
 clear - H.
 set (a := coeff_mat _ _ _ _) in *. clearbody a.
 set (b := coeff_mat _ _ _ _) in *. clearbody b.
 symmetry in H.
 apply sqrt_eq_0 in H; [ | apply sqrt_pos].
 unfold Cmod in H; simpl in H.
 unfold coeff_mat in H; simpl in H.
 apply sqrt_eq_0 in H; [ | nra].
 destruct a as [ar ai], b as [br bi]. simpl in *. unfold C0.
 rewrite ?Rmult_1_r, ?Rplus_0_r in H.
 ring_simplify in H.
 replace (ar^4) with (ar^2 * ar^2) in H by nra.
 replace (br^4) with (br^2 * br^2) in H by nra.
 replace (ai^4) with (ai^2 * ai^2) in H by nra.
 replace (bi^4) with (bi^2 * bi^2) in H by nra.
 assert (ar^2=0 /\ ai^2=0 /\ br^2=0 /\ bi^2=0)
  by (repeat split; nra).
 clear H; destruct H0 as [? [? [? ?]]].
 repeat f_equal; nra.
}
clear H.
injection H0; clear H0; intros.
destruct H2.
assert (forall m1 m2 : @matrix C 2 2, m1=m2 ->
   coeff_mat zero m1 0 0 = coeff_mat zero m2 0 0 /\
   coeff_mat zero m1 0 1 = coeff_mat zero m2 0 1 /\
   coeff_mat zero m1 1 0 = coeff_mat zero m2 1 0 /\
   coeff_mat zero m1 1 1 = coeff_mat zero m2 1 1)
    by (intros; subst; auto).
apply H3 in H1; destruct H1 as [H1a [H1b [H1c H1d]]].
apply H3 in H2; destruct H2 as [H2a [H2b [H2c H2d]]].
clear H3.
set (u := @coeff_mat C_AbelianGroup 2 2 (@zero C_AbelianGroup)
        (@Mone C_Ring 2)) in *.
hnf in u. simpl in u. subst u.
simpl in *.
repeat match goal with H: _ = zero |- _ => clear H end.
repeat match goal with H: _ = one |- _ => injection H; clear H; intros end.
unfold C0 in *.
destruct i as [|[|]]; [ | | lia]; clear Hi;
rewrite H,H0 in *; clear H H0; simpl in *; lra.
Qed.

(* if σ^2 bounds the singular values of A ∈ M(C^2) then σ bounds the two-norm of A *)
Theorem sv_bound_implies_two_norm_bound   (A : @matrix C 2 2) (σ : R):
  sv_bound 2 A σ  ->  two_norm_bound 2 A σ.
Proof.
intros. intro.
red in H.
destruct H as [H0 [V [Λ [H1 [H2 [H3 H6]]]]]].
assert (exists a : matrix 2 1, u = Mmult V a)
  by (apply  (vectors_in_basis 2 u V ); auto).
destruct H as (a & Hu); subst.
unfold vec_two_norm.
repeat rewrite tranpose_rewrite.
do 2 rewrite <- Mmult_assoc.
replace (Mmult (matrix_conj_transpose 2 2 A) (Mmult A (Mmult V a))) with
(Mmult (Mmult (Mmult (matrix_conj_transpose 2 2 A) A) V) a)
by (repeat rewrite Mmult_assoc; auto).
rewrite H1.
replace (Mmult (matrix_conj_transpose 2 2 V) (Mmult (Mmult V Λ) a)) with
(Mmult (Mmult (matrix_conj_transpose 2 2 V) V) (Mmult Λ a))
by (repeat rewrite Mmult_assoc; auto).
replace (Mmult (Mmult (matrix_conj_transpose 2 1 a) (matrix_conj_transpose 2 2 V)) (Mmult V a))
with
(Mmult (matrix_conj_transpose 2 1 a) (Mmult (Mmult (matrix_conj_transpose 2 2 V) V) a))
by (repeat rewrite Mmult_assoc; auto).
destruct H2 as (H2 & _).
rewrite H2.
rewrite !Mmult_one_l.
replace (Mmult Λ a)
with
(mk_matrix 2 1 (fun i _ : nat =>
  mult (coeff_mat zero Λ i i) (coeff_mat zero a i 0))).
{
rewrite <- (sqrt_pow2 σ) by auto.
rewrite <- sqrt_mult by (try nra; apply Cmod_ge_0).
apply sqrt_le_1_alt.
rewrite <- (Cmod_RtoC (σ^2)) by nra.
rewrite <- Cmod_mult.
unfold Mmult.
rewrite !coeff_mat_bij; try lia.
change (Init.Nat.pred 2) with 1%nat.
rewrite !sum_Sn.
rewrite !coeff_mat_bij by lia.
rewrite !sum_O.
rewrite !coeff_mat_bij by lia.
change plus with Cplus.
change mult with Cmult.
unfold matrix_conj_transpose.
rewrite !coeff_mat_bij by lia.
rewrite Cmult_comm.
rewrite <- Cmult_assoc.
rewrite C_sqr_ccong.
rewrite Cmult_comm.
rewrite Cplus_comm.
rewrite Cmult_comm.
rewrite <- Cmult_assoc.
rewrite C_sqr_ccong.
rewrite !C_sqr_ccong2.

pose proof (H6 0%nat ltac:(lia)) as (HL1 & HL2 & HL3).
pose proof (H6 1%nat ltac:(lia)) as (HL4 & HL5 & HL6).
rewrite HL1.
rewrite HL4.

rewrite <- !RtoC_mult.
rewrite <- !RtoC_plus.
rewrite <- !RtoC_mult.
rewrite !Cmod_R.

rewrite Rmult_comm.
apply Rabs_pos_le.
apply Rle_plus; auto.
apply Rle_mult; auto.
apply sqr_plus_pos.
apply Rle_mult; auto.
apply sqr_plus_pos.

apply Rle_mult; auto;
  try apply square_pos.
apply Rle_plus; auto;
  apply sqr_plus_pos.

rewrite Rmult_plus_distr_l.
rewrite Rplus_comm.
apply Rplus_le_compat.
*
rewrite Rmult_comm.
apply Rmult_le_compat_r; auto.
apply sqr_plus_pos.
*
rewrite Rmult_comm.
apply Rmult_le_compat_r; auto.
apply sqr_plus_pos.
}
apply mk_matrix_ext; intros.
assert (Hj: (j = 0)%nat) by lia; subst.
change (Init.Nat.pred 2) with (S 0).
red in H3.
destruct i as [|[|]]; [ | | lia].
--
rewrite sum_Sn, sum_O.
specialize (H3 0%nat 1%nat ltac:(lia)).

change ((@coeff_mat (AbelianGroup.sort (Ring.AbelianGroup C_Ring)) 2 2
        (@zero (Ring.AbelianGroup C_Ring)) Λ 0 1))
with
(@coeff_mat C 2 2 (@zero C_AbelianGroup) Λ 0 1).
rewrite H3.
rewrite ?@mult_zero_l, ?@mult_zero_r, ?@plus_zero_l, ?@plus_zero_r.
auto.
--
rewrite sum_Sn, sum_O.
specialize (H3 1%nat 0%nat ltac:(lia)).
change (@zero C_AbelianGroup) with (@zero C_Ring) in *.
change (@coeff_mat _ 2 2  (@zero C_Ring) Λ 1 0)
with (@coeff_mat C 2 2 (@zero C_Ring) Λ 1 0).
simpl.
rewrite H3.
rewrite ?@mult_zero_l, ?@mult_zero_r, ?@plus_zero_l, ?@plus_zero_r.
auto.
Qed.

Lemma MTM_lambda_2_pos (h : R | 0 < h < 1.4):
0 <= (MTM_lambda_2 (proj1_sig h)).
Proof.
destruct h as (h & Hh); simpl.
unfold MTM_lambda_2.
interval with ( i_bisect h, i_taylor h, i_degree 3).
Qed.

Lemma MTM_lambda_2_pos_2 (h : R) :
 0 < h < 1.41->
0 <= (MTM_lambda_2 h).
Proof.
intros.
unfold MTM_lambda_2.
interval with ( i_bisect h, i_taylor h, i_degree 3).
Qed.

Lemma MTM_lambda_1_pos_2 (h : R) :
 0 < h < 1.41 ->
0 <= (MTM_lambda_1 h).
Proof.
intros.
unfold MTM_lambda_1.
interval with ( i_bisect h, i_taylor h, i_degree 3).
Qed.

Lemma Rdiv_le a b c d :
  0 < b  -> 0 < d ->
  a * b <= c * d -> a/d <= c/b.
Proof.
intros.
apply Rle_div_l in H1 ; auto.
replace (a * b / d ) with
(a / d * b) in H1 by nra.
rewrite Rle_div_r in H1; auto.
Qed.

Lemma Rdiv_le2 a b c  :
  0 < b  ->
  a  <= c  -> a/b <= c/b.
Proof.
intros.
apply Rle_div_l; auto.
replace (c / b * b) with c; auto.
field. nra.
Qed.

Lemma eig_MTM_le (h: R):
  0 < h < 1.41 ->
   (MTM_lambda_1 h) <=  (MTM_lambda_2 h).
Proof.
intros.
unfold MTM_lambda_1, MTM_lambda_2.
assert (h ^ 4 - 4 * h ^ 2 + 4 <> 0) by
  interval with ( i_bisect h, i_taylor h, i_degree 3).
apply Rdiv_le; try
interval with ( i_bisect h, i_taylor h, i_degree 3).
repeat rewrite pow2_abs.
field_simplify; try interval.
repeat rewrite pow2_sqrt; try nra.
field_simplify; auto.
match goal with |-context [?a ^ 3] =>
replace (a^3) with (a^2 * a) by nra
end.
repeat rewrite pow2_sqrt; try nra.
field_simplify; auto.
try apply Rdiv_le2; try
interval with ( i_bisect h, i_taylor h, i_degree 3).
apply Rminus_le.
field_simplify.
unfold Rminus.
rewrite ?Ropp_mult_distr_l.
rewrite <- ? Rmult_plus_distr_r.
apply Rmult_le_0_r; try apply sqrt_pos.
unfold pow.
rewrite <- ?Rmult_assoc, ?Rmult_1_r.
rewrite <- ? Rmult_plus_distr_r.
apply Rmult_le_0_r; try nra.
apply Rmult_le_0_r; try nra.
apply Rmult_le_0_r; try nra.
interval with ( i_bisect h, i_depth 9, i_taylor h, i_degree 5, i_prec 53).
Qed.

Lemma div_eq_1 :
 (forall a b : R, a = b -> b <> 0 -> a / b = 1).
Proof.
intros; subst. field; auto. Qed.

Lemma MTM_eigenvectors_orthogonal_1 (h: R):
  0 < h < 1.41 ->
Mmult (matrix_conj_transpose 2 2 (MTM_eigenvector_matrix h))
  (MTM_eigenvector_matrix h) = Mone.
Proof.
intros.
unfold MTM_eigenvector_matrix, matrix_conj_transpose.
repeat match goal with |- context [(@mk_matrix C 2 2 ?a)] =>
change (@mk_matrix C 2 2 a) with
(@mk_matrix (AbelianGroup.sort C_AbelianGroup) 2 2 a)
end.
unfold Mmult, Mone.
apply mk_matrix_ext => i j Hi Hj.
assert (Hi2: (i = 1)%nat \/ (i <> 1)%nat) by lia; destruct Hi2;
assert (Hj2: (j = 1)%nat \/ (j <> 1)%nat) by lia; destruct Hj2; subst; simpl.
-
repeat rewrite sum_Sn.
repeat rewrite sum_O.
repeat rewrite coeff_mat_bij; try lia.
unfold coeff_mat; simpl.
unfold Cconj,RtoC, MTM_eV_2; simpl.
change mult with Cmult.
change plus with Cplus.
change one with C1.
repeat rewrite coeff_mat_bij; try lia.
simpl.
cbv [Cplus Cmult RtoC C1 fst snd].
f_equal; field_simplify; try nra.
repeat rewrite pow2_sqrt.
field_simplify.
repeat rewrite pow2_abs.
field_simplify.
apply div_eq_1.
repeat rewrite pow2_sqrt; nra.
repeat rewrite pow2_sqrt; try nra.
apply Rgt_not_eq;
field_simplify.
interval
 with ( i_bisect h, i_depth 7, i_taylor h, i_degree 3).
split.
all: (try interval
 with ( i_bisect h, i_depth 7, i_taylor h, i_degree 3)).
repeat rewrite <- Rabs_mult.
match goal with |-context [?a <> 0] =>
  field_simplify a
end.
repeat match goal with |-context [Rabs( (?a / ?b) * (?a / ?b)) ] =>
replace ( (a / b) * (a / b)) with ( (a/b)^2) by nra
end.
repeat rewrite Rabs_sqr_le.
repeat rewrite pow2_abs.
match goal with |-context [?a <> 0] =>
  field_simplify a; try nra
end.
repeat rewrite pow2_sqrt; try nra.
match goal with |-context [?a <> 0] =>
  field_simplify a; try nra
end.
all: try split; try
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
-
assert (j = 0)%nat by lia; subst.
repeat rewrite sum_Sn.
repeat rewrite sum_O.
repeat rewrite coeff_mat_bij; try lia.
unfold coeff_mat; simpl.
unfold Cconj,RtoC, MTM_eV_1; simpl.
change mult with Cmult.
change plus with Cplus.
change one with C1.
change zero with C0.
repeat rewrite coeff_mat_bij; try lia.
simpl.
cbv [Cplus Cmult RtoC C0 fst snd].
f_equal; field_simplify; try nra.
repeat rewrite pow2_sqrt.
field_simplify.
assert ( forall a, 0/a = 0) by (intros;nra).
apply H0.
repeat rewrite Rmult_assoc.
match goal with |-context[h ^ 4 * ?a] =>
set (y:= a )
end.
replace (h ^ 4 * y - 4 * (h ^ 2 * y) + 4 * y) with
((h ^ 4 - 4 * h ^ 2  + 4 ) *y) by nra.
apply Rmult_integral_contrapositive_currified.
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
subst y.
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
repeat split; try
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
repeat split; try
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
-
assert (i = 0)%nat by lia; subst.
repeat rewrite sum_Sn.
repeat rewrite sum_O.
repeat rewrite coeff_mat_bij; try lia.
simpl.
unfold Cconj,RtoC, MTM_eV_1, MTM_eV_2; simpl.
change mult with Cmult.
change plus with Cplus.
change one with C1.
change zero with C0.
repeat rewrite coeff_mat_bij; try lia.
unfold coeff_mat; simpl.
cbv [Cplus Cmult RtoC C0 fst snd].
f_equal; field_simplify; try nra.
repeat rewrite pow2_sqrt.
field_simplify.
assert ( forall a, 0/a = 0) by (intros;nra).
apply H1.
repeat rewrite Rmult_assoc.
match goal with |-context[h ^ 4 * ?a] =>
set (y:= a )
end.
replace (h ^ 4 * y - 4 * (h ^ 2 * y) + 4 * y) with
((h ^ 4 - 4 * h ^ 2  + 4 ) *y) by nra.
apply Rmult_integral_contrapositive_currified.
interval
 with ( i_bisect h, i_depth 7, i_taylor h, i_degree 3).
subst y.
rewrite <- sqrt_mult.
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
interval
 with ( i_bisect h, i_depth 7, i_taylor h, i_degree 3).
repeat split; try
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
repeat split; try
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
-
assert (i = 0)%nat by lia; subst.
assert (j = 0)%nat by lia; subst.
repeat rewrite sum_Sn.
repeat rewrite sum_O.
repeat rewrite coeff_mat_bij; try lia.
unfold coeff_mat; simpl.
unfold Cconj,RtoC, MTM_eV_1; simpl.
change mult with Cmult.
change plus with Cplus.
change one with C1.
repeat rewrite coeff_mat_bij; try lia.
simpl.
cbv [Cplus Cmult RtoC C1 fst snd].
f_equal; field_simplify; try nra.
repeat rewrite pow2_sqrt.
field_simplify.
repeat rewrite pow2_abs.
field_simplify.
apply div_eq_1.
repeat rewrite pow2_sqrt; nra.
repeat rewrite pow2_sqrt; try nra.
apply Rgt_not_eq;
field_simplify.
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
repeat split.
all: (try repeat split; try interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7)).
Qed.

Lemma MTM_eigenvectors_orthogonal_2 (h: R):
  0 < h < 1.41 ->
Mmult (MTM_eigenvector_matrix h)
(matrix_conj_transpose 2 2 (MTM_eigenvector_matrix h)) = Mone.
Proof.
intros.
unfold MTM_eigenvector_matrix, matrix_conj_transpose.
repeat match goal with |- context [(@mk_matrix C 2 2 ?a)] =>
change (@mk_matrix C 2 2 a) with
(@mk_matrix (AbelianGroup.sort C_AbelianGroup) 2 2 a)
end.
unfold Mmult, Mone.
apply mk_matrix_ext => i j Hi Hj.
assert (Hi2: (i = 1)%nat \/ (i <> 1)%nat) by lia; destruct Hi2;
assert (Hj2: (j = 1)%nat \/ (j <> 1)%nat) by lia; destruct Hj2; subst; simpl.
-
repeat rewrite sum_Sn.
repeat rewrite sum_O.
repeat rewrite coeff_mat_bij; try lia.
unfold coeff_mat; simpl.
unfold Cconj,RtoC, MTM_eV_1, MTM_eV_2; simpl.
change mult with Cmult.
change plus with Cplus.
change one with C1.
repeat rewrite coeff_mat_bij; try lia.
simpl.
cbv [Cplus Cmult RtoC C1 fst snd].
f_equal; field_simplify; try nra.
repeat rewrite pow2_sqrt.
field_simplify.
repeat rewrite pow2_abs.
field_simplify.
apply div_eq_1.
repeat rewrite pow2_sqrt; try nra.
match goal with |-context[sqrt ?a ^ 4] =>
  replace (sqrt a ^ 4) with
 (sqrt a ^ 2 * sqrt a ^ 2) by nra
end.
repeat rewrite pow2_sqrt; try nra.
repeat rewrite pow2_sqrt; try nra.
all: (try repeat split; try interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7)).
-
assert (j = 0)%nat by lia; subst.
repeat rewrite sum_Sn.
repeat rewrite sum_O.
repeat rewrite coeff_mat_bij; try lia.
unfold coeff_mat; simpl.
unfold Cconj,RtoC, MTM_eV_1, MTM_eV_2; simpl.
change mult with Cmult.
change plus with Cplus.
change one with C1.
change zero with C0.
repeat rewrite coeff_mat_bij; try lia.
simpl.
cbv [Cplus Cmult RtoC C0 fst snd].
f_equal; field_simplify; try nra.
repeat rewrite pow2_sqrt.
field_simplify.
assert ( forall a b, b = 0 -> a<>0 -> b/a = 0) by (intros;nra).
apply H0; try interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
all: (try interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7)).
repeat rewrite pow2_abs; field_simplify; try nra.
apply H0; try interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
repeat rewrite pow2_sqrt; field_simplify; try nra.
repeat rewrite pow2_abs.
all: (try split; try apply sep_0_div;
(try interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7))).
all: (try split; try apply sep_0_div;
(try interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7))).
-
assert (i = 0)%nat by lia; subst.
repeat rewrite sum_Sn.
repeat rewrite sum_O.
repeat rewrite coeff_mat_bij; try lia.
unfold coeff_mat; simpl.
unfold Cconj,RtoC, MTM_eV_1, MTM_eV_2; simpl.
change mult with Cmult.
change plus with Cplus.
change one with C1.
change zero with C0.
repeat rewrite coeff_mat_bij; try lia.
simpl.
cbv [Cplus Cmult RtoC C0 fst snd].
f_equal; field_simplify; try nra.
repeat rewrite pow2_sqrt.
field_simplify.
assert ( forall a b, b = 0 -> a<>0 -> b/a = 0) by (intros;nra).
apply H1.
repeat rewrite Rmult_assoc.
repeat rewrite pow2_abs; field_simplify; try nra.
apply H1; try interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
repeat rewrite pow2_sqrt; try nra.
repeat rewrite pow2_abs.
match goal with |-context[ ?a <> 0] =>
field_simplify a;try nra;
repeat rewrite pow2_sqrt; try nra
end.
match goal with |-context[sqrt ?a ^ 4 ] =>
replace (sqrt a ^ 4) with
(sqrt a ^ 2 * sqrt a ^ 2) by nra;
repeat rewrite pow2_sqrt; try nra
end.
match goal with |-context[ ?a <> 0] =>
field_simplify a;try nra;
repeat rewrite pow2_sqrt; try nra
end; try interval
 with ( i_bisect h, i_depth 7, i_taylor h, i_degree 3).
apply sep_0_div; try split;
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
all : try repeat split; try
interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7).
-
assert (i = 0)%nat by lia; subst.
assert (j = 0)%nat by lia; subst.
repeat rewrite sum_Sn.
repeat rewrite sum_O.
repeat rewrite coeff_mat_bij; try lia.
unfold coeff_mat; simpl.
unfold Cconj,RtoC, MTM_eV_1, MTM_eV_2; simpl.
change mult with Cmult.
change plus with Cplus.
change one with C1.
repeat rewrite coeff_mat_bij; try lia.
simpl.
cbv [Cplus Cmult RtoC C1 fst snd].
f_equal; field_simplify; try nra.
repeat rewrite pow2_sqrt.
field_simplify.
all : try repeat split; try
interval
 with ( i_bisect h, i_depth 7, i_taylor h, i_degree 3).
repeat rewrite pow2_abs.
field_simplify.
apply div_eq_1.
repeat rewrite pow2_sqrt; try nra;
match goal with |-context[sqrt ?a ^ 4 ] =>
replace (sqrt a ^ 4) with
(sqrt a ^ 2 * sqrt a ^ 2) by nra;
repeat rewrite pow2_sqrt; try nra
end.
repeat rewrite pow2_sqrt; try nra.
match goal with |-context[ ?a <> 0] =>
field_simplify a;try nra;
repeat rewrite pow2_sqrt; try nra
end.
match goal with |-context[sqrt ?a ^ 4 ] =>
replace (sqrt a ^ 4) with
(sqrt a ^ 2 * sqrt a ^ 2) by nra;
repeat rewrite pow2_sqrt; try nra
end.
all: (try repeat split; try interval
 with ( i_bisect h, i_depth 10, i_taylor h, i_degree 7)).
Qed.

Lemma two_norm_bound_lambda2 (h : R | 0 < h < 1.41):
 two_norm_bound 2 (M (proj1_sig h)) (sqrt (MTM_lambda_2 (proj1_sig h))).
Proof.
apply ( sv_bound_implies_two_norm_bound
  (M (proj1_sig h)) (sqrt (MTM_lambda_2 (proj1_sig h)))).
unfold sv_bound.
destruct h as (h & Hh); simpl; split; try apply sqrt_pos.
exists (MTM_eigenvector_matrix h), (MTM_eigenvalue_matrix h).
repeat split.
-
rewrite MTM_aux.
apply (MTM_eigens_correct h Hh).
-
apply MTM_eigenvectors_orthogonal_1; auto.
-
apply MTM_eigenvectors_orthogonal_2; auto.
-
unfold diag_pred, MTM_eigenvalue_matrix; unfold coeff_mat;
intros; simpl; try lia.
destruct i as [|[|]]; try lia;
destruct j as [|[|]]; try lia;
reflexivity.
-
unfold MTM_eigenvalue_matrix, coeff_mat; simpl.
destruct i as [|[|]]; try lia; reflexivity.
-
destruct i as [|[|]]; try lia; simpl.
apply MTM_lambda_1_pos_2; auto.
apply MTM_lambda_2_pos_2; auto.
-
rewrite Rmult_1_r.
rewrite sqrt_def by (apply MTM_lambda_2_pos_2; auto).
destruct i as [|[|]]; try lia; simpl.
apply eig_MTM_le; auto.
apply Rle_refl.
Qed.

Definition σ (h: R) := sqrt (MTM_lambda_2 h).

Definition two_norm_M (h : R | 0 < h < 1.41) :=
  proj1_sig (exist (two_norm_bound 2 (M (proj1_sig h)))
                          (sqrt (MTM_lambda_2 (proj1_sig h)))
                          (two_norm_bound_lambda2 h)).

Lemma sigma_eq_two_norm_M:
  forall h, σ (proj1_sig h) = two_norm_M h.
Proof.
destruct h; reflexivity.
Qed.

(* 1.000003814704542914881812976091168820858001708984375 *)

Definition σb := 1.000003814704543.

Lemma sigma_bound: σ h <= σb.
Proof.
unfold σ, σb, MTM_lambda_2, h.
match goal with |- sqrt ?a <= _ => field_simplify a end.
match goal with |- ?a <= _ => interval_intro a upper end.
eapply Rle_trans.
apply H. nra.
interval.
Qed.

Lemma M_norm_sub_mult :
  forall (h : R | 0 < h < 1.41),
  forall (y : @matrix C 2 1%nat),
  vec_two_norm_2d (Mmult (M (proj1_sig h)) y) <= (two_norm_M h) * vec_two_norm_2d y.
Proof.
intros.
unfold two_norm_M. simpl.
repeat rewrite <- two_norms_eq_2d.
apply two_norm_bound_lambda2.
Qed.

Lemma matrix_analysis_method_bound_n :
  forall p q : R,
  forall n : nat,
  forall h : {h : R | 0 <  h < 1.41},
  let Mn := Mpow 2 n (M (proj1_sig h)) in
  vec_two_norm_2d  (Mmult Mn (s_vector (p, q))) <=
      (sqrt (Cmod (MTM_lambda_2 (proj1_sig h)))) ^ n * vec_two_norm_2d (s_vector (p,q)).
Proof.
intros ? ? ? h; intros.
induction n.
-
simpl. simpl in Mn.
rewrite Rmult_1_l.
subst Mn.
rewrite M_ID_equiv_M1.
rewrite Mmult_one_l.
apply Rle_refl.
-
unfold Mpow in Mn.
fold Mpow in Mn.
simpl in IHn.
subst Mn.
replace (Mmult (Mmult (Mpow 2 n
  (M (@proj1_sig R (fun h1 : R => 0 < h1 < 1.41) h))) (M (@proj1_sig R (fun h1 : R => 0 < h1 < 1.41) h))) (s_vector (p, q)))
with
( Mmult (M (@proj1_sig R (fun h1 : R => 0 < h1 < 1.41) h))
  (Mmult (Mpow 2 n (M (@proj1_sig R (fun h1 : R => 0 < h1 < 1.41) h))) (s_vector (p, q)))).
destruct (@Mmult C_Ring 2 2 1 (Mpow 2 n (M (@proj1_sig R (fun h1 : R => 0 < h1 < 1.41) h))) (s_vector (p, q))).
eapply Rle_trans.
pose proof M_norm_sub_mult h (t, t0).
apply H.
eapply Rle_trans.
apply Rmult_le_compat_l.
unfold two_norm_M; simpl.
apply sqrt_pos.
apply IHn.
unfold two_norm_M.
simpl.
rewrite Cmod_RtoC; try apply MTM_lambda_2_pos_2; try (destruct h; simpl; auto).
apply Req_le.
rewrite Rmult_assoc; auto.
rewrite Mmult_assoc.
rewrite Mpow_comm; auto.
Qed.

Lemma h_bnd_lem :
0 <  h < 1.41.
Proof.
split; unfold h; unfold ω; try nra.
Qed.

Theorem matrix_bound :
  forall p q: R,
  forall n : nat,
  let Mn := Mpow 2 n (M  h ) in
  vec_two_norm_2d  (Mmult Mn (s_vector (p, q))) <=
      σb ^ n * vec_two_norm_2d (s_vector (p,q)).
Proof.
intros.
set (j := (exist (fun x => 0 < x < 1.41) h) h_bnd_lem).
pose proof matrix_analysis_method_bound_n p q n j.
simpl in H.
eapply Rle_trans.
apply H.
apply Rmult_le_compat_r.
apply Rnorm_pos.
apply pow_incr; split.
apply sqrt_pos.
rewrite Cmod_RtoC.
apply sigma_bound.
apply MTM_lambda_2_pos_2.
unfold h. lra.
Qed.

Lemma Rprod_norm_vec_two_norm :
 forall ic,   ∥ ic ∥ = vec_two_norm _ (s_vector ic).
Proof.
intros.
rewrite two_norms_eq_2d.
unfold vec_two_norm_2d.
destruct ic as [p q]; simpl.
unfold Rprod_norm; simpl.
unfold Cmod, coeff_mat; simpl.
f_equal.
rewrite ?Rmult_0_l, ?Rplus_0_r, ?Rmult_1_r.
rewrite ?sqrt_sqrt; auto; nra.
Qed.

Lemma iternR_bound :
  forall p q: R,
  forall nf : nat,
  ( nf <=1000)%nat ->
  ∥iternR (p, q) h nf∥ <= σb ^ nf * ∥(p,q)∥.
Proof.
intros.
unfold σb.
apply Rle_trans with (σb ^ nf * vec_two_norm_2d (s_vector (p, q))).
-
pose proof matrix_bound p q nf.
simpl in H0.
rewrite Rprod_norm_vec_two_norm.
rewrite <- transition_matrix_equiv_iternR.
rewrite two_norms_eq_2d. lra.
-
apply Rmult_le_compat_l.
apply pow_le; try nra.
unfold vec_two_norm_2d, Rprod_norm.
unfold fst, snd, Cmod.
rewrite !pow2_sqrt by apply sqr_plus_pos.
simpl.
apply Req_le.
f_equal; nra.
Qed.

Lemma method_norm_bound :
  forall p q: R,
  ∥(leapfrog_stepR h (p,q))∥ <= σb * ∥(p,q)∥.
Proof.
intros.
assert (H : (1 <= 1000)%nat) by (simpl; lia).
eapply Rle_trans.
apply (iternR_bound p q 1 H).
apply Rmult_le_compat_r; try apply   Rnorm_pos.
lra.
Qed.

Lemma iternR_bound_max_step :
  forall p q: R,
  forall nf : nat,
  ( nf <=1000)%nat ->
  ∥iternR (p, q) h nf∥ <= 1.003822 * ∥(p,q)∥.
Proof.
intros.
eapply Rle_trans.
apply (iternR_bound p q nf H).
eapply Rmult_le_compat_r; try apply Rnorm_pos.
eapply Rle_trans.
apply Rle_pow. unfold σb. lra. eassumption.
interval with (i_prec 256).
Qed.

Close Scope R_scope.


(* week-01_functional-programming-in-Coq.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 15 Aug 2017 *)

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

Check 3.

(* Note: "nat" is the type of natural numbers. *)

Compute 3.

(* Note: natural numbers are self-evaluating. *)

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

Compute (4 + 6).

Check (4 + 6).

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

Check (plus 4 6).

(* Note: infix + is syntactic sugar for plus. *)

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

Check (plus 4).

(* Note: and plus refers to a library function. *)

Compute (plus 4).
Compute (plus 3).
Compute (plus 2).
Compute (plus 1).
Compute (plus 0).

(* Note: functions are written as in OCaml,
   with the keyword "fun" followed by the formal parameter
   (and optionally its type), "=>", and the body. *)

Compute (fun m : nat => S m).

(*
   For comparison,
     fun m : nat => S m
   would be written
     (lambda (m) (1+ n))
   in Scheme.
 *)

Compute ((fun m : nat => S m) 3).

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

Definition three := 3.

Check three.

Compute three.

Definition ten := 4 + 6.

Check ten.

Compute ten.

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

(* The following definitions are all equivalent: *)

Definition succ_v0 := fun m : nat => S m.

Definition succ_v1 := fun m => S m.

Definition succ_v2 (m : nat) :=
  S m.

Definition succ_v3 (m : nat) : nat :=
  S m.

Definition succ_v4 m :=
  S m.

(* Note: the definition of succ_v3 is the recommended one here. *)

(* Note: variables are defined once and for all in a file. *)

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

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

Definition test_add (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 1)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 1 1 =n= 2)
  &&
  (candidate 1 2 =n= 3)
  &&
  (candidate 2 1 =n= 3)
  &&
  (candidate 2 2 =n= 4)
  (* etc. *)
  .

Fixpoint add_v1 (i j : nat) : nat :=
  match i with
    | O => j
    | S i' => S (add_v1 i' j)
  end.

Compute (test_add add_v1).

Fixpoint add_v2 (i j : nat) : nat :=
  match i with
    | O => j
    | S i' => add_v2 i' (S j)
  end.

Compute (test_add add_v2).

Definition add_v3 (i j : nat) : nat :=
  let fix visit n :=
    match n with
      | O => j
      | S n' => S (visit n')
    end
  in visit i.

Compute (test_add add_v3).

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

Inductive list_nat : Type :=
  nil_nat : list_nat
| cons_nat : nat -> list_nat -> list_nat.

Fixpoint beq_list_nat (xs ys : list_nat) : bool :=
  match xs with
    nil_nat =>
    match ys with
      nil_nat =>
      true
    | cons_nat y ys' =>
      false
    end
  | cons_nat x xs' =>
    match ys with
      nil_nat =>
      false
    | cons_nat y ys' =>
      (x =n= y) && beq_list_nat xs' ys'
    end
  end.

Notation "A =ns= B" :=
  (beq_list_nat A B) (at level 70, right associativity).

(* ***** *)

Definition test_append (candidate: list_nat -> list_nat -> list_nat) : bool :=
  (candidate nil_nat nil_nat =ns= nil_nat)
  &&
  (candidate nil_nat (cons_nat 10 nil_nat) =ns= (cons_nat 10 nil_nat))
  &&
  (candidate (cons_nat 1 nil_nat) (cons_nat 10 nil_nat) =ns= (cons_nat 1 (cons_nat 10 nil_nat)))
  (* etc. *)
  .

Fixpoint append_v0 (xs ys : list_nat) : list_nat :=
  match xs with
  | nil_nat =>
    ys
  | cons_nat x xs' =>
    cons_nat x (append_v0 xs' ys)
  end.

Compute (test_append append_v0).

(* ***** *)

Definition test_length (candidate: list_nat -> nat) : bool :=
  (candidate nil_nat =n= 0)
  &&
  (candidate (cons_nat 1 nil_nat) =n= 1)
  &&
  (candidate (cons_nat 2 (cons_nat 1 nil_nat)) =n= 2)
  (* etc. *)
  .

Fixpoint length_v0 (xs : list_nat) : nat :=
  match xs with
  | nil_nat =>
    0
  | cons_nat x xs' =>
    S (length_v0 xs')
  end.

Compute (test_length length_v0).

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

Inductive binary_tree : Type :=
  Leaf : nat -> binary_tree
| Node : binary_tree -> binary_tree -> binary_tree.

Fixpoint beq_binary_tree (t1 t2 : binary_tree) : bool :=
  match t1 with
    Leaf n1 =>
    match t2 with
      Leaf n2 =>
      n1 =n= n2
    | Node t21 t22 =>
      false
    end
  | Node t11 t12 =>
    match t2 with
      Leaf n2 =>
      false
    | Node t21 t22 =>
      (beq_binary_tree t11 t21) && (beq_binary_tree t12 t22)
    end
  end.

Notation "A =bt= B" :=
  (beq_binary_tree A B) (at level 70, right associativity).

(* ***** *)

Definition test_number_of_leaves (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 1) =n= 1)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 2)
  (* etc. *)
  .

Fixpoint number_of_leaves_v0 (t : binary_tree) : nat :=
  match t with
    Leaf n =>
    1
  | Node t1 t2 =>
    (number_of_leaves_v0 t1) + (number_of_leaves_v0 t2)
  end.

Compute (test_number_of_leaves number_of_leaves_v0).

(* ***** *)

Definition test_swap (candidate: binary_tree -> binary_tree) : bool :=
  (candidate (Leaf 1) =bt= (Leaf 1))
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =bt= (Node (Leaf 2) (Leaf 1)))
  (* etc. *)
  .

Definition test_flatten (candidate: binary_tree -> list_nat) : bool :=
  (candidate (Leaf 1) =ns= (cons_nat 1 nil_nat))
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =ns= (cons_nat 1 (cons_nat 2 nil_nat)))
  (* etc. *)
  .

Fixpoint flatten_v0 (t : binary_tree) : list_nat :=
    match t with
    | Leaf n =>
      cons_nat n nil_nat
    | Node t1 t2 =>
      append_v0 (flatten_v0 t1) (flatten_v0 t2)
    end.

Compute (test_flatten flatten_v0).

(*
Fixpoint flatten_v1 (t : binary_tree) : list_nat :=
    match t with
    | Leaf n =>
      cons_nat n nil_nat
    | Node t1 t2 =>
      flatten_v1_aux t1 (flatten_v1 t2)
    end
with flatten_v1_aux (t : binary_tree) (a : list_nat) : list_nat :=
     append_v0 (flatten_v1 t) a.
 *)

Fixpoint flatten_v2 (t : binary_tree) : list_nat :=
    match t with
    | Leaf n =>
      cons_nat n nil_nat
    | Node t1 t2 =>
      flatten_v2_aux t1 (flatten_v2 t2)
    end
with flatten_v2_aux (t : binary_tree) (a : list_nat) : list_nat :=
       match t with
       | Leaf n =>
         append_v0 (cons_nat n nil_nat) a
       | Node t1 t2 =>
         append_v0 (flatten_v2_aux t1 (flatten_v2 t2)) a
       end.

Compute (test_flatten flatten_v2).

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

(* end of week-01_functional-programming-in-Coq.v *)
(* Local Variables: *)
(* End: *)


(* Author: Devendra
 *)
Require Import Coq.Lists.List.

Require Import Coq.Classes.EquivDec.

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

(* Definition xlist := [1;1;1;1]. *)

(* Check ([1; 2; 3; 4]). *)

(* Check (var1 [1; 2; 3]). *)

(* Inductive terms : Set := *)
(* | var : string -> terms *)
(* | app : string -> terms list -> terms. *)

Inductive term : Set :=
| var : nat -> term
| fn  : nat -> term -> term.

Check fn 1 (fn 1 (var 2)).

Inductive form : Set :=
| eq : term -> term -> form.

Notation "x -=- y" := (eq x y)
                        (at level 60).

Check (fn 1 (var 2)) -=- (var 2).

(* Check exists  *)

(* Inductive prf (l : list (term * term)) : term -> Prop := *)
(*   prfrefl (a : term) : (prf l a). *)

(* Inductive prf (l : list (term * term)) (a : term) : term -> Prop := *)
(*   prfrefl : prf l a a *)
(*   prfsym  : prf l a b -> prf l b a.  *)

(* The correctness condition *)

Inductive prf (l : list (term * term)) : term -> term -> Prop  :=
(* | paxm  :  *)
| pref : forall t, prf l t t
| psym : forall s t, prf l s t -> prf l t s
| ptrs : forall s t u, prf l s t -> prf l t u -> prf l s u
| pcong : forall (n : nat) s t, prf l s t -> prf l (fn n s) (fn n t).

Check psym [] (var 2) ( var 2) (pref [] (var 2) ).

Check prf.

(* computes all the subterms of a given term. *)

Fixpoint subterms (t : term) : list term :=
  match t with
  | var n => [var n]
  | fn n t1 => (fn n t1) :: subterms t1
  end.

(* give list of tuples of term and its parent *)

Fixpoint parent_list (t : term) :=
  match t with
  | var _ => []
  | fn n t => (t, fn n t) :: parent_list t
  end.

Eval compute in parent_list (fn 1 (var 2)).

Scheme Equality for term.

Check term_eq_dec.

Eval compute in term_eq_dec (var 2) (fn 1 (var 3)).

Eval compute in term_beq (var 2) (var 3).

Eval compute in if (term_beq (var 2) (var 2)) then 1 else 0.

(* Ignore this *)

Definition f (t : term) (arg : term*term) :=
  match arg with
  | (x, _) => term_beq t x
  end.

(* gets the parents of a particular term from parent_list *)

Definition get_parents (t : term) (l : list (term*term)) :=
  map (fun x => match x with | (_, n) => n end) (filter (f t) l).

Eval compute in get_parents (var 2) (parent_list (fn 1 (var 2)) ++ parent_list (fn 3 (var 2))).

Check remove.

Check List.remove.

Check last.

Eval compute in remove term_eq_dec (var 2) [var 2; var 3; var 4].

Definition removeT l := remove term_eq_dec (var 2) l.

(* Scheme Equality for term*term. *)

Definition term_pairs_eqb (u v : term * term) :=
  match (u, v) with
  | ((a, b), (c, d)) => andb  (term_beq a c) (term_beq b d)
  end.

(* equality for... *)
(* Definition term_pairs_eq_dec (u v : term * term) := *)
(*   match (u, v) with *)
(*   | ((a, b), (c, d)) => (term_eq_dec a c) /\ (term_eq_dec b d) *)
(*   end. *)

Definition removeTP a l := remove term_pairs_eq a l.

(* Setting up the UF datastructure. Will need further modification *)

(* Fixpoint uf_find (l : list (term*term)) (t : term) := *)
(*   match l with *)
(*   | [] => var 1000 *)
(*   | (x, y)::ls => if term_beq x t then (if term_beq x y then x else uf_find l y) else *)
(*                     uf_find ls t *)
(*   end. *)

(* Fixpoint uf_merge (l : list (term*term)) (u v : term) := *)
(*   let a := uf_find l u in *)
(*   let b := uf_find l v in *)
(*   if term_beq a b then l else remove *)

(* Ignore this *)
(* Fixpoint get_parents (t : term) (l : list (term*nat)) := *)
(*   match l with *)
(*   | [] => [] *)
(*   | (x,n) :: xs => match t with *)
(*                    | x => n :: get_parents t xs *)
(*                    | _ => get_parents t xs *)
(*                    end *)

(*   end. *)


Require Export PropLang.
Require Export RelationClasses.
Require Export Morphisms.
Require Export List.

Section subcontext.

Context {atom : Type}.

Definition subcontext (Γ₁ Γ₂ : list (prop atom)) : Prop :=
forall P, In P Γ₁ -> In P Γ₂.
Infix "⊆" := subcontext (no associativity, at level 70).

Global Instance subcontext_preord : PreOrder subcontext.
Proof.
constructor.
+ intro Γ. red. trivial.
+ intros Γ₁ Γ₂ Γ₃; unfold subcontext. auto.
Qed.

Lemma subcontext_cons : forall P Γ₁ Γ₂, P :: Γ₁ ⊆ Γ₂ <->
  In P Γ₂ /\ Γ₁ ⊆ Γ₂.
Proof.
split; intros; repeat split.
+ apply H; left; reflexivity.
+ intros x ?; apply H; right; assumption.
+ destruct H. intro x; destruct 1; subst; auto.
Qed.

Lemma subcontext_cons_r : forall P Γ, Γ ⊆ P :: Γ.
Proof.
intros P Γ x ?; right; assumption.
Qed.

Global Instance subcontext_cons_proper :
  Proper (eq ==> subcontext ++> subcontext) (@cons (prop atom)).
Proof.
intros P Q [] Γ₁ Γ₂ ?. rewrite subcontext_cons; split.
+ left; reflexivity.
+ rewrite H; apply subcontext_cons_r.
Qed.

End subcontext.

Infix "⊆" := subcontext (no associativity, at level 70).

Ltac prove_In :=
match goal with
| |- In ?P (?P :: ?Γ) => left; reflexivity
| |- In ?P (?Q :: ?Γ) => right; prove_In
end.
Ltac prove_subcontext :=
match goal with
| |- ?P :: ?Γ ⊆ ?Γ' => rewrite subcontext_cons; split;
     [ prove_In | prove_subcontext ]
| |- ?Γ ⊆ ?Γ => reflexivity
| |- ?Γ ⊆ ?P :: ?Γ' => rewrite <- (subcontext_cons_r P Γ');
                       prove_subcontext
end.


Require Import Arith Bool List.
Require Import Omega.
Set Implicit Arguments.

Lemma seq_minimum : forall m n x, In x (seq n m) -> n <= x.
Proof.
  induction m.
  - simpl.
    intro; contradiction.
  - intros n x.
    simpl.
    intro.
    destruct H; try omega.
    apply IHm in H.
    omega.
Qed.

Lemma seq_nodup : forall m n, NoDup (seq n m).
Proof.
  induction m; intros; simpl; constructor.
  - unfold not; intro.
    apply seq_minimum in H.
    omega.
  - auto.
Qed.

Lemma count_occ_app A dec :
 forall (x : A) (ys zs : list A),
 count_occ dec (ys ++ zs) x = count_occ dec ys x + count_occ dec zs x.
Proof.
  induction ys; auto.
  intro zs.
  simpl.
  rewrite (IHys zs).
  destruct (dec a x); omega.
Qed.

Fixpoint scan_left (A B : Type) (f : A -> B -> A) (bs : list B)
(a : A): list A :=
  match bs with
  | nil => a :: nil
  | b :: bs' => let a' := f a b in a :: scan_left f bs' a'
  end.

Lemma scanl_exist_tl A B :
 forall (f : A -> B -> A) bs a, exists as', scan_left f bs a = a :: as'.
Proof.
  intros.
  destruct bs.
  - simpl.
    exists nil.
    reflexivity.
  - simpl.
    exists (scan_left f bs (f a b)).
    reflexivity.
Qed.

Lemma foldl_scanl_last A B :
 forall f (bs : list B) (a : A) d,
 fold_left f bs a = last (scan_left f bs a) d.
Proof.
  induction bs as [| b bs' IHbs'].
  - intros a d.
    reflexivity.
  - intros.
    simpl fold_left.
    specialize (IHbs' (f a b) d).
    rewrite IHbs'.
    simpl scan_left.
    remember (scanl_exist_tl f bs' (f a b)) as Extl; clear HeqExtl.
    destruct Extl.
    rewrite H.
    reflexivity.
Qed.

Fixpoint rep A (a : A) (n : nat): list A :=
  match n with
  | O => nil
  | S n' => a :: rep a n'
  end.
Lemma rep_length A a n : length (@rep A a n) = n.
Proof.
  induction n; simpl; auto.
Qed.

Lemma rep_in A a n : forall x, In x (@rep A a n) -> a = x.
Proof.
  induction n; simpl; intuition.
Qed.

Lemma rep_count A dec a n : count_occ dec (@rep A a n) a = n.
Proof.
  induction n; auto.
  simpl.
  case (dec a a); intro; auto.
  exfalso; apply n0.
  reflexivity.
Qed.

Lemma rep_count_0 A dec a b n : a <> b -> count_occ dec (@rep A a n) b = 0.
Proof.
  intro a_ne_b.
  induction n; auto.
  simpl.
  case (dec a b); intro; try contradiction; auto.
Qed.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_onray_betweenness.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_onray_orderofpoints_any :
	forall A B P,
	OnRay A B P ->
	(BetS A P B \/ eq B P \/ BetS A B P).
Proof.
	intros A B P.
	intros OnRay_AB_P.

	assert (~ ~ (BetS A P B \/ eq B P \/ BetS A B P)) as BetS_A_P_B_or_eq_B_P_or_BetS_A_B_P.
	{
		intro n_BetS_A_P_B_or_eq_B_P_or_BetS_A_B_P.

		apply Classical_Prop.not_or_and in n_BetS_A_P_B_or_eq_B_P_or_BetS_A_B_P as (
			nBetS_A_P_B & n_eq_B_P_or_BetS_A_B_P
		).
		apply Classical_Prop.not_or_and in n_eq_B_P_or_BetS_A_B_P as (neq_B_P & nBetS_A_B_P).
		pose proof (lemma_inequalitysymmetric _ _ neq_B_P) as neq_P_B.
		pose proof (lemma_onray_betweenness _ _ _ OnRay_AB_P neq_P_B nBetS_A_P_B) as BetS_A_B_P.

		contradict BetS_A_B_P.
		exact nBetS_A_B_P.
	}
	apply Classical_Prop.NNPP in BetS_A_P_B_or_eq_B_P_or_BetS_A_B_P.
	exact BetS_A_P_B_or_eq_B_P_or_BetS_A_B_P.
Qed.

End Euclid.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Lists.List.
Import ListNotations.
Require Import FunInd FMapInterface.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.FSets.FMapInterface.
Require Import Lia.

(* Definition of Pure Lambda Calculus *)

Inductive tm : Type :=
| tm_var   : nat -> tm
| tm_app   : tm -> tm -> tm
| tm_abs   : tm -> tm.

Inductive value : tm -> Prop :=
| v_abs : forall t,
    value (tm_abs t)
| v_var : forall x,
    value (tm_var x).

Inductive nonvalue : tm -> Prop :=
| nv_app : forall t1 t2,
    nonvalue (tm_app t1 t2).

Fixpoint isvalue (p:tm) : bool :=
  match p with
  | tm_abs _ => true
  | tm_var _ => true
  | tm_app _ _ => false
  end.

(* De Brujin index *)

Fixpoint liftX  (n : nat) (t : tm) : tm :=
  match t with
  | tm_var ix =>
    if lt_dec ix n then t else tm_var (S ix)
  | tm_abs x1 => tm_abs (liftX (S n) x1)
  | tm_app x1 x2 => tm_app (liftX n x1) (liftX n x2)
  end.

Fixpoint substX (n:  nat) (u:  tm) (t: tm) : tm :=
  match t with
  | tm_var ix =>
    if lt_dec ix n
    then tm_var ix
    else if lt_dec n ix
         then tm_var (ix - 1)
         else u
  | tm_abs x2
    => tm_abs (substX (S n) (liftX 0 u) x2)
  | tm_app x1 x2
    => tm_app (substX n u x1) (substX n u x2)
  end.

Ltac kill_lift :=
  match goal with
  | [ |- context [lt_dec ?n ?n'] ]
    => case (lt_dec n n'); intros
  | [H: context [lt_dec ?n ?n'] |- _]
    => destruct (lt_dec n n'); intros
  end.

Ltac solve_lift :=
  lia || kill_lift || auto using Nat.sub_0_r || simpl.

Lemma liftX_liftX: forall t1 n n',
    liftX n (liftX (n + n') t1)
    = liftX (1 + (n + n')) (liftX n t1).
Proof with eauto.
  induction t1; intros; simpl in *...
  - repeat solve_lift.
  - rewrite IHt1_1. rewrite IHt1_2...
  - specialize IHt1 with (S n) n'.
    assert (S (n + n') = S n + n') by lia.
    rewrite H.
    rewrite IHt1...
Qed.

Lemma substX_liftX: forall t1 t2 n,
    substX n t2 (liftX n t1) = t1.
Proof with eauto.
  induction t1; intros; simpl...
  - repeat solve_lift...
  - rewrite IHt1_1. rewrite IHt1_2. reflexivity.
  - rewrite IHt1...
Qed.

Lemma liftX_substX: forall t1 t2 n n',
    liftX n (substX (n + n') t2 t1)
    = substX (1 + n + n') (liftX n t2) (liftX n t1).
Proof with eauto.
  induction t1; intros; simpl in *...
  - repeat solve_lift.
    assert (S (n - 1) = n - 0) by lia.
    rewrite H...
  - rewrite <- IHt1_1. rewrite IHt1_2. reflexivity.
  - specialize IHt1 with (liftX 0 t2) (S n) n'.
    assert (S (n + n') = S n + n') by lia.
    rewrite H. rewrite IHt1. simpl.
    assert (liftX 0 (liftX n t2) = liftX (S n) (liftX 0 t2)). {
      assert (n = 0 + n) by lia.
      rewrite H0.
      rewrite liftX_liftX with t2 0 n.
      auto.
    }
    rewrite H0...
Qed.

Lemma liftX_substX': forall t1 t2 n n',
    liftX (n + n') (substX n t2 t1)
    = substX n (liftX (n + n') t2) (liftX (1 + n + n') t1).
Proof with eauto.
  induction t1; intros; simpl in *...
  - repeat solve_lift.
    assert (S (n - 1) = n - 0) by lia.
    rewrite H...
  - rewrite <- IHt1_1. rewrite IHt1_2...
  - specialize IHt1 with (liftX 0 t2) (S n) n'.
    assert (S (n + n') = S n + n') by lia.
    rewrite H. rewrite IHt1. simpl.
    assert (liftX (S (n + n')) (liftX 0 t2) = liftX 0 (liftX (n + n') t2)). {
      assert (n + n' = 0 + (n + n')) by lia.
      rewrite H0.
      rewrite liftX_liftX.
      auto.
    }
    rewrite <- H0...
Qed.

Lemma substX_substX: forall t1 t2 t3 n m,
    substX (n + m) t3 (substX n t2 t1)
    = substX n (substX (n + m) t3 t2)
             (substX (1 + n + m) (liftX n t3) t1).
Proof with eauto.
  induction t1; intros; simpl in *...
  - repeat solve_lift. rewrite substX_liftX...
  - rewrite IHt1_1. rewrite IHt1_2...
  - specialize IHt1 with (liftX 0 t2) (liftX 0 t3) (S n) m.
    assert (S (n + m) = S n + m) by lia.
    rewrite H. rewrite IHt1. simpl.
    assert (liftX (S n) (liftX 0 t3) = liftX 0 (liftX n t3)). {
      assert (S n = 1 + (0 + n)) by lia. rewrite H0.
      rewrite <- liftX_liftX...
    }
    rewrite H0.
    assert (substX (S (n + m)) (liftX 0 t3) (liftX 0 t2) = liftX 0 (substX (n + m) t3 t2)). {
      assert (S (n + m) = 1 + 0 + (n + m)) by lia.
      rewrite H1. rewrite <- liftX_substX...
    }
    rewrite H1...
Qed.

(* Evaluation *)

(* Weak Head reduction *)
Inductive step : tm -> tm -> Prop :=
| ST_AppAbs : forall t1 v2,
    value v2 ->
    step (tm_app (tm_abs t1) v2) (substX 0 v2 t1)
| ST_App1 : forall t1 t1' t2,
    step t1 t1' ->
     step (tm_app t1 t2) (tm_app t1' t2)
| ST_App2 : forall v1 t2 t2',
    value v1 ->
    step t2 t2' ->
    step (tm_app v1 t2) (tm_app v1 t2').

(* Beta reduction *)
Inductive reduce : tm -> tm -> Prop :=
| Red_Self : forall t, reduce t t
| Red_Body : forall t1 t2,
    reduce t1 t2 ->
    reduce (tm_abs t1) (tm_abs t2)
| Red_App1 : forall t1 t1' t2 t2',
    reduce t1 t1' ->
    reduce t2 t2' ->
    reduce (tm_app t1 t2) (tm_app t1' t2')
| Red_App2 : forall t1 t1' v2 v2',
    value v2 ->
    reduce t1 t1' ->
    reduce v2 v2' ->
    reduce (tm_app (tm_abs t1) v2) (substX 0 v2' t1').

(* Non-head reduction *)
Inductive ireduce : tm -> tm -> Prop :=
| Int_Self : forall t, ireduce t t
| Int_Body : forall t1 t2,
    reduce t1 t2 ->
    ireduce (tm_abs t1) (tm_abs t2)
| Int_App1 : forall t1 t1' t2 t2',
    nonvalue t1 ->
    ireduce t1 t1' ->
    reduce t2 t2' ->
    ireduce (tm_app t1 t2) (tm_app t1' t2')
| Int_App2 : forall t1 t1' t2 t2',
    ireduce t1 t1' ->
    ireduce t2 t2' ->
    ireduce (tm_app t1 t2) (tm_app t1' t2').

Hint Constructors value : core.
Hint Constructors nonvalue : core.
Hint Constructors step :  core.
Hint Constructors reduce : core.
Hint Constructors ireduce : core.

Inductive multi {X : Type} (R : relation X) : relation X :=
| multi_refl : forall (x : X), multi R x x
| multi_step : forall (x y z : X),
    R x y ->
    multi R y z ->
    multi R x z.

Theorem multi_R : forall (X : Type) (R : relation X) (x y : X),
    R x y -> (multi R) x y.
Proof.
  intros X R x y H.
  apply multi_step with y. apply H. apply multi_refl.
Qed.

Theorem multi_trans :
  forall (X : Type) (R : relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  intros X R x y z G H.
  induction G.
    - assumption.
    - apply multi_step with y. assumption.
      apply IHG. assumption.
Qed.

Notation mstep := (multi step).
Notation mreduce := (multi reduce).
Notation mireduce := (multi ireduce).

(* Example *)

Example e1: mstep (tm_app (tm_abs (tm_var 1000)) (tm_var 100)) (tm_var 999).
Proof.
  apply multi_R.
  constructor. constructor.
Qed.

Inductive halt : tm -> Prop :=
| Halt : forall t1 t2, mstep t1 t2 -> value t2 -> halt t1.

Hint Constructors halt:Core.

Inductive val_or_not : tm -> Prop :=
| Is_Val : forall t, value t -> val_or_not t
| Not_Val : forall t, nonvalue t -> val_or_not t.

Hint Constructors val_or_not:Core.

Lemma decide_val : forall t,
    val_or_not t.
Proof with eauto.
  destruct t.
  - apply Is_Val...
  - apply Not_Val...
  - apply Is_Val...
Qed.

Lemma step_nvalue : forall t1 t2,
    step t1 t2 -> nonvalue t1.
Proof with eauto.
  intros. induction H... Qed.

(* Reduction *)

Lemma step_implies_reduce : forall t1 t2,
    step t1 t2 -> reduce t1 t2.
Proof with eauto.
  intros. induction H... Qed.

Lemma mstep_implies_mreduce : forall t1 t2,
    mstep t1 t2 -> mreduce t1 t2.
Proof with eauto.
  intros.
  induction H;
    eauto using step_implies_reduce, multi_trans, multi_R.
Qed.

Lemma reduce_val : forall t1 t2,
    reduce t1 t2 -> value t1 -> value t2.
Proof with eauto.
  intros. destruct H0; inversion H; subst; constructor.
Qed.

Lemma reduce_compact : forall t1 t2 t2',
    reduce t2 t2' -> reduce (tm_app t1 t2) (tm_app t1 t2).
Proof with eauto.
  intros. induction H... Qed.

Lemma lift_inv_val : forall t1 n,
    value t1 <-> value (liftX n t1).
Proof with eauto.
  intros. split; intros.
  - induction n; destruct H; simpl;
      solve [repeat constructor ||
                    match goal with
                    | [|- context[if ?a then _ else ?c]] => destruct a
                    end].
  - induction t1... simpl in *. inversion H.
Qed.

Lemma lift_inv_nonval : forall t1 n,
    nonvalue t1 <-> nonvalue (liftX n t1).
Proof with eauto.
  intros. split; intros.
  - induction n; destruct H; simpl;
      try solve [constructor].
  - induction t1; simpl in H...
    destruct (lt_dec n0 n); inversion H.
    inversion H.
Qed.

Lemma subst_inv_val : forall t1 t2 n,
    value t2 ->
    value t1 <-> value (substX n t2 t1).
Proof with eauto.
  intros. split; intros.
  - induction t1; destruct H; simpl;
      try repeat solve_lift; inversion H0.
  - induction t1; destruct H; simpl; inversion H0...
Qed.

Lemma subst_inv_nval : forall t1 t2 n,
    value t2 ->
    nonvalue t1 <-> nonvalue (substX n t2 t1).
Proof with eauto.
  intros. split; intros.
  - induction t1; destruct H; simpl;
      try repeat solve_lift; inversion H0.
  - induction t1; simpl in *...
    destruct (lt_dec n0 n) eqn:Eb...
    destruct (lt_dec n n0) eqn:Eb'...
    inversion H0.
    destruct H0. inversion H.
    inversion H0.
Qed.

Lemma step_subst : forall t1 t2 t2' n,
    step t2 t2' -> value t1 ->
    step (substX n t1 t2) (substX n t1 t2').
Proof with eauto.
  intros.
  generalize dependent t1.
  generalize dependent n.
  induction H; intros; simpl in *...
  + assert (n = 0 + n) by lia.
    rewrite H1. rewrite substX_substX.
    constructor. rewrite <- subst_inv_val...
  + constructor... rewrite <- subst_inv_val...
Qed.

Lemma reduce_lift : forall t1 t1' n,
    reduce t1 t1' ->
    reduce (liftX n t1) (liftX n t1').
Proof with eauto.
  intros. generalize dependent n.
  induction H; intros; simpl in *...
  - assert (n = 0 + n) by lia.
    rewrite H2.
    rewrite liftX_substX'.
    simpl.
    constructor...
    apply lift_inv_val...
Qed.

Lemma reduce_subst : forall t1 t1' t2 t2' n,
    reduce t1 t1' -> reduce t2 t2' -> value t2 ->
    reduce (substX n t2 t1) (substX n t2' t1').
Proof with eauto using reduce_lift.
  intros. generalize dependent n.
  generalize dependent t2. generalize dependent t2'.
  induction H; simpl in *...
  - induction t; intros; simpl in *...
    + repeat solve_lift.
    + constructor... apply IHt... rewrite <- lift_inv_val...
  - intros. constructor. apply IHreduce... rewrite <- lift_inv_val...
  - intros. assert (n = 0 + n) by lia. rewrite H4.
    rewrite substX_substX. simpl.
    constructor... rewrite <- subst_inv_val...
    apply IHreduce1... rewrite <- lift_inv_val...
Qed.

Lemma ireduce_subst : forall t1 t1' t2 t2' n,
    ireduce t1 t1' -> reduce t2 t2' -> value t2 ->
    ireduce (substX n t2 t1) (substX n t2' t1').
Proof with eauto using reduce_subst, reduce_lift.
  intros. generalize dependent n.
  generalize dependent t2. generalize dependent t2'.
  induction H; simpl in *...
  - induction t; intros; simpl in *...
    repeat solve_lift.
    destruct H1. inversion H0...
    inversion H0; subst...
    constructor. apply reduce_subst...
    rewrite <- lift_inv_val...
  - intros. constructor. apply reduce_subst...
    rewrite <- lift_inv_val...
  - intros. constructor. rewrite <- subst_inv_nval...
    apply IHireduce...
    apply reduce_subst...
Qed.

Lemma ireduce_nval : forall t1 t2,
    ireduce t1 t2 -> nonvalue t1 -> nonvalue t2.
Proof with eauto.
  intros. induction H... inversion H0. Qed.

Lemma ireduce_inv_val : forall t1 t2,
    ireduce t1 t2 -> value t2 -> value t1.
Proof with eauto.
  intros. induction H; try solve [inversion H0]... Qed.

Lemma ireduce_inv_nval : forall t1 t2,
    ireduce t1 t2 -> nonvalue t2 -> nonvalue t1.
Proof with eauto.
  intros. induction H; try solve [inversion H0]... Qed.

Lemma mireduce_inv_val : forall t1 t2,
    mireduce t1 t2 -> value t2 -> value t1.
Proof with eauto.
  intros. induction H; eauto using ireduce_inv_val.
Qed.

Lemma mireduce_inv_nval : forall t1 t2,
    mireduce t1 t2 -> nonvalue t2 -> nonvalue t1.
Proof with eauto.
  intros. induction H; eauto using ireduce_inv_nval...
Qed.

Lemma ireduce_implies_reduce: forall t1 t2,
    ireduce t1 t2 -> reduce t1 t2.
Proof with eauto.
  intros. induction H... Qed.

Inductive sreduce : tm -> tm -> Prop :=
| SRed__z : forall t1 t2,
    ireduce t1 t2 -> sreduce t1 t2
| SRed__s : forall t1 t2 t3,
    reduce t1 t3 -> step t1 t2 -> sreduce t2 t3 -> sreduce t1 t3.

Hint Constructors sreduce : Core.

Lemma sreduce_implies_reduce : forall t1 t2,
    sreduce t1 t2 -> reduce t1 t2.
Proof with eauto.
  intros. induction H... induction H... Qed.

(* Lemma 2 *)
Lemma sreduce_app_nval : forall t1 t1' t2 t2',
    sreduce t1 t1' -> reduce t2 t2' -> nonvalue t1' ->
    sreduce (tm_app t1 t2) (tm_app t1' t2').
Proof with eauto.
  intros. generalize dependent t2. generalize dependent t2'.
  induction H.
  - constructor... constructor... eapply ireduce_inv_nval...
  - intros. eapply IHsreduce in H1. eapply SRed__s in H1... assumption.
Qed.

Lemma sreduce_app_val : forall t1 t1' t2 t2',
    sreduce t1 t1' -> sreduce t2 t2' -> value t1' ->
    sreduce (tm_app t1 t2) (tm_app t1' t2').
Proof with eauto.
  intros.
  generalize dependent t2. generalize dependent t2'.
  induction H; intros; induction H0; simpl in *;
    try solve
        [eapply SRed__s; eauto; constructor; eauto;
         apply sreduce_implies_reduce; eauto]...
  - constructor. apply Int_App2...
  - eapply SRed__s... constructor...
    apply ireduce_implies_reduce...
    constructor... eapply ireduce_inv_val in H1...
Qed.

(* Lemma 3 *)
Lemma sreduce_app: forall t1 t1' t2 t2',
    sreduce t1 t1' -> sreduce t2 t2' ->
    sreduce (tm_app t1 t2) (tm_app t1' t2').
Proof with eauto.
  intros. assert (val_or_not t1') by auto using decide_val.
  inversion H1; subst.
  - apply sreduce_app_val...
  - apply sreduce_app_nval...
    apply sreduce_implies_reduce...
Qed.

Lemma sreduce_compact: forall t1 t2 t2' n,
    sreduce t2 t2' -> value t2 ->
    sreduce (substX n t2 t1 ) (substX n t2' t1).
Proof with eauto.
  induction t1; simpl; intros; try repeat solve_lift...
  - repeat constructor.
  - repeat constructor.
  - apply sreduce_app.
    apply IHt1_1... apply IHt1_2...
  - constructor. constructor.
    apply reduce_subst...
    apply reduce_lift... apply sreduce_implies_reduce...
    rewrite <- lift_inv_val...
Qed.

(* Lemma 4 *)
Lemma ireduce_sreduce_subst: forall t1 t1' t2 t2' n,
    ireduce t1 t1' -> sreduce t2 t2' -> value t2 ->
    sreduce (substX n t2 t1) (substX n t2' t1').
Proof with eauto.
  intros.
  generalize dependent t2. generalize dependent t2'.
  generalize dependent n.
  induction H; simpl in *...
  - intros. apply sreduce_compact...
  - intros. constructor. constructor.
    apply reduce_subst... apply reduce_lift...
    apply sreduce_implies_reduce...
    rewrite <- lift_inv_val...
  - intros. repeat constructor.
    rewrite <- subst_inv_nval...
    apply ireduce_subst...
    apply sreduce_implies_reduce...
    apply reduce_subst...
    apply sreduce_implies_reduce in H2...
  - intros. constructor. apply sreduce_implies_reduce in H1.
    apply Int_App2; apply ireduce_subst...
Qed.

(* Lemma 5 *)
Lemma sreduce_subst: forall t1 t1' t2 t2' n,
    sreduce t1 t1' ->
    sreduce t2 t2' -> value t2 ->
    sreduce (substX n t2 t1) (substX n t2' t1').
Proof with eauto.
  intros.
  generalize dependent t2. generalize dependent t2'.
  generalize dependent n.
  induction H; intros.
  - apply ireduce_sreduce_subst...
  - eapply SRed__s.
    + apply reduce_subst...
      apply sreduce_implies_reduce...
    + apply step_subst...
    + apply IHsreduce...
Qed.

Lemma reduce_implies_sreduce: forall t1 t2,
    reduce t1 t2 -> sreduce t1 t2.
Proof with eauto.
  intros. induction H.
  - repeat constructor.
  - repeat constructor...
  - apply sreduce_app...
  - eapply SRed__s.
    constructor...
    constructor...
    apply sreduce_subst...
Qed.

Lemma sreduce_implies_mstep_ireduce: forall t1 t3,
    sreduce t1 t3 -> exists t2, mstep t1 t2 /\ ireduce t2 t3.
Proof with eauto using multi_R, multi_trans.
  intros.
  induction H...
  - eexists. split... constructor.
  - destruct IHsreduce. destruct H2.
    exists x. split...
Qed.

(* Lemma 6: main lemma*)
Lemma reduce_implies_mstep_ireduce: forall t1 t3,
    reduce t1 t3 -> exists t2, mstep t1 t2 /\ ireduce t2 t3.
Proof.
  eauto using sreduce_implies_mstep_ireduce, reduce_implies_sreduce. Qed.

Ltac kill_step :=
  match goal with
    | [H: step _ _ |- _] => inversion H
    | [H: step _ _ |- _] => inversion H
    | [H: value (tm_app ?a ?b) |- _] => inversion H
    | [H: value ?a, G: step ?a _ |- _] => destruct H; inversion G
  end.

Ltac solve_step :=
  kill_step || auto || simpl in *.

(* Postponement *)

(* Lemma 7: Postponement *)
Lemma ireduce_step_implies_step_reduce: forall t1 t2 t3,
    ireduce t1 t2 -> step t2 t3 ->
    exists t2', step t1 t2' /\ reduce t2' t3.
Proof with eauto.
  (*
    Note: the paper said induction on t1
    But in fact you will lost information by that
    So we induct by hypothesis on Coq
  *)
  intros. generalize dependent t3.
  induction H; intros.
  - eexists...
  - inversion H0.
  - apply ireduce_nval in H0 as H'...
    destruct H'. destruct H.
    inversion H2; subst...
    eapply IHireduce in H5...
    destruct H5. destruct H. eexists. split...
    inversion H4.
  - apply ireduce_implies_reduce in H as I.
    apply ireduce_implies_reduce in H0 as I0.
    inversion H1; subst...
    + apply ireduce_inv_val in H as H'...
      apply ireduce_inv_val in H0 as H''...
      destruct H'; try solve [inversion H].
      eexists. split. constructor...
      inversion H; subst; apply reduce_subst...
    + apply step_nvalue in H5 as H'.
      apply ireduce_inv_nval in H...
      destruct H. destruct H'.
      apply IHireduce1 in H5.
      destruct H5. destruct H.
      eexists. split...
    + apply IHireduce2 in H6. destruct H6. destruct H2.
      eexists (tm_app t1 x). split... constructor...
      apply ireduce_inv_val in H...
Qed.

(* Collary 8 *)
Lemma ireduce_step_implies_mstep_ireduce: forall t1 t2 t3,
    ireduce t1 t2 -> step t2 t3 ->
    exists t2', mstep t1 t2' /\ ireduce t2' t3.
Proof with eauto.
  intros.
  eapply ireduce_step_implies_step_reduce in H...
  destruct H. destruct H.
  apply reduce_implies_mstep_ireduce in H1.
  destruct H1. destruct H1.
  eexists. split...
  eapply multi_trans...
  eapply multi_R...
Qed.

Lemma ireduce_mstep_implies_mstep_ireduce: forall t1 t2 t3,
    ireduce t1 t2 -> mstep t2 t3 ->
    exists t2', mstep t1 t2' /\ ireduce t2' t3.
Proof with eauto.
  intros. revert dependent t1.
  induction H0; intros.
  - eexists. split... constructor.
  - eapply ireduce_step_implies_mstep_ireduce with t1 x y in H1...
    destruct H1 as [? [?]].
    apply IHmulti in H2.
    destruct H2 as [? [?]].
    eapply multi_trans in H2...
Qed.

(* Evaluation *)

Lemma reduce_mstep_implies_mstep_ireduce: forall t1 t2 t3,
    reduce t1 t2 -> mstep t2 t3 ->
    exists t2', mstep t1 t2' /\ ireduce t2' t3.
Proof with eauto.
  intros.
  apply reduce_implies_mstep_ireduce in H.
  destruct H as [? [?]].
  eapply ireduce_mstep_implies_mstep_ireduce in H1...
  destruct H1 as [? [?]].
  eapply multi_trans in H1...
Qed.

(* Lemma 9: Bifurcation *)
Lemma mreduce_implies_mstep_mireduce: forall t1 t3,
    mreduce t1 t3 ->
    exists t2, mstep t1 t2 /\ mireduce t2 t3.
Proof with eauto.
  intros. induction H...
  - eexists. split; constructor.
  - destruct IHmulti as [? [?]].
    eapply reduce_mstep_implies_mstep_ireduce with x y x0 in H...
    destruct H as [? [?]].
    eexists. split...
    econstructor...
Qed.

(* Confluence *)

Lemma diamond: forall t1 t2 t2',
    reduce t1 t2 -> reduce t1 t2' ->
    exists t3, reduce t2 t3 /\ reduce t2' t3.
Proof with eauto using reduce_val, reduce_subst.
  intros. generalize dependent t2'.
  induction H; intros...
  - inversion H0; subst...
    apply IHreduce in H2...
    destruct H2. destruct H1.
    exists (tm_abs x). split...
  - inversion H1; subst...
    + apply IHreduce1 in H4. apply IHreduce2 in H6.
      destruct H4 as [? [?]]. destruct H6 as [? [?]].
      exists (tm_app x x0). split...
    + assert (reduce (tm_abs t0) (tm_abs t1'0)) by auto.
      apply IHreduce1 in H2. destruct H2 as [? [?]].
      apply reduce_val in H7 as H7'...
      apply IHreduce2 in H7. destruct H7 as [? [?]].
      (* a lot of inversions... *)
      inversion H; subst; inversion H2; subst; inversion H3; subst;
        try solve [exists (substX 0 x0 t0); split; eauto using reduce_val, reduce_subst];
        try solve [exists (substX 0 x0 t3); split; eauto using reduce_val, reduce_subst];
        try solve [exists (substX 0 x0 t4); split; eauto using reduce_val, reduce_subst].
  - inversion H2; subst...
    + apply reduce_val in H7 as H7'...
      apply IHreduce2 in H7. destruct H7 as [? [?]].
      inversion H5; subst.
      * exists (substX 0 x t1'). split...
      * apply IHreduce1 in H7. destruct H7 as [? [?]].
        exists (substX 0 x x0). split...
    + apply IHreduce1 in H6 as H6'. destruct H6' as [? [?]].
      apply IHreduce2 in H8 as H8'. destruct H8' as [? [?]].
      exists (substX 0 x0 x). split...
Qed.

Lemma strip: forall t1 t2 t2',
    reduce t1 t2 -> mreduce t1 t2' ->
    exists t3, mreduce t2 t3 /\ reduce t2' t3.
Proof with eauto using multi_R.
  intros. revert dependent t2. induction H0; intros...
  apply diamond with x y t2 in H as H'... destruct H' as [? [?]].
  apply IHmulti in H2. destruct H2 as [? [?]].
  eapply multi_step in H2...
Qed.

Lemma confluence: forall t1 t2 t2',
    mreduce t1 t2 -> mreduce t1 t2' ->
    exists t3, mreduce t2 t3 /\ mreduce t2' t3.
Proof with eauto using multi_R.
  intros. revert dependent t2'. induction H; intros...
  apply strip with x y t2' in H as H'... destruct H' as [? [?]].
  apply IHmulti in H2. destruct H2 as [? [?]].
  eapply multi_step in H3...
Qed.

(* Termincation *)

Lemma rhalt_implies_halt : forall t1 t2,
    mreduce t1 t2 -> value t2 -> halt t1.
Proof with eauto.
  intros.
  apply mreduce_implies_mstep_mireduce in H.
  destruct H as [? [?]].
  apply mireduce_inv_val in H1...
  econstructor...
Qed.

Lemma reduce_inv_preserves_halt: forall t1 t2,
    mreduce t1 t2 -> halt t2 -> halt t1.
Proof with eauto.
  intros. destruct H0.
  apply mstep_implies_mreduce in H0.
  eapply multi_trans in H0...
  eapply rhalt_implies_halt...
Qed.

(* Theorem 10: Adequacy of Reduction *)
Lemma reduce_preserves_halt: forall t1 t2,
    reduce t1 t2 -> halt t1 -> halt t2.
Proof with eauto.
  intros. destruct H0.
  apply mstep_implies_mreduce in H0.
  eapply strip in H...
  destruct H as [? [?]].
  apply reduce_val in H2...
  eapply rhalt_implies_halt...
Qed.

(* Standardization *)

(* Definition 11 *)
Inductive treduce : tm -> tm -> Prop :=
| TRed__z : forall t, treduce t t
| TRed__s : forall t1 t2 t3,
    step t1 t2 ->
    treduce t2 t3 ->
    treduce t1 t3
| TRed__lam : forall t1 t2,
    treduce t1 t2 ->
    treduce (tm_abs t1) (tm_abs t2)
 | TRed__App : forall t1 t1' t2 t2',
    treduce t1 t1' ->
    treduce t2 t2' ->
    treduce (tm_app t1 t2) (tm_app t1' t2').

Hint Constructors treduce.

Lemma mstep_treduce_trans : forall t1 t2 t3,
    mstep t1 t2 -> treduce t2 t3 -> treduce t1 t3.
Proof with eauto.
  intros. induction H... Qed.

Lemma mstep_implies_treduce : forall t1 t2,
    mstep t1 t2 -> treduce t1 t2.
Proof with eauto.
  intros. eapply mstep_treduce_trans... Qed.

Inductive wmireduce : tm -> tm -> Prop :=
| WMIRed__ident : forall t, wmireduce t t
| WMIRed__lam : forall t1 t2,
    mreduce t1 t2 ->
    wmireduce (tm_abs t1) (tm_abs t2)
| WMIRed__App : forall t1 t1' t2 t2',
    mreduce t1 t1' ->
    mreduce t2 t2' ->
    wmireduce (tm_app t1 t2) (tm_app t1' t2').

Hint Constructors wmireduce.

Ltac kill_multi :=
  match goal with
  | [H: context[reduce ?t1 ?t2], I: context[mreduce ?t2 ?t3] |- mreduce ?t1 ?t3 ] =>
    eapply multi_trans; eauto; eapply multi_R; eauto
  end.

Lemma ireduce_wmireduce_trans : forall t1 t2 t3,
    ireduce t1 t2 -> wmireduce t2 t3 -> wmireduce t1 t3.
Proof with eauto.
  intros. generalize dependent t3.
  induction H; intros; eauto using multi_R.
  - inversion H0; subst; constructor;
      eauto using ireduce_implies_reduce, multi_R.
    kill_multi.
  - inversion H2; subst; constructor;
      eauto using ireduce_implies_reduce, multi_R;
      apply ireduce_implies_reduce in H0; kill_multi.
  - inversion H1; subst; constructor;
      eauto using ireduce_implies_reduce, multi_R;
      apply ireduce_implies_reduce in H, H0; kill_multi.
Qed.

Lemma mireduce_implies_wmireduce : forall t1 t2,
    mireduce t1 t2 -> wmireduce t1 t2.
Proof with eauto using ireduce_wmireduce_trans.
  intros. induction H... Qed.

(* Theorem 12 *)
(* Note: the original twelf method does not work here *)
(* I followed the idea from paper *)
Lemma mreduce_implies_treduce : forall t1 t2,
    mreduce t1 t2 -> treduce t1 t2.
Proof with eauto using mstep_implies_treduce.
  intros. revert dependent t1.
  induction t2; intros;
    apply mreduce_implies_mstep_mireduce in H as I;
    destruct I as [? [?]].
  - eapply mstep_treduce_trans with x...
    clear H. clear H0. clear t1.
    apply mireduce_inv_val in H1 as H1'...
    destruct H1'.
    + exfalso.
      remember (tm_abs t). remember (tm_var n).
      revert dependent t.
      induction H1; intros; subst...
      discriminate Heqt0.
      inversion H; subst...
    + remember (tm_var x). remember (tm_var n).
      revert dependent x. revert dependent n.
      induction H1; intros; subst...
      inversion H; subst...
  - apply mireduce_inv_nval in H1 as H1'... destruct H1'.
    eapply mstep_treduce_trans with (tm_app t0 t2)... clear H0.
    apply mireduce_implies_wmireduce in H1.
    remember (tm_app t2_1 t2_2). remember (tm_app t0 t2).
    induction H1; intros; subst...
    + inversion Heqt.
    + inversion Heqt; inversion Heqt3; subst.
      clear Heqt. clear Heqt3.
      constructor...
  - eapply mstep_treduce_trans with x...
    clear H. clear H0. clear t1.
    apply mireduce_inv_val in H1 as H1'...
    destruct H1'.
    + constructor...
      apply mireduce_implies_wmireduce in H1.
      remember (tm_abs t). remember (tm_abs t2).
      revert dependent t. revert dependent t2.
      induction H1; intros; subst...
      inversion Heqt0...
      inversion Heqt0. inversion Heqt1. subst...
      inversion Heqt0.
    + exfalso.
      remember (tm_abs t2). remember (tm_var x).
      revert dependent t2.
      induction H1; intros; subst...
      discriminate Heqt.
      inversion H; subst...
Qed.

Lemma wmireduce_implies_treduce : forall t1 t2,
    wmireduce t1 t2 -> treduce t1 t2.
Proof with eauto using mreduce_implies_treduce.
  intros. induction H... Qed.

Inductive ctx : Type :=
| ctxHole: ctx
| ctxLam: ctx -> ctx
| ctxApp1: tm -> ctx -> ctx
| ctxApp2: ctx -> tm -> ctx.

Fixpoint fill_context C t :=
  match C with
  | ctxHole => t
  | ctxLam C' => tm_abs (fill_context C' t)
  | ctxApp1 t1 C' => tm_app t1 (fill_context C' t)
  | ctxApp2 C' t2 => tm_app (fill_context C' t) t2
  end.

Lemma mreduce_app2: forall t1 t2 t2',
    mreduce t2 t2' -> mreduce (tm_app t1 t2) (tm_app t1 t2').
Proof with eauto.
  intros. induction H...
  - apply multi_R. econstructor.
  - eapply multi_trans. apply multi_R.
    apply Red_App1... assumption.
Qed.

Lemma mreduce_app1: forall t1 t1' t2,
    mreduce t1 t1' -> mreduce (tm_app t1 t2) (tm_app t1' t2).
Proof with eauto.
  intros. induction H...
  - apply multi_R. econstructor.
  - eapply multi_trans. apply multi_R.
    apply Red_App1... assumption.
Qed.

Lemma mreduce_abs: forall t1 t1',
    mreduce t1 t1' -> mreduce (tm_abs t1) (tm_abs t1').
Proof with eauto.
  intros. induction H...
  - apply multi_R. econstructor.
  - eapply multi_trans. apply multi_R.
    apply Red_Body... assumption.
Qed.

Lemma context_mreduce: forall C t1 t2,
    mreduce t1 t2 -> mreduce (fill_context C t1) (fill_context C t2).
Proof with eauto.
  induction C; intros; simpl in *;
    eauto using mreduce_abs, mreduce_app2, mreduce_app1.
Qed.

Lemma contextual_equivalence: forall C t1 t2,
    mstep t1 t2 -> halt (fill_context C t1) <-> halt (fill_context C t2).
Proof with eauto using
           value_halt, mreduce_preserves_halt, mreduce_inv_preserves_halt.
  induction C; split; simpl in *;
    apply mstep_implies_mreduce in H as H';
    intros...
  - inversion H0; subst.
    eapply mreduce_preserves_halt...
    apply mreduce_app2.
    apply context_mreduce...
  - inversion H0; subst.
    eapply mreduce_inv_preserves_halt...
    apply mreduce_app2.
    apply context_mreduce...
  - inversion H0; subst.
    eapply mreduce_preserves_halt...
    apply mreduce_app1.
    apply context_mreduce...
  - inversion H0; subst.
    eapply mreduce_inv_preserves_halt...
    apply mreduce_app1.
    apply context_mreduce...
Qed.