Add LoadPath "..".
Add LoadPath "../LabelFree/NoDiamond".
Require Import LabelFreeNoDia.

Open Scope is5_scope.
Open Scope permut_scope.

Inductive WHT: te_LF -> Type :=
| val_WHT: forall M, value_LF M -> WHT M
| step_WHT: forall M,
              sigT (fun V => prod (value_LF V) (steps_LF M V)) -> WHT M.

Fixpoint Red (M: te_LF) (A: ty) : Type :=
match A with
| tvar => WHT M
| tarrow A1 A2 =>
    prod (WHT M)
    (forall N,
       lc_t_LF N ->
       Red N A1 ->
      Red (appl_LF M N) A2)
| tbox A1 => prod (WHT M) (Red (unbox_LF M) A1)
end.

Lemma step_LF_unique:
forall M N N',
  M |-> N -> M |->N' -> N = N'.
intros; generalize dependent N'; induction H; intros; inversion H0; subst;
auto. inversion H5. inversion H2. inversion H.
rewrite IHstep_LF with M'0; auto.
inversion H. rewrite IHstep_LF with M'0; auto.
Qed.

Lemma WHT_step:
forall M M',
  WHT M ->
  M |-> M' ->
  WHT M'.
intros; inversion H; subst.
apply value_no_step with (N:=M') in H1; auto; contradiction.
destruct H1 as (V, (H1, H2)).
inversion H2; subst.
apply step_LF_unique with (N':=V) in H0; subst; auto. constructor; auto.
apply step_WHT; exists V; split; auto.
apply step_LF_unique with (N':=M'0) in H0; subst; auto.
Qed.

Lemma WHT_step_back:
forall M M',
  M |-> M' ->
WHT M' -> WHT M.
intros; apply step_WHT.
inversion H0; subst.
exists M'; split; auto; constructor; auto.
destruct H1; destruct p.
exists x; split; auto; apply multi_step_LF with (M':=M'); auto.
Qed.

Hint Resolve WHT_step WHT_step_back.

(* CR 2 *)
Theorem property_2:
forall A M M'
  (HRed: Red M A)
  (H_lc_t: lc_t_LF M)
  (HStep: M |-> M'),
  Red M' A.
induction A; intros; simpl in *; intros.
(* base type *)
eauto.
(* arrow type *)
destruct HRed; split; eauto; intros.
apply IHA2 with (M:=appl_LF M N); auto.
constructor; auto.
constructor; auto.
(* box type *)
destruct HRed; split; eauto; intros.
apply IHA with (M:=unbox_LF M); auto; constructor; eauto.
Qed.

(* CR 1 *)
Theorem property_1:
forall A M
  (H_lc_t: lc_t_LF M),
  Red M A -> WHT M.
induction A; intros; simpl in *; auto;
destruct X; auto.
Qed.

(* CR 3 *)
Theorem property_3:
forall A M M'
  (H_lc: lc_t_LF M),
  M |-> M' ->   Red M' A ->
  Red M A.
induction A; intros; simpl in *.
(* base type *)
eauto.
(* arrow type *)
destruct X; split; eauto; intros.
apply IHA2 with (appl_LF M' N); try constructor; auto; intros; simpl in *.
(* box type *)
destruct X; split; eauto; intros.
intros; apply IHA with (unbox_LF M'); try constructor; auto.
Qed.

Fixpoint find_var (L: list (var * ty * te_LF)) (x:var) :
                     option (var * ty * te_LF) :=
match L with
| nil => None
| (v, A, M) :: L' =>
  if (eq_var_dec x v) then Some (v, A, M) else find_var L' x
end.

Lemma Mem_find_var:
  forall L v,
    Mem v (map fst_ (map fst_ L)) ->
    exists A M, find_var L v = Some (v, A, M).
induction L; intros; [ rewrite Mem_nil_eq in *; contradiction | ];
destruct a; destruct p; rew_map in *; simpl in *.
subst; rewrite Mem_cons_eq in H.
destruct (eq_var_dec v v0).
subst; simpl; exists t0 t; auto.
destruct H; try contradiction; apply IHL; auto.
Qed.

Lemma NotMem_find_var:
  forall L v,
    ~Mem v (map fst_ (map fst_ L)) ->
    find_var L v = None.
induction L; intros; simpl in *; auto;
destruct a; destruct p; rew_map in *; simpl in *;
case_if.
elim H; apply Mem_here.
apply IHL; intro; elim H;
rewrite Mem_cons_eq; right; auto.
Qed.

Lemma find_var_Mem:
forall L v A M,
  find_var L v = Some (v, A, M) -> Mem (v, A, M) L.
induction L; intros; [inversion H; subst | ].
destruct a; destruct p; simpl in *; case_if.
inversion H; subst; apply Mem_here.
rewrite Mem_cons_eq; right; apply IHL; auto.
Qed.

Fixpoint OkL (L: list (var * ty * te_LF)) U :=
match L with
| nil => True
| (v, A, M) :: L' => ~ Mem v U /\ OkL L' (v::U)
end.

Lemma OkL_permut:
forall L U1 U2,
  U1 *=* U2 ->
  OkL L U1 -> OkL L U2.
induction L; intros; [constructor | destruct a; destruct p];
inversion H0; subst; constructor.
intro; elim H1; apply Mem_permut with (l:=U2); [symmetry | ]; auto.
apply IHL with (U1:=v::U1); auto.
Qed.

Lemma OkL_weaken:
forall L U w,
  OkL L (w::U) -> OkL L U.
induction L; intros; simpl in *; auto; destruct a; destruct p; destruct H;
split.
intro; elim H; rewrite Mem_cons_eq; right; auto.
apply IHL with w. apply OkL_permut with (U1:=v::w::U); auto; permut_simpl.
Qed.

Lemma OkL_used_notin:
forall L U x A M,
  OkL L U ->
  Mem x U ->
  ~ Mem (x, A, M) L.
induction L; intros.
rewrite Mem_nil_eq; tauto.
intro; destruct a; destruct p; rewrite Mem_cons_eq in *; inversion H; subst;
destruct H1.
inversion H1; subst; contradiction.
specialize IHL with U x A M.
apply OkL_weaken in H3; apply IHL in H3; auto.
Qed.

Lemma OkL_fresh:
forall L x U,
  OkL L U->
  x \notin from_list (map fst_ (map fst_ L)) \u from_list U ->
  OkL L (x::U).
induction L; intros; [constructor | destruct a; destruct p];
simpl in *; destruct H; split.
intro; elim H; rewrite Mem_cons_eq in *; destruct H2; subst; auto;
repeat rewrite notin_union in *; destruct H0; destruct H0;
rew_map; simpl; rewrite from_list_cons; rewrite in_union; left;
rewrite in_singleton; auto.
apply OkL_permut with (U1:=x::v::U); [permut_simpl | apply IHL]; auto.
rew_map in *; simpl in *;
repeat rewrite from_list_cons in *; repeat rewrite notin_union in *;
simpl in *; destruct H0; destruct H0; split; auto.
Qed.

Lemma Mem_find_var_type:
  forall L v A,
    OkL L nil ->
    Mem (v, A) (map fst_ L) ->
    {M | find_var L v = Some (v, A, M)}.
induction L; intros; [ rewrite Mem_nil_eq in *; contradiction | ];
destruct a; destruct p; rew_map in *; simpl in *; destruct H.
subst; apply Mem_cons_spec in H0.
case_if.
destruct H0.
inversion e; subst; exists t; auto.
destruct IHL with v0 A; auto.
apply OkL_weaken in H1; auto.
apply find_var_Mem in e.
apply OkL_used_notin with (x:=v0) (A:=A) (M:=x) in H1; [ | apply Mem_here];
contradiction.
destruct H0; [inversion e; subst; elim H2; auto | ].
apply IHL; auto; apply OkL_weaken in H1; auto.
intros; decide equality. apply eq_ty_dec. apply eq_var_dec.
Qed.

Fixpoint SL (L: list (var * ty * te_LF)) (M: te_LF) : te_LF :=
match M with
| hyp_LF (bte v) => M
| hyp_LF (fte v) =>
  let x := find_var L v in
  match x with
    | Some (v, A, M) => M
    | None => hyp_LF (fte v)
  end
| lam_LF A M => lam_LF A (SL L M)
| appl_LF M N => appl_LF (SL L M) (SL L N)
| box_LF M => box_LF (SL L M)
| unbox_LF M => unbox_LF (SL L M)
end.

Lemma SL_nil:
forall M,
  SL nil M = M.
induction M; intros; simpl in *;
try erewrite IHM || (erewrite IHM1; erewrite IHM2); eauto.
destruct v; auto.
Qed.

Lemma lc_SL:
forall M L n,
  lc_t_n_LF n M ->
  (forall a b c, Mem (a,b,c) L -> lc_t_LF c) ->
  lc_t_n_LF n (SL L M).
induction M; intros; simpl in *;
try (inversion H; subst; constructor; eapply IHM; eauto).
destruct v; inversion H; subst.
constructor; auto.
destruct (Mem_dec var (map fst_ (map fst_ L)) v). apply eq_var_dec.
apply Mem_find_var in m; destruct m; destruct H1.
rewrite H1. replace n with (0+n) by omega.
apply closed_t_addition_LF; apply H0 with v x. apply find_var_Mem; auto.
rewrite NotMem_find_var; auto.
inversion H; subst; constructor; [apply IHM1 | apply IHM2]; auto.
Qed.

Fixpoint FV_L (L: list (var * ty * te_LF)) :=
match L with
| nil => \{}
| (v, A, M) :: L' => used_vars_te_LF M \u FV_L L'
end.

Lemma notin_FV_notin_elem:
forall x L,
  x \notin FV_L L ->
  forall a b c, Mem (a,b,c) L -> x \notin used_vars_te_LF c.
induction L; intros; simpl in *.
rewrite Mem_nil_eq in *; contradiction.
rewrite Mem_cons_eq in H0; destruct H0; [inversion H0; subst | ].
rewrite notin_union in H; destruct H; auto.
destruct a; destruct p; rewrite notin_union in H; destruct H;
apply IHL with (a:=a0) (b:=b); auto.
Qed.

Lemma SL_hyp:
forall L G Gamma v A,
  OkL L nil ->
  concat (Gamma::G) *=* map fst_ L ->
  (forall a b c, Mem (a, b, c) L -> Red c b) ->
  G |= Gamma |- hyp_LF (fte v) ::: A ->
  Red (SL L (hyp_LF (fte v))) A.
intros.
inversion X0; subst.
assert (Mem (v, A) (map fst_ L)).
  apply Mem_permut with (l:=concat (Gamma::G)); auto.
  rew_concat; rewrite Mem_app_or_eq; left; auto.
apply Mem_find_var_type in H1; auto. destruct H1.
simpl; rewrite e; apply X with v.
apply find_var_Mem; auto.
Qed.

Lemma SL_bte_subst:
forall L0 M x k,
  ~ Mem x (map fst_ (map fst_ L0)) ->
  (forall v a m, Mem (v, a, m) L0 -> lc_t_LF m) ->
  [hyp_LF (fte x) // bte k](SL L0 M) =
  SL L0 [hyp_LF (fte x) // bte k]M.
induction M; intros; simpl in *;
try rewrite IHM || (rewrite IHM1; try rewrite IHM2); auto.
case_if; simpl.
case_if. rewrite NotMem_find_var; auto.
destruct v; simpl; repeat case_if; auto.
destruct (Mem_dec var (map fst_ (map fst_ L0)) v);
try apply eq_var_dec; [ | rewrite NotMem_find_var]; auto;
simpl; repeat case_if; auto.
apply Mem_find_var in m; destruct m as (a, (b, m)); rewrite m; simpl.
rewrite closed_subst_t_bound_LF with (n:=0); auto; try omega;
apply H0 with v a; apply find_var_Mem; auto.
Qed.

Lemma SL_extend:
forall M L0 x A N,
  x \notin FV_L L0 ->
  ~Mem x (map fst_ (map fst_ L0)) ->
  SL ((x, A, N) :: L0) M =
  [N // fte x](SL L0 M).
induction M; intros; simpl in *;
try rewrite IHM || (rewrite IHM1; try rewrite IHM2); auto.
destruct v; simpl; repeat case_if; auto.
rewrite NotMem_find_var; auto; simpl; case_if; auto.
destruct (Mem_dec var (map fst_ (map fst_ L0)) v);
try apply eq_var_dec; [ | rewrite NotMem_find_var]; auto;
simpl; repeat case_if; auto.
apply Mem_find_var in m; destruct m as (a, (b, m)); rewrite m; simpl.
rewrite closed_subst_t_free_LF; auto.
apply notin_FV_notin_elem with L0 v a; eauto.
apply find_var_Mem; eauto.
Qed.

Theorem main_theorem:
forall G Gamma M A,
  lc_t_LF M ->
  G |= Gamma |- M ::: A ->
  forall L,
    OkL L nil ->
    concat(Gamma::G) *=* map fst_ L ->
    (forall a b c, Mem (a,b,c) L -> lc_t_LF c) ->
    (forall a b c, Mem (a,b,c) L -> Red c b) ->
    Red (SL L M) A.
intros G Gamma M A LC HT; induction HT; intros.
(* hyp *)
apply SL_hyp with G Gamma; auto; constructor; auto.
(* lam *)
unfold open_LF in *;
assert {x | x \notin L \u used_vars_te_LF (SL L0 M) \u
       from_list (map fst_ (map fst_ L0)) \u FV_L L0} by apply Fresh.
destruct H3.
assert (forall V, Red V A -> lc_t_LF V ->
           Red (SL ((x, A, V) :: L0) [hyp_LF (fte x) // bte 0]M) B).
intros; apply X; auto.
apply lc_t_subst_t_LF_bound; [ constructor | inversion LC]; auto.
constructor. rewrite Mem_nil_eq; tauto.
apply OkL_fresh; auto; rewrite notin_union; split; auto;
rewrite from_list_nil; auto.
rew_map in *; simpl; rewrite <-  H1; rew_concat; auto.
intros; rewrite Mem_cons_eq in *; destruct H4.
inversion H4; subst; auto.
apply H2 with a b; auto.
intros; apply Mem_cons_spec in H4. destruct H4.
inversion e; subst; auto.
apply X0 with a ; auto.
intros; destruct k; destruct p; destruct k'; destruct p; decide equality.
apply eq_te_LF_dec. destruct p; destruct a0; decide equality.
apply eq_ty_dec. apply eq_var_dec.
simpl in *; split; intros. repeat constructor.
apply property_3 with (M':=(SL L0 M) ^t^ N).
constructor; auto; constructor; apply lc_SL; auto; inversion LC; auto.
constructor.
apply lc_SL; auto; inversion LC; auto. auto.
unfold open_LF in *.
rewrite subst_t_neutral_free_LF with (v:=x); auto.
replace ([N // fte x]([hyp_LF (fte x) // bte 0](SL L0 M))) with
  (SL ((x, A, N)::L0) [hyp_LF (fte x) // bte 0]M).
apply X1; auto.
rewrite SL_bte_subst; auto; [ | apply notin_Mem; auto].
rewrite SL_extend; auto; apply notin_Mem; auto.
(* appl *)
simpl in *; apply IHHT1; auto. inversion LC; auto.
apply lc_SL; inversion LC; auto.
apply IHHT2; auto; inversion LC; subst; auto.
(* box *)
simpl in *; split. repeat constructor.
apply property_3 with (SL L M).
constructor; constructor; apply lc_SL; inversion LC; auto.
constructor.
inversion LC; subst; apply lc_SL; auto.
apply IHHT; auto; rew_concat in *. inversion LC; auto.
rewrite <- H0; permut_simpl.
(* unbox *)
simpl in *; apply IHHT; auto.
inversion LC; auto.
(* unbox-fetch *)
simpl in *;apply IHHT; auto.
inversion LC; auto.
rewrite <- H0; apply PPermut_concat_permut.
transitivityP (Gamma' :: G & Gamma); PPermut_LF_simpl.
Qed.

Theorem termination_language:
forall G M A,
  emptyEquiv_LF G |= nil |- M ::: A ->
  WHT M.
intros; apply property_1 with A.
apply types_LF_lc_t_LF in X; auto.
apply main_theorem with (L:=nil) in X.
rewrite SL_nil in X; auto.
apply types_LF_lc_t_LF in X; auto.
simpl; auto.
rew_concat; rew_map; clear X M A.
induction G; simpl; rew_concat; auto.
intros; rewrite Mem_nil_eq in *; contradiction.
intros; rewrite Mem_nil_eq in *; contradiction.
Qed.

(*
Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inductive sumbool => "bool" [ "true" "false" ].

Extract Inductive nat => "int"
  [ "0" "(fun x → x + 1)" ]
  "(fun zero succ n →
      if n=0 then zero () else succ (n-1))".
Extract Constant plus => "( + )".

Extract Constant eq_var_dec => "( = )".

Extraction "termination_LF_nodia" termination_language.
*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**
   lemmas.
   Some nice lemmas, mostly about le, lt, and mult.

   @author Olga Caprotti and Martijn Oostdijk
   @version $Revision$
*)

Global Set Asymmetric Patterns.

Require Import ZArith.
Require Import EqNat.

Lemma predminus1 : forall n : nat, pred n = n - 1.
Proof.
   intro n. case n.
   simpl in |- *. reflexivity.
   simpl in |- *. intro m. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma le_mult_l : forall p q : nat, p <= q -> forall r : nat, r * p <= r * q.
Proof.
   intros p q H.
   simple induction r.
   simpl in |- *.
   apply le_n.
   intros r1 IHr1.
   simpl in |- *.
   apply plus_le_compat.
   assumption.
   assumption.
Qed.

Lemma lt_plus_plus : forall n m p q : nat, n < m -> p < q -> n + p < m + q.
Proof.
   intros n m p q H H0.
   elim H; simpl in |- *; auto with arith.
Qed.

Lemma lt_mult_l :
 forall p q : nat, p < q -> forall r : nat, S r * p < S r * q.
Proof.
   intros p q H.
   simple induction r.
   simpl in |- *.
   rewrite <- plus_n_O.
   rewrite <- plus_n_O.
   assumption.
   intros r1 IHr1.
   simpl in |- *.
   apply lt_plus_plus.
   assumption.
   assumption.
Qed.

Lemma le_mult_r : forall p q : nat, p <= q -> forall r : nat, p * r <= q * r.
Proof.
   intros p q H.
   simple induction r.
   simpl in |- *.
   rewrite <- (mult_n_O p).
   rewrite <- (mult_n_O q).
   apply le_n.
   intros r1 IHr1.
   rewrite <- (mult_n_Sm p r1).
   rewrite <- (mult_n_Sm q r1).
   apply plus_le_compat.
   assumption.
   assumption.
Qed.

Lemma sqrbound : forall p q : nat, p * p <= p * q \/ q * q <= p * q.
Proof.
   intros.
   elim (le_or_lt p q).
   left.
   apply le_mult_l.
   assumption.
   right.
   apply le_mult_r.
   apply lt_le_weak.
   assumption.
Qed.

Lemma le_n_nm : forall n m : nat, n <= n * S m.
Proof.
   simple induction n.
   simpl in |- *.
   intros.
   apply le_n.
   intros n1 IHn1.
   simpl in |- *.
   intros.
   apply le_n_S.
   rewrite (plus_comm m (n1 * S m)).
   apply le_plus_trans.
   apply IHn1.
Qed.

Lemma le_n_mn : forall n m : nat, n <= S m * n.
Proof.
   intros.
   rewrite (mult_comm (S m) n).
   apply le_n_nm.
Qed.

Lemma le_n_nn : forall n : nat, n <= n * n.
Proof.
   intro n. case n.
   simpl in |- *. apply le_n.
   simpl in |- *. intros. apply le_n_S. apply le_plus_trans. apply le_n.
Qed.

Lemma lt_n_nm : forall n m : nat, 0 < n -> 1 < m -> n < n * m.
Proof.
   intros n m.
   case n. intros. elim (lt_n_O 0). assumption.
   intro n1. case m. intros. elim (lt_n_O 1). assumption.
   intro m1. case m1. intros. elim (lt_irrefl 1). assumption.
   intro m2. elim n1.
   simpl in |- *. intros. apply lt_n_S. apply lt_O_Sn.
   simpl in |- *. intros n2 IH. intros.
   apply lt_n_S.
   apply lt_trans with (S (S (m2 + n2 * S (S m2)))).
   apply IH.
   apply lt_O_Sn.
   apply lt_n_S.
   apply lt_O_Sn.
   apply lt_n_S.
   rewrite (plus_comm m2).
   rewrite (plus_comm m2).
   simpl in |- *.
   apply lt_n_S.
   apply lt_le_trans with (S (n2 * S (S m2) + m2)).
   apply lt_n_Sn.
   apply le_n_S.
   apply le_plus_trans.
   apply le_n.
Qed.

Lemma sqr_ascend : forall n : nat, n > 1 -> n < n * n.
Proof.
   simple induction n.
   intros.
   elim (lt_n_O 1).
   assumption.
   intros m IHm.
   intro.
   unfold gt in H.
   unfold lt in H.
   elim (le_lt_or_eq 1 m).
   intros.
   simpl in |- *.
   apply lt_n_S.
   rewrite <- (mult_n_Sm m m).
   rewrite plus_comm.
   apply lt_plus_trans.
   apply lt_plus_trans.
   apply IHm.
   assumption.
   intros.
   rewrite <- H0.
   simpl in |- *.
   unfold lt in |- *.
   apply le_S.
   apply le_n.
   apply le_S_n.
   assumption.
Qed.

Lemma witness_le : forall x y : nat, (exists q : nat, x + q = y) -> x <= y.
Proof.
   intros. elim H. intro q. intros.
   rewrite <- H0.
   elim q.
   rewrite <- plus_n_O. apply le_n.
   intros. rewrite <- plus_n_Sm. apply le_S. assumption.
Qed.

Lemma le_witness : forall x y : nat, x <= y -> exists q : nat, x + q = y.
Proof.
   intros x y.
   intro.
   elim H.
   split with 0.
   simpl in |- *.
   symmetry  in |- *.
   apply plus_n_O.
   intros.
   case H1.
   intros.
   split with (S x0).
   replace (x + S x0) with (S (x + x0)).
   simpl in |- *.
   rewrite H2.
   reflexivity.
   apply plus_n_Sm.
Qed.

Lemma lt_witness :
 forall x y : nat, x < y -> exists q : nat, x + q = y /\ 0 < q.
Proof.
   unfold lt in |- *.
   intros.
   elim (le_witness (S x) y).
   intros.
   split with (S x0).
   split.
   rewrite <- plus_n_Sm.
   assumption.
   apply le_n_S.
   apply le_O_n.
   assumption.
Qed.

Lemma le_le_mult : forall b a c d : nat, a <= b -> c <= d -> a * c <= b * d.
Proof.
   simple induction b.
   intros.
   replace a with 0.
   simpl in |- *.
   apply le_n.
   apply le_n_O_eq.
   assumption.
   intros b1 IHb1.
   simpl in |- *.
   intros.
   elim (le_lt_or_eq a (S b1)).
   unfold lt in |- *.
   intros.
   rewrite (plus_comm d (b1 * d)).
   apply le_plus_trans.
   apply IHb1.
   apply le_S_n.
   assumption.
   assumption.
   intro.
   rewrite H1.
   replace (d + b1 * d) with (S b1 * d).
   apply le_mult_l.
   assumption.
   reflexivity.
   assumption.
Qed.

Lemma lt_lt_mult : forall a b c d : nat, a < b -> c < d -> a * c < b * d.
Proof.
   unfold lt in |- *.
   intros.
   apply le_trans with (S a * S c).
   simpl in |- *.
   apply le_n_S.
   rewrite <- (mult_n_Sm a c).
   rewrite (plus_comm c (a * c + a)).
   apply le_plus_trans.
   apply le_plus_trans.
   apply le_n.
   apply le_le_mult.
   assumption.
   assumption.
Qed.

Lemma lt_n_nm_m_gt_1 : forall a b : nat, a < a * b -> b > 1.
Proof.
   intros a b. case b.
   rewrite <- (mult_n_O a). intro. elim (lt_n_O a). assumption.
   intro b1. case b1.
   rewrite <- (mult_n_Sm a 0).
   rewrite <- (mult_n_O a). simpl in |- *. intro.
   elim (lt_irrefl a). assumption.
   intros. apply gt_n_S. apply gt_Sn_O.
Qed.

Lemma n0n1_or_gt : forall n : nat, n = 0 \/ n = 1 \/ n > 1.
Proof.
   intro n. case n.
   left. reflexivity.
   intro n1. case n1.
   right. left. reflexivity.
   intro n2.
   right. right. apply gt_n_S. apply gt_Sn_O.
Qed.

Lemma lt_multpred_pp : forall p : nat, p > 1 -> pred p * pred p < p * p.
Proof.
   intro.
   case p.
   intro.
   elim (lt_n_O 1).
   assumption.
   intro p1.
   case p1.
   intro.
   elim (lt_irrefl 1).
   assumption.
   intro p2.
   intros.
   apply lt_lt_mult.
   simpl in |- *. apply lt_n_Sn.
   simpl in |- *. apply lt_n_Sn.
Qed.

Lemma le_diff0 : forall b a c : nat, a <= b -> a = b + c -> c = 0.
Proof.
   simple induction b.
   simpl in |- *. intro.
   case a.
   intros.
   rewrite H0.
   reflexivity.
   intros.
   elim (lt_n_O n).
   assumption.
   intros b1 IH.
   simpl in |- *.
   intros.
   rewrite H0 in H.
   apply (IH (b1 + c) c).
   apply le_S_n.
   assumption.
   reflexivity.
Qed.

Lemma simpl_lt_mult_l : forall a b c : nat, a * b < a * c -> b < c.
Proof.
   simple induction a.
   simpl in |- *.
   intros.
   elim (lt_irrefl 0).
   assumption.
   intros a1 IH.
   intros.
   elim (le_or_lt b c).
   intro.
   elim (le_lt_or_eq b c).
   intro.
   assumption.
   intros.
   rewrite H1 in H.
   elim (lt_irrefl (S a1 * c)).
   assumption.
   assumption.
   intros.
   cut (S a1 * c <= S a1 * b).
   intros.
   elim (le_not_lt (S a1 * c) (S a1 * b)).
   assumption.
   assumption.
   apply lt_le_weak.
   apply lt_mult_l.
   assumption.
Qed.

Lemma simpl_le_mult_l : forall a b c : nat, 0 < a -> a * b <= a * c -> b <= c.
Proof.
   simple induction a.
   intros.
   elim (lt_n_O 0).
   assumption.
   intros a1 IH.
   intros.
   simpl in H0.
   elim (le_or_lt b c).
   intro.
   assumption.
   intro.
   elim (lt_not_le (S a1 * c) (S a1 * b)).
   apply lt_mult_l.
   assumption.
   assumption.
Qed.

Lemma simpl_eq_mult_l : forall a b c : nat, 0 < a -> a * b = a * c -> b = c.
Proof.
   intros. apply le_antisym.
   apply simpl_le_mult_l with a. assumption. rewrite H0. apply le_n.
   apply simpl_le_mult_l with a. assumption. rewrite H0. apply le_n.
Qed.

Lemma mult_ppq_p0q1 : forall p q : nat, p = p * q -> p = 0 \/ q = 1.
Proof.
   intro p. case p. left. reflexivity.
   intro p1. right.
   apply simpl_eq_mult_l with (S p1). apply lt_O_Sn.
   rewrite <- H.
   rewrite <- mult_n_Sm. rewrite <- mult_n_O.
   simpl in |- *. reflexivity.
Qed.

Lemma mult_pq1_p1q1 : forall p q : nat, p * q = 1 -> p = 1 /\ q = 1.
Proof.
   intro p. case p. simpl in |- *. intros. discriminate H.
   intro p1. case p1. simpl in |- *.
   intro q. rewrite <- plus_n_O. split. reflexivity. assumption.
   intro p2.
   intro q. case q. rewrite <- mult_n_O. intro. discriminate H.
   intro q1. case q1.
   rewrite <- mult_n_Sm.
   rewrite <- mult_n_O.
   simpl in |- *. intro. discriminate H.
   intro q2. simpl in |- *. intro. discriminate H.
Qed.

Lemma Zmult_ab0a0b0 : forall a b : Z, (a * b)%Z = 0%Z -> a = 0%Z \/ b = 0%Z.
Proof.
   simple induction a.
   simpl in |- *. left. reflexivity.
   intro p. simple induction b.
   simpl in |- *. right. reflexivity.
   simpl in |- *. intros. discriminate H.
   simpl in |- *. intros. discriminate H.
   intro. simple induction b.
   simpl in |- *. right. reflexivity.
   simpl in |- *. intros. discriminate H.
   simpl in |- *. intros. discriminate H.
Qed.

Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z.
Proof.
   intros a b. intros.
   apply Zplus_le_reg_l with b.
   unfold Zminus in |- *. rewrite (Zplus_comm a).
   rewrite (Zplus_assoc b (- b)). rewrite Zplus_opp_r.
   simpl in |- *. rewrite <- Zplus_0_r_reverse. assumption.
Qed.

Lemma Zopp_lt_gt_0 : forall x : Z, (x < 0)%Z -> (- x > 0)%Z.
Proof.
   simple induction x.
   intro. unfold Z.lt in H. simpl in H. discriminate H.
   intros. unfold Z.lt in H. simpl in H. discriminate H.
   intros. simpl in |- *. unfold Z.gt in |- *. simpl in |- *. reflexivity.
Qed.

Lemma Zlt_neq : forall x y : Z, (x < y)%Z -> x <> y.
Proof.
   intros. intro.
   rewrite H0 in H.
   elim (Z.lt_irrefl y).
   assumption.
Qed.

Lemma Zgt_neq : forall x y : Z, (x > y)%Z -> x <> y.
Proof.
   intros. intro.
   rewrite H0 in H.
   elim (Z.lt_irrefl y).
   apply Z.gt_lt. assumption.
Qed.

Lemma S_inj : forall n m : nat, S n = S m -> n = m.
  intros n m H; injection H; trivial.
Qed.

Lemma Zlt_mult_l :
 forall p q r : Z, (0 < r)%Z -> (p < q)%Z -> (r * p < r * q)%Z.
Proof.
   simple induction r.
   intros. elim (Z.lt_irrefl 0). assumption.
   intros. unfold Z.lt in |- *.
   rewrite (Zcompare_mult_compat p0 p q).
   assumption.
   intros. unfold Z.lt in H. simpl in H. discriminate H.
Qed.

Lemma Zle_mult_l :
 forall p q r : Z, (0 < r)%Z -> (p <= q)%Z -> (r * p <= r * q)%Z.
Proof.
   simple induction r.
   intros. simpl in |- *. apply Zeq_le. reflexivity.
   intros. unfold Z.le in |- *.
   rewrite (Zcompare_mult_compat p0 p q).
   assumption.
   intros. unfold Z.lt in H. simpl in H. discriminate H.
Qed.


From iris_logrel.F_mu_ref Require Export fundamental_binary.

Inductive ctx_item :=
  | CTX_Lam
  | CTX_AppL (e2 : expr)
  | CTX_AppR (e1 : expr)
  (* Products *)
  | CTX_PairL (e2 : expr)
  | CTX_PairR (e1 : expr)
  | CTX_Fst
  | CTX_Snd
  (* Sums *)
  | CTX_InjL
  | CTX_InjR
  | CTX_CaseL (e1 : expr) (e2 : expr)
  | CTX_CaseM (e0 : expr) (e2 : expr)
  | CTX_CaseR (e0 : expr) (e1 : expr)
  (* Recursive Types *)
  | CTX_Fold
  | CTX_Unfold
  (* Polymorphic Types *)
  | CTX_TLam
  | CTX_TApp
  (* Reference Types *)
  | CTX_Alloc
  | CTX_Load
  | CTX_StoreL (e2 : expr)
  | CTX_StoreR (e1 : expr).

Fixpoint fill_ctx_item (ctx : ctx_item) (e : expr) : expr :=
  match ctx with
  | CTX_Lam => Lam e
  | CTX_AppL e2 => App e e2
  | CTX_AppR e1 => App e1 e
  | CTX_PairL e2 => Pair e e2
  | CTX_PairR e1 => Pair e1 e
  | CTX_Fst => Fst e
  | CTX_Snd => Snd e
  | CTX_InjL => InjL e
  | CTX_InjR => InjR e
  | CTX_CaseL e1 e2 => Case e e1 e2
  | CTX_CaseM e0 e2 => Case e0 e e2
  | CTX_CaseR e0 e1 => Case e0 e1 e
  | CTX_Fold => Fold e
  | CTX_Unfold => Unfold e
  | CTX_TLam => TLam e
  | CTX_TApp => TApp e
  | CTX_Alloc => Alloc e
  | CTX_Load => Load e
  | CTX_StoreL e2 => Store e e2
  | CTX_StoreR e1 => Store e1 e
  end.

Definition ctx := list ctx_item.

Definition fill_ctx (K : ctx) (e : expr) : expr := foldr fill_ctx_item e K.

(** typed ctx *)
Inductive typed_ctx_item :
    ctx_item → list type → type → list type → type → Prop :=
  | TP_CTX_Lam Γ τ τ' :
     typed_ctx_item CTX_Lam (τ :: Γ) τ' Γ (TArrow τ τ')
  | TP_CTX_AppL Γ e2 τ τ' :
     typed Γ e2 τ →
     typed_ctx_item (CTX_AppL e2) Γ (TArrow τ τ') Γ τ'
  | TP_CTX_AppR Γ e1 τ τ' :
     typed Γ e1 (TArrow τ τ') →
     typed_ctx_item (CTX_AppR e1) Γ τ Γ τ'
  | TP_CTX_PairL Γ e2 τ τ' :
     typed Γ e2 τ' →
     typed_ctx_item (CTX_PairL e2) Γ τ Γ (TProd τ τ')
  | TP_CTX_PairR Γ e1 τ τ' :
     typed Γ e1 τ →
     typed_ctx_item (CTX_PairR e1) Γ τ' Γ (TProd τ τ')
  | TP_CTX_Fst Γ τ τ' :
     typed_ctx_item CTX_Fst Γ (TProd τ τ') Γ τ
  | TP_CTX_Snd Γ τ τ' :
     typed_ctx_item CTX_Snd Γ (TProd τ τ') Γ τ'
  | TP_CTX_InjL Γ τ τ' :
     typed_ctx_item CTX_InjL Γ τ Γ (TSum τ τ')
  | TP_CTX_InjR Γ τ τ' :
     typed_ctx_item CTX_InjR Γ τ' Γ (TSum τ τ')
  | TP_CTX_CaseL Γ e1 e2 τ1 τ2 τ' :
     typed (τ1 :: Γ) e1 τ' → typed (τ2 :: Γ) e2 τ' →
     typed_ctx_item (CTX_CaseL e1 e2) Γ (TSum τ1 τ2) Γ τ'
  | TP_CTX_CaseM Γ e0 e2 τ1 τ2 τ' :
     typed Γ e0 (TSum τ1 τ2) → typed (τ2 :: Γ) e2 τ' →
     typed_ctx_item (CTX_CaseM e0 e2) (τ1 :: Γ) τ' Γ τ'
  | TP_CTX_CaseR Γ e0 e1 τ1 τ2 τ' :
     typed Γ e0 (TSum τ1 τ2) → typed (τ1 :: Γ) e1 τ' →
     typed_ctx_item (CTX_CaseR e0 e1) (τ2 :: Γ) τ' Γ τ'
  | TP_CTX_Fold Γ τ :
     typed_ctx_item CTX_Fold Γ τ.[(TRec τ)/] Γ (TRec τ)
  | TP_CTX_Unfold Γ τ :
     typed_ctx_item CTX_Unfold Γ (TRec τ) Γ τ.[(TRec τ)/]
  | TP_CTX_TLam Γ τ :
     typed_ctx_item CTX_TLam (subst (ren (+1)) <$> Γ) τ Γ (TForall τ)
  | TP_CTX_TApp Γ τ τ' :
     typed_ctx_item CTX_TApp Γ (TForall τ) Γ τ.[τ'/]
  | TPCTX_Alloc Γ τ :
     typed_ctx_item CTX_Alloc Γ τ Γ (Tref τ)
  | TP_CTX_Load Γ τ :
     typed_ctx_item CTX_Load Γ (Tref τ) Γ τ
  | TP_CTX_StoreL Γ e2 τ :
     typed Γ e2 τ → typed_ctx_item (CTX_StoreL e2) Γ (Tref τ) Γ TUnit
  | TP_CTX_StoreR Γ e1 τ :
     typed Γ e1 (Tref τ) →
     typed_ctx_item (CTX_StoreR e1) Γ τ Γ TUnit.

Lemma typed_ctx_item_typed k Γ τ Γ' τ' e :
  typed Γ e τ → typed_ctx_item k Γ τ Γ' τ' →
  typed Γ' (fill_ctx_item k e) τ'.
Proof. induction 2; simpl; eauto using typed. Qed.

Inductive typed_ctx: ctx → list type → type → list type → type → Prop :=
  | TPCTX_nil Γ τ :
     typed_ctx nil Γ τ Γ τ
  | TPCTX_cons Γ1 τ1 Γ2 τ2 Γ3 τ3 k K :
     typed_ctx_item k Γ2 τ2 Γ3 τ3 →
     typed_ctx K Γ1 τ1 Γ2 τ2 →
     typed_ctx (k :: K) Γ1 τ1 Γ3 τ3.

Lemma typed_ctx_typed K Γ τ Γ' τ' e :
  typed Γ e τ → typed_ctx K Γ τ Γ' τ' → typed Γ' (fill_ctx K e) τ'.
Proof. induction 2; simpl; eauto using typed_ctx_item_typed. Qed.

Lemma typed_ctx_n_closed K Γ τ Γ' τ' e :
  (∀ f, e.[upn (length Γ) f] = e) → typed_ctx K Γ τ Γ' τ' →
  ∀ f, (fill_ctx K e).[upn (length Γ') f] = (fill_ctx K e).
Proof.
  intros H1 H2; induction H2; simpl; auto.
  induction H => f; asimpl; simpl in *;
    repeat match goal with H : _ |- _ => rewrite fmap_length in H end;
    try f_equal;
    eauto using typed_n_closed;
    try match goal with H : _ |- _ => eapply (typed_n_closed _ _ _ H) end.
Qed.

Definition ctx_refines (Γ : list type)
    (e e' : expr) (τ : type) := ∀ K thp σ v,
  typed_ctx K Γ τ [] TUnit →
  rtc step ([fill_ctx K e], ∅) (of_val v :: thp, σ) →
  ∃ thp' σ' v', rtc step ([fill_ctx K e'], ∅) (of_val v' :: thp', σ').
Notation "Γ ⊨ e '≤ctx≤' e' : τ" :=
  (ctx_refines Γ e e' τ) (at level 74, e, e', τ at next level).

Ltac fold_interp :=
  match goal with
  | |- context [ interp_expr (interp_arrow (interp ?A) (interp ?A'))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_arrow (interp A) (interp A')) B (C, D)) with
    (interp_expr (interp (TArrow A A')) B (C, D))
  | |- context [ interp_expr (interp_prod (interp ?A) (interp ?A'))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_prod (interp A) (interp A')) B (C, D)) with
    (interp_expr (interp (TProd A A')) B (C, D))
  | |- context [ interp_expr (interp_prod (interp ?A) (interp ?A'))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_prod (interp A) (interp A')) B (C, D)) with
    (interp_expr (interp (TProd A A')) B (C, D))
  | |- context [ interp_expr (interp_sum (interp ?A) (interp ?A'))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_sum (interp A) (interp A')) B (C, D)) with
    (interp_expr (interp (TSum A A')) B (C, D))
  | |- context [ interp_expr (interp_rec (interp ?A)) ?B (?C, ?D) ] =>
    change (interp_expr (interp_rec (interp A)) B (C, D)) with
    (interp_expr (interp (TRec A)) B (C, D))
  | |- context [ interp_expr (interp_forall (interp ?A))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_forall (interp A)) B (C, D)) with
    (interp_expr (interp (TForall A)) B (C, D))
  | |- context [ interp_expr (interp_ref (interp ?A))
                            ?B (?C, ?D) ] =>
    change (interp_expr (interp_ref (interp A)) B (C, D)) with
    (interp_expr (interp (Tref A)) B (C, D))
  end.

Section bin_log_related_under_typed_ctx.
  Context `{heapG Σ, cfgSG Σ}.

  Lemma bin_log_related_under_typed_ctx Γ e e' τ Γ' τ' K :
    (∀ f, e.[upn (length Γ) f] = e) →
    (∀ f, e'.[upn (length Γ) f] = e') →
    typed_ctx K Γ τ Γ' τ' →
    Γ ⊨ e ≤log≤ e' : τ → Γ' ⊨ fill_ctx K e ≤log≤ fill_ctx K e' : τ'.
  Proof.
    revert Γ τ Γ' τ' e e'.
    induction K as [|k K]=> Γ τ Γ' τ' e e' H1 H2; simpl.
    - inversion_clear 1; trivial.
    - inversion_clear 1 as [|? ? ? ? ? ? ? ? Hx1 Hx2]. intros H3.
      specialize (IHK _ _ _ _ e e' H1 H2 Hx2 H3).
      inversion Hx1; subst; simpl; try fold_interp.
      + eapply bin_log_related_lam; eauto;
          match goal with
            H : _ |- _ => eapply (typed_ctx_n_closed _ _ _ _ _ _ _ H)
          end.
      + eapply bin_log_related_app; eauto using binary_fundamental.
      + eapply bin_log_related_app; eauto using binary_fundamental.
      + eapply bin_log_related_pair; eauto using binary_fundamental.
      + eapply bin_log_related_pair; eauto using binary_fundamental.
      + eapply bin_log_related_fst; eauto.
      + eapply bin_log_related_snd; eauto.
      + eapply bin_log_related_injl; eauto.
      + eapply bin_log_related_injr; eauto.
      + match goal with
          H : typed_ctx_item _ _ _ _ _ |- _ => inversion H; subst
        end.
        eapply bin_log_related_case;
          eauto using binary_fundamental;
          match goal with
            H : _ |- _ => eapply (typed_n_closed _ _ _ H)
          end.
      + match goal with
          H : typed_ctx_item _ _ _ _ _ |- _ => inversion H; subst
        end.
        eapply bin_log_related_case;
          eauto using binary_fundamental;
          try match goal with
                H : _ |- _ => eapply (typed_n_closed _ _ _ H)
              end;
          match goal with
            H : _ |- _ => eapply (typed_ctx_n_closed _ _ _ _ _ _ _ H)
          end.
      + match goal with
          H : typed_ctx_item _ _ _ _ _ |- _ => inversion H; subst
        end.
        eapply bin_log_related_case;
          eauto using binary_fundamental;
          try match goal with
                H : _ |- _ => eapply (typed_n_closed _ _ _ H)
              end;
          match goal with
            H : _ |- _ => eapply (typed_ctx_n_closed _ _ _ _ _ _ _ H)
          end.
      + eapply bin_log_related_fold; eauto.
      + eapply bin_log_related_unfold; eauto.
      + eapply bin_log_related_tlam; eauto with typeclass_instances.
      + eapply bin_log_related_tapp; eauto.
      + eapply bin_log_related_alloc; eauto.
      + eapply bin_log_related_load; eauto.
      + eapply bin_log_related_store; eauto using binary_fundamental.
      + eapply bin_log_related_store; eauto using binary_fundamental.
        Unshelve. all: trivial.
  Qed.
End bin_log_related_under_typed_ctx.


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

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo_def.
Require Import Cos_rel.
Require Import Max.
Open Local Scope nat_scope.
Open Local Scope R_scope.

Definition Majxy (x y:R) (n:nat) : R :=
  Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S n) / INR (fact n).

Lemma Majxy_cv_R0 : forall x y:R, Un_cv (Majxy x y) 0.
Proof.
  intros.
  set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
  set (C0 := C ^ 4).
  cut (0 < C).
  intro.
  cut (0 < C0).
  intro.
  assert (H1 := cv_speed_pow_fact C0).
  unfold Un_cv in H1; unfold R_dist in H1.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  cut (0 < eps / C0);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
	[ assumption | apply Rinv_0_lt_compat; assumption ] ].
  elim (H1 (eps / C0) H3); intros N0 H4.
  exists N0; intros.
  replace (Majxy x y n) with (C0 ^ S n / INR (fact n)).
  simpl in |- *.
  apply Rmult_lt_reg_l with (Rabs (/ C0)).
  apply Rabs_pos_lt.
  apply Rinv_neq_0_compat.
  red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
  rewrite <- Rabs_mult.
  unfold Rminus in |- *; rewrite Rmult_plus_distr_l.
  rewrite Ropp_0; rewrite Rmult_0_r.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  rewrite (Rabs_right (/ C0)).
  rewrite <- (Rmult_comm eps).
  replace (C0 ^ n * / INR (fact n) + 0) with (C0 ^ n * / INR (fact n) - 0);
    [ idtac | ring ].
  unfold Rdiv in H4; apply H4; assumption.
  apply Rle_ge; left; apply Rinv_0_lt_compat; assumption.
  red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
  unfold Majxy in |- *.
  unfold C0 in |- *.
  rewrite pow_mult.
  unfold C in |- *; reflexivity.
  unfold C0 in |- *; apply pow_lt; assumption.
  apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *.
  apply RmaxLess1.
Qed.

Lemma reste1_maj :
  forall (x y:R) (N:nat),
    (0 < N)%nat -> Rabs (Reste1 x y N) <= Majxy x y (pred N).
Proof.
  intros.
  set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
  unfold Reste1 in |- *.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	Rabs
        (sum_f_R0
          (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
            y ^ (2 * (N - l))) (pred (N - k)))) (
	      pred N)).
  apply
    (Rsum_abs
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
          x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
          y ^ (2 * (N - l))) (pred (N - k))) (pred N)).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          Rabs
          ((-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
            y ^ (2 * (N - l)))) (pred (N - k))) (
	      pred N)).
  apply sum_Rle.
  intros.
  apply
    (Rsum_abs
      (fun l:nat =>
	(-1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) *
	((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
	y ^ (2 * (N - l))) (pred (N - n))).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) *
          C ^ (2 * S (N + k))) (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  unfold Rdiv in |- *; repeat rewrite Rabs_mult.
  do 2 rewrite pow_1_abs.
  do 2 rewrite Rmult_1_l.
  rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n))))).
  rewrite (Rabs_right (/ INR (fact (2 * (N - n0))))).
  rewrite mult_INR.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  rewrite <- Rmult_assoc.
  rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0))))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  do 2 rewrite <- RPow_abs.
  apply Rle_trans with (Rabs x ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C in |- *.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
  apply Rle_trans with (C ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
  do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0)))).
  apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess1.
  apply RmaxLess2.
  right.
  replace (2 * S (N + n))%nat with (2 * (N - n0) + 2 * S (n0 + n))%nat.
  rewrite pow_add.
  apply Rmult_comm.
  apply INR_eq; rewrite plus_INR; do 3 rewrite mult_INR.
  rewrite minus_INR.
  repeat rewrite S_INR; do 2 rewrite plus_INR; ring.
  apply le_trans with (pred (N - n)).
  exact H1.
  apply le_S_n.
  replace (S (pred (N - n))) with (N - n)%nat.
  apply le_trans with N.
  apply (fun p n m:nat => plus_le_reg_l n m p) with n.
  rewrite <- le_plus_minus.
  apply le_plus_r.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply le_n_Sn.
  apply S_pred with 0%nat.
  apply plus_lt_reg_l with n.
  rewrite <- le_plus_minus.
  replace (n + 0)%nat with n; [ idtac | ring ].
  apply le_lt_trans with (pred N).
  assumption.
  apply lt_pred_n_n; assumption.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) * C ^ (4 * N))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat.
  rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  apply Rle_pow.
  unfold C in |- *; apply RmaxLess1.
  replace (4 * N)%nat with (2 * (2 * N))%nat; [ idtac | ring ].
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (2 * N)%nat with (S (N + pred N)).
  apply le_n_S.
  apply plus_le_compat_l; assumption.
  rewrite pred_of_minus.
  omega.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => C ^ (4 * N) * Rsqr (/ INR (fact (S (N + k)))))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  rewrite <- (Rmult_comm (C ^ (4 * N))).
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  replace (/ INR (fact (2 * S (n0 + n)) * fact (2 * (N - n0)))) with
    (Binomial.C (2 * S (N + n)) (2 * S (n0 + n)) / INR (fact (2 * S (N + n)))).
  apply Rle_trans with
    (Binomial.C (2 * S (N + n)) (S (N + n)) / INR (fact (2 * S (N + n)))).
  unfold Rdiv in |- *;
    do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (N + n))))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply C_maj.
  omega.
  right.
  unfold Rdiv in |- *; rewrite Rmult_comm.
  unfold Binomial.C in |- *.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (N + n) - S (N + n))%nat with (S (N + n)).
  rewrite Rinv_mult_distr.
  unfold Rsqr in |- *; reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  omega.
  apply INR_fact_neq_0.
  unfold Rdiv in |- *; rewrite Rmult_comm.
  unfold Binomial.C in |- *.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (N + n) - 2 * S (n0 + n))%nat with (2 * (N - n0))%nat.
  rewrite mult_INR.
  reflexivity.
  omega.
  apply INR_fact_neq_0.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR N / INR (fact (S N)) * C ^ (4 * N)) (pred N)).
  apply sum_Rle; intros.
  rewrite <-
    (scal_sum (fun _:nat => C ^ (4 * N)) (pred (N - n))
      (Rsqr (/ INR (fact (S (N + n)))))).
  rewrite sum_cte.
  rewrite <- Rmult_assoc.
  do 2 rewrite <- (Rmult_comm (C ^ (4 * N))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  apply Rle_trans with (Rsqr (/ INR (fact (S (N + n)))) * INR N).
  apply Rmult_le_compat_l.
  apply Rle_0_sqr.
  apply le_INR.
  omega.
  rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
  apply pos_INR.
  apply Rle_trans with (/ INR (fact (S (N + n)))).
  pattern (/ INR (fact (S (N + n)))) at 2 in |- *; rewrite <- Rmult_1_r.
  unfold Rsqr in |- *.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r.
  replace 1 with (INR 1).
  apply le_INR.
  apply lt_le_S.
  apply INR_lt; apply INR_fact_lt_0.
  reflexivity.
  apply INR_fact_neq_0.
  apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (fact (S N))).
  apply INR_fact_lt_0.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm (INR (fact (S N)))).
  rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  apply le_INR.
  apply fact_le.
  apply le_n_S.
  apply le_plus_l.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  rewrite sum_cte.
  apply Rle_trans with (C ^ (4 * N) / INR (fact (pred N))).
  rewrite <- (Rmult_comm (C ^ (4 * N))).
  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  cut (S (pred N) = N).
  intro; rewrite H0.
  pattern N at 2 in |- *; rewrite <- H0.
  do 2 rewrite fact_simpl.
  rewrite H0.
  repeat rewrite mult_INR.
  repeat rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (/ INR (S N))).
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l.
  pattern (/ INR (fact (pred N))) at 2 in |- *; rewrite <- Rmult_1_r.
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (S N)).
  apply lt_INR_0; apply lt_O_Sn.
  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; rewrite Rmult_1_l.
  apply le_INR; apply le_n_Sn.
  apply not_O_INR; discriminate.
  apply not_O_INR.
  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
  apply not_O_INR.
  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
  apply INR_fact_neq_0.
  apply not_O_INR; discriminate.
  apply prod_neq_R0.
  apply not_O_INR.
  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
  apply INR_fact_neq_0.
  symmetry  in |- *; apply S_pred with 0%nat; assumption.
  right.
  unfold Majxy in |- *.
  unfold C in |- *.
  replace (S (pred N)) with N.
  reflexivity.
  apply S_pred with 0%nat; assumption.
Qed.

Lemma reste2_maj :
  forall (x y:R) (N:nat), (0 < N)%nat -> Rabs (Reste2 x y N) <= Majxy x y N.
Proof.
  intros.
  set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
  unfold Reste2 in |- *.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	Rabs
        (sum_f_R0
          (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
            y ^ (2 * (N - l) + 1)) (pred (N - k)))) (
	      pred N)).
  apply
    (Rsum_abs
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
          x ^ (2 * S (l + k) + 1) *
          ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
          y ^ (2 * (N - l) + 1)) (pred (N - k))) (
	    pred N)).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          Rabs
          ((-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
            y ^ (2 * (N - l) + 1))) (pred (N - k))) (
	      pred N)).
  apply sum_Rle.
  intros.
  apply
    (Rsum_abs
      (fun l:nat =>
	(-1) ^ S (l + n) / INR (fact (2 * S (l + n) + 1)) *
	x ^ (2 * S (l + n) + 1) *
	((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
	y ^ (2 * (N - l) + 1)) (pred (N - n))).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
          C ^ (2 * S (S (N + k)))) (pred (N - k))) (
	    pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  unfold Rdiv in |- *; repeat rewrite Rabs_mult.
  do 2 rewrite pow_1_abs.
  do 2 rewrite Rmult_1_l.
  rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n) + 1)))).
  rewrite (Rabs_right (/ INR (fact (2 * (N - n0) + 1)))).
  rewrite mult_INR.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  rewrite <- Rmult_assoc.
  rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0) + 1)))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  do 2 rewrite <- RPow_abs.
  apply Rle_trans with (Rabs x ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C in |- *.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
  apply Rle_trans with (C ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
  do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0) + 1))).
  apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess1.
  apply RmaxLess2.
  right.
  replace (2 * S (S (N + n)))%nat with
    (2 * (N - n0) + 1 + (2 * S (n0 + n) + 1))%nat.
  repeat rewrite pow_add.
  ring.
  omega.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply Rle_ge; left; apply Rinv_0_lt_compat.
  apply INR_fact_lt_0.
  apply Rle_ge; left; apply Rinv_0_lt_compat.
  apply INR_fact_lt_0.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
          C ^ (4 * S N)) (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat.
  rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  apply Rle_pow.
  unfold C in |- *; apply RmaxLess1.
  replace (4 * S N)%nat with (2 * (2 * S N))%nat; [ idtac | ring ].
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (2 * S N)%nat with (S (S (N + N))).
  repeat apply le_n_S.
  apply plus_le_compat_l.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  ring.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat => C ^ (4 * S N) * Rsqr (/ INR (fact (S (S (N + k))))))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  rewrite <- (Rmult_comm (C ^ (4 * S N))).
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  replace (/ INR (fact (2 * S (n0 + n) + 1) * fact (2 * (N - n0) + 1))) with
    (Binomial.C (2 * S (S (N + n))) (2 * S (n0 + n) + 1) /
      INR (fact (2 * S (S (N + n))))).
  apply Rle_trans with
    (Binomial.C (2 * S (S (N + n))) (S (S (N + n))) /
      INR (fact (2 * S (S (N + n))))).
  unfold Rdiv in |- *;
    do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (S (N + n)))))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply C_maj.
  apply le_trans with (2 * S (S (n0 + n)))%nat.
  replace (2 * S (S (n0 + n)))%nat with (S (2 * S (n0 + n) + 1)).
  apply le_n_Sn.
  ring.
  omega.
  right.
  unfold Rdiv in |- *; rewrite Rmult_comm.
  unfold Binomial.C in |- *.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (S (N + n)) - S (S (N + n)))%nat with (S (S (N + n))).
  rewrite Rinv_mult_distr.
  unfold Rsqr in |- *; reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  omega.
  apply INR_fact_neq_0.
  unfold Rdiv in |- *; rewrite Rmult_comm.
  unfold Binomial.C in |- *.
  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (S (N + n)) - (2 * S (n0 + n) + 1))%nat with
    (2 * (N - n0) + 1)%nat.
  rewrite mult_INR.
  reflexivity.
  omega.
  apply INR_fact_neq_0.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR N / INR (fact (S (S N))) * C ^ (4 * S N))
      (pred N)).
  apply sum_Rle; intros.
  rewrite <-
    (scal_sum (fun _:nat => C ^ (4 * S N)) (pred (N - n))
      (Rsqr (/ INR (fact (S (S (N + n))))))).
  rewrite sum_cte.
  rewrite <- Rmult_assoc.
  do 2 rewrite <- (Rmult_comm (C ^ (4 * S N))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  apply Rle_trans with (Rsqr (/ INR (fact (S (S (N + n))))) * INR N).
  apply Rmult_le_compat_l.
  apply Rle_0_sqr.
  replace (S (pred (N - n))) with (N - n)%nat.
  apply le_INR.
  omega.
  omega.
  rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
  apply pos_INR.
  apply Rle_trans with (/ INR (fact (S (S (N + n))))).
  pattern (/ INR (fact (S (S (N + n))))) at 2 in |- *; rewrite <- Rmult_1_r.
  unfold Rsqr in |- *.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r.
  replace 1 with (INR 1).
  apply le_INR.
  apply lt_le_S.
  apply INR_lt; apply INR_fact_lt_0.
  reflexivity.
  apply INR_fact_neq_0.
  apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (fact (S (S N)))).
  apply INR_fact_lt_0.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm (INR (fact (S (S N))))).
  rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  apply le_INR.
  apply fact_le.
  omega.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  rewrite sum_cte.
  apply Rle_trans with (C ^ (4 * S N) / INR (fact N)).
  rewrite <- (Rmult_comm (C ^ (4 * S N))).
  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with 1.
  apply Rlt_0_1.
  unfold C in |- *; apply RmaxLess1.
  cut (S (pred N) = N).
  intro; rewrite H0.
  do 2 rewrite fact_simpl.
  repeat rewrite mult_INR.
  repeat rewrite Rinv_mult_distr.
  apply Rle_trans with
    (INR (S (S N)) * (/ INR (S (S N)) * (/ INR (S N) * / INR (fact N))) * INR N).
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm (INR N)).
  rewrite (Rmult_comm (INR (S (S N)))).
  apply Rmult_le_compat_l.
  repeat apply Rmult_le_pos.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  left; apply Rinv_0_lt_compat.
  apply INR_fact_lt_0.
  apply pos_INR.
  apply le_INR.
  apply le_trans with (S N); apply le_n_Sn.
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l.
  apply Rle_trans with (/ INR (S N) * / INR (fact N) * INR (S N)).
  repeat rewrite Rmult_assoc.
  repeat apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply le_INR; apply le_n_Sn.
  rewrite (Rmult_comm (/ INR (S N))).
  rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; right; reflexivity.
  apply not_O_INR; discriminate.
  apply not_O_INR; discriminate.
  apply not_O_INR; discriminate.
  apply INR_fact_neq_0.
  apply not_O_INR; discriminate.
  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
  symmetry  in |- *; apply S_pred with 0%nat; assumption.
  right.
  unfold Majxy in |- *.
  unfold C in |- *.
  reflexivity.
Qed.

Lemma reste1_cv_R0 : forall x y:R, Un_cv (Reste1 x y) 0.
Proof.
  intros.
  assert (H := Majxy_cv_R0 x y).
  unfold Un_cv in H; unfold R_dist in H.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H eps H0); intros N0 H1.
  exists (S N0); intros.
  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
  apply Rle_lt_trans with (Rabs (Majxy x y (pred n))).
  rewrite (Rabs_right (Majxy x y (pred n))).
  apply reste1_maj.
  apply lt_le_trans with (S N0).
  apply lt_O_Sn.
  assumption.
  apply Rle_ge.
  unfold Majxy in |- *.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  replace (Majxy x y (pred n)) with (Majxy x y (pred n) - 0); [ idtac | ring ].
  apply H1.
  unfold ge in |- *; apply le_S_n.
  replace (S (pred n)) with n.
  assumption.
  apply S_pred with 0%nat.
  apply lt_le_trans with (S N0); [ apply lt_O_Sn | assumption ].
Qed.

Lemma reste2_cv_R0 : forall x y:R, Un_cv (Reste2 x y) 0.
Proof.
  intros.
  assert (H := Majxy_cv_R0 x y).
  unfold Un_cv in H; unfold R_dist in H.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H eps H0); intros N0 H1.
  exists (S N0); intros.
  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
  apply Rle_lt_trans with (Rabs (Majxy x y n)).
  rewrite (Rabs_right (Majxy x y n)).
  apply reste2_maj.
  apply lt_le_trans with (S N0).
  apply lt_O_Sn.
  assumption.
  apply Rle_ge.
  unfold Majxy in |- *.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  replace (Majxy x y n) with (Majxy x y n - 0); [ idtac | ring ].
  apply H1.
  unfold ge in |- *; apply le_trans with (S N0).
  apply le_n_Sn.
  exact H2.
Qed.

Lemma reste_cv_R0 : forall x y:R, Un_cv (Reste x y) 0.
Proof.
  intros.
  unfold Reste in |- *.
  set (An := fun n:nat => Reste2 x y n).
  set (Bn := fun n:nat => Reste1 x y (S n)).
  cut
    (Un_cv (fun n:nat => An n - Bn n) (0 - 0) ->
      Un_cv (fun N:nat => Reste2 x y N - Reste1 x y (S N)) 0).
  intro.
  apply H.
  apply CV_minus.
  unfold An in |- *.
  replace (fun n:nat => Reste2 x y n) with (Reste2 x y).
  apply reste2_cv_R0.
  reflexivity.
  unfold Bn in |- *.
  assert (H0 := reste1_cv_R0 x y).
  unfold Un_cv in H0; unfold R_dist in H0.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  elim (H0 eps H1); intros N0 H2.
  exists N0; intros.
  apply H2.
  unfold ge in |- *; apply le_trans with (S N0).
  apply le_n_Sn.
  apply le_n_S; assumption.
  unfold An, Bn in |- *.
  intro.
  replace 0 with (0 - 0); [ idtac | ring ].
  exact H.
Qed.

Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y.
Proof.
  intros.
  cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)).
  cut (Un_cv (C1 x y) (cos (x + y))).
  intros.
  apply UL_sequence with (C1 x y); assumption.
  apply C1_cvg.
  unfold Un_cv in |- *; unfold R_dist in |- *.
  intros.
  assert (H0 := A1_cvg x).
  assert (H1 := A1_cvg y).
  assert (H2 := B1_cvg x).
  assert (H3 := B1_cvg y).
  assert (H4 := CV_mult _ _ _ _ H0 H1).
  assert (H5 := CV_mult _ _ _ _ H2 H3).
  assert (H6 := reste_cv_R0 x y).
  unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6.
  unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6.
  cut (0 < eps / 3);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (H4 (eps / 3) H7); intros N1 H8.
  elim (H5 (eps / 3) H7); intros N2 H9.
  elim (H6 (eps / 3) H7); intros N3 H10.
  set (N := S (S (max (max N1 N2) N3))).
  exists N.
  intros.
  cut (n = S (pred n)).
  intro; rewrite H12.
  rewrite <- cos_plus_form.
  rewrite <- H12.
  apply Rle_lt_trans with
    (Rabs (A1 x n * A1 y n - cos x * cos y) +
      Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))).
  replace
    (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) -
      (cos x * cos y - sin x * sin y)) with
    (A1 x n * A1 y n - cos x * cos y +
      (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n)));
    [ apply Rabs_triang | ring ].
  replace eps with (eps / 3 + (eps / 3 + eps / 3)).
  apply Rplus_lt_compat.
  apply H8.
  unfold ge in |- *; apply le_trans with N.
  unfold N in |- *.
  apply le_trans with (max N1 N2).
  apply le_max_l.
  apply le_trans with (max (max N1 N2) N3).
  apply le_max_l.
  apply le_trans with (S (max (max N1 N2) N3)); apply le_n_Sn.
  assumption.
  apply Rle_lt_trans with
    (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) +
      Rabs (Reste x y (pred n))).
  apply Rabs_triang.
  apply Rplus_lt_compat.
  rewrite <- Rabs_Ropp.
  rewrite Ropp_minus_distr.
  apply H9.
  unfold ge in |- *; apply le_trans with (max N1 N2).
  apply le_max_r.
  apply le_S_n.
  rewrite <- H12.
  apply le_trans with N.
  unfold N in |- *.
  apply le_n_S.
  apply le_trans with (max (max N1 N2) N3).
  apply le_max_l.
  apply le_n_Sn.
  assumption.
  replace (Reste x y (pred n)) with (Reste x y (pred n) - 0).
  apply H10.
  unfold ge in |- *.
  apply le_S_n.
  rewrite <- H12.
  apply le_trans with N.
  unfold N in |- *.
  apply le_n_S.
  apply le_trans with (max (max N1 N2) N3).
  apply le_max_r.
  apply le_n_Sn.
  assumption.
  ring.
  pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
  ring.
  unfold Rdiv in |- *.
  rewrite <- Rmult_assoc.
  apply Rinv_r_simpl_m.
  discrR.
  apply lt_le_trans with (pred N).
  unfold N in |- *; simpl in |- *; apply lt_O_Sn.
  apply le_S_n.
  rewrite <- H12.
  replace (S (pred N)) with N.
  assumption.
  unfold N in |- *; simpl in |- *; reflexivity.
  cut (0 < N)%nat.
  intro.
  cut (0 < n)%nat.
  intro.
  apply S_pred with 0%nat; assumption.
  apply lt_le_trans with N; assumption.
  unfold N in |- *; apply lt_O_Sn.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
  induction l1.
  - intros. simpl. f_equal. apply IHl1.
  - intros. reflexivity.
Qed.

Lemma lem2 : forall l, len l = len (append l Nil).
Proof.
  induction l.
  - simpl. f_equal. apply IHl.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (len (rev x)) (len x).
Proof.
induction x.
  - simpl. rewrite <- IHx. rewrite <- (lem (rev x) Nil n).
 lfind. Admitted.


Require Export Syntax.

Inductive envDom :=
  | env_var : var -> envDom
  | env_loc : loc -> envDom.

Instance ID_envDom : ID envDom := {}.
  intros; repeat (decide equality).
Qed.

Definition env := partial_map envDom ty.

Inductive wfType (P : program) : ty -> Prop :=
  | WF_TClass :
      forall c,
        classLookup P c <> None ->
        wfType P (TClass c)
  | WF_TInterface :
      forall i,
        interfaceLookup P i <> None ->
        wfType P (TInterface i)
  | WF_TUnit : wfType P TUnit.

Inductive wfEnv (P : program) : env -> Prop :=
  | WF_Env :
      (forall Gamma,
        (forall x t, Gamma x = Some t -> wfType P t) ->
        (forall l t, Gamma (env_loc l) = Some t -> exists c, t = TClass c) ->
        wfEnv P Gamma).

Inductive wfFrame (Gamma Gamma1 Gamma2 : env) : Prop :=
  | WF_Frame :
      (forall x t, Gamma1 x = Some t -> Gamma x = Some t) ->
      (forall x t, Gamma2 x = Some t -> Gamma x = Some t) ->
      (forall x t, Gamma1 (env_var x) = Some t -> Gamma2 (env_var x) = None) ->
      (forall x t, Gamma2 (env_var x) = Some t -> Gamma1 (env_var x) = None) ->
      wfFrame Gamma Gamma1 Gamma2.

Inductive wfSubsumption (Gamma Gamma' : env) : Prop :=
  | WF_Subsumption :
      (forall x t, Gamma x = Some t -> Gamma' x = Some t) ->
      wfSubsumption Gamma Gamma'.

Inductive subtypeOf (P : program) : ty -> ty -> Prop :=
  | Sub_Class :
      forall c i fs ms,
        classLookup P c = Some (Cls c i fs ms) ->
        subtypeOf P (TClass c) (TInterface i)
  | Sub_InterfaceLeft :
      forall i i1 i2,
        interfaceLookup P i = Some (ExtInterface i i1 i2) ->
        subtypeOf P (TInterface i) (TInterface i1)
  | Sub_InterfaceRight :
      forall i i1 i2,
        interfaceLookup P i = Some (ExtInterface i i1 i2) ->
        subtypeOf P (TInterface i) (TInterface i2)
  | Sub_Refl :
      forall t,
        wfType P t ->
        subtypeOf P t t
  | Sub_Trans :
      forall t1 t2 t3,
        subtypeOf P t1 t2 ->
        subtypeOf P t2 t3 ->
        subtypeOf P t1 t3.
  (* | Sub_Unit : *)
  (*     forall t, *)
  (*       wfType P t -> *)
  (*       subtypeOf P t TUnit. *)

Tactic Notation "subtypeOf_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "Sub_Class"  | Case_aux c "Sub_InterfaceLeft"
  | Case_aux c "Sub_InterfaceRight" | Case_aux c "Sub_Refl"
  | Case_aux c "Sub_Trans" (*| Case_aux c "Sub_Unit"*)].

Reserved Notation " P ';' Gamma '|-' expr '\in' ty " (at level 40).

Inductive hasType (P : program) (Gamma : env) : expr -> ty -> Prop :=
  | T_Var :
      forall x t,
        wfEnv P Gamma ->
        Gamma (env_var x) = Some t ->
        P ; Gamma |- (EVar x) \in t
  | T_Loc :
      forall l t t2,
        wfEnv P Gamma ->
        Gamma (env_loc l) = Some t2 ->
        subtypeOf P t2 t ->
        P ; Gamma |- (EVal (VLoc l)) \in t
  | T_Null :
      forall t,
        wfEnv P Gamma ->
        wfType P t ->
        P ; Gamma |- EVal VNull \in t
  | T_New :
      forall c,
        wfEnv P Gamma ->
        classLookup P c <> None ->
        P ; Gamma |- ENew c \in TClass c
  | T_Call :
      forall x m e t t1 t2 msigs y,
        P ; Gamma |- (EVar x) \in t1 -> (*Gamma (env_var x) = Some t1 ->*)
        methodSigs P t1 msigs ->
        methodSigLookup msigs m = Some (MethodSig m (y, t2) t) ->
        P ; Gamma |- e \in t2 ->
        P ; Gamma |- ECall x m e \in t
  | T_Select :
      forall x f c t fs,
        P ; Gamma |- (EVar x) \in TClass c ->
        fields P (TClass c) = Some fs ->
        fieldLookup fs f = Some (Field f t) ->
        P ; Gamma |- ESelect x f \in t
  | T_Update :
      forall c x f e t fs,
        P ; Gamma |- (EVar x) \in TClass c ->
        fields P (TClass c) = Some fs ->
        fieldLookup fs f = Some (Field f t) ->
        P ; Gamma |- e \in t ->
        P ; Gamma |- EUpdate x f e \in TUnit
  | T_Let :
      forall x e body t t',
        P ; Gamma |- e \in t ->
        P ; extend Gamma (env_var (SV x)) t |- body \in t' ->
        no_locks body ->
        P ; Gamma |- ELet x e body \in t'
  | T_Cast :
      forall e t1 t2,
        P ; Gamma |- e \in t2 ->
        subtypeOf P t2 t1 ->
        P ; Gamma |- ECast t1 e \in t1
  | T_Par :
      forall Gamma1 Gamma2 e1 e2 e3 t1 t2 t3,
        wfFrame Gamma Gamma1 Gamma2 ->
        P ; Gamma1 |- e1 \in t1 ->
        P ; Gamma2 |- e2 \in t2 ->
        P ; Gamma |- e3 \in t3 ->
        no_locks e1 ->
        no_locks e2 ->
        no_locks e3 ->
        P ; Gamma |- EPar e1 e2 e3 \in t3
  | T_Lock :
      forall x t2 e t,
        P ; Gamma |- (EVar x) \in t2 ->
        P ; Gamma |- e \in t ->
        no_locks e ->
        P ; Gamma |- ELock x e \in t
  | T_Locked :
      forall l t2 e t,
        P ; Gamma |- (EVal (VLoc l)) \in t2 ->
        P ; Gamma |- e \in t ->
        P ; Gamma |- ELocked l e \in t
  where " P ';' Gamma '|-' expr '\in' ty " := (hasType P Gamma expr ty).

Tactic Notation "hasType_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var"
  | Case_aux c "T_Loc"
  | Case_aux c "T_Null"
  | Case_aux c "T_New"
  | Case_aux c "T_Call"
  | Case_aux c "T_Select"
  | Case_aux c "T_Update"
  | Case_aux c "T_Let"
  | Case_aux c "T_Cast"
  | Case_aux c "T_Par"
  | Case_aux c "T_Lock"
  | Case_aux c "T_Locked"
  ].


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e222m117_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


From DEZ Require Export
  Init.
From DEZ.Is Require Import
  LeftModule.
From DEZ.ShouldHave Require Import
  FieldNotations.

Definition unit_eqv (x y : unit) : Prop := True.

Instance unit_has_eqv : HasEqv unit := unit_eqv.

Instance unit_is_reflexive : IsReflexive unit_eqv := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_symmetric : IsSymmetric unit_eqv := {}.
Proof. intros x y p. constructor. Qed.

Instance unit_is_transitive : IsTransitive unit_eqv := {}.
Proof. intros x y z p q. constructor. Qed.

Instance unit_is_setoid : IsSetoid unit_eqv := {}.

Theorem unit_eqv_iff_eq : forall x y : unit,
  x == y <-> x = y.
Proof.
  intros [] []. split.
  - intros _. constructor.
  - intros _. constructor. Qed.

Definition tt2 (x y : unit) : unit := tt.

Instance unit_has_opr : HasOpr unit := tt2.

Instance unit_is_associative : IsAssociative tt2 := {}.
Proof. intros x y z. constructor. Qed.

Instance unit_is_semigroup : IsSemigroup tt2 := {}.
Proof. intros x y p z w q. constructor. Qed.

Instance unit_has_idn : HasIdn unit := tt.

Instance unit_is_left_identifiable : IsLeftIdentifiable tt2 tt := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_right_identifiable : IsRightIdentifiable tt2 tt := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_identifiable : IsBiidentifiable tt2 tt := {}.

Instance unit_is_monoid : IsMonoid tt2 tt := {}.

Instance unit_is_commutative : IsCommutative tt2 := {}.
Proof. intros x y. constructor. Qed.

Instance unit_is_commutative_monoid : IsCommutativeMonoid tt2 tt := {}.

Definition tt1 (x : unit) : unit := tt.

Instance unit_has_inv : HasInv unit := tt1.

Instance unit_is_left_invertible : IsLeftInvertible tt2 tt tt1 := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_right_invertible : IsRightInvertible tt2 tt tt1 := {}.
Proof. intros x. constructor. Qed.

Instance unit_is_invertible : IsBiinvertible tt2 tt tt1 := {}.

Instance unit_is_group : IsGroup tt2 tt tt1 := {}.
Proof. intros x y p. constructor. Qed.

Instance unit_is_abelian_group : IsAbelianGroup tt2 tt tt1 := {}.

Instance unit_has_add : HasAdd unit := tt2.
Instance unit_has_mul : HasMul unit := tt2.

Instance unit_has_zero : HasZero unit := tt.
Instance unit_has_one : HasOne unit := tt.

Instance unit_is_left_distributive : IsLeftDistributive tt2 tt2 := {}.
Proof. intros x y z. constructor. Qed.

Instance unit_is_right_distributive : IsRightDistributive tt2 tt2 := {}.
Proof. intros x y z. constructor. Qed.

Instance unit_is_distributive : IsBidistributive tt2 tt2 := {}.

Instance unit_is_semiring : IsSemiring tt2 tt tt2 tt := {}.

Instance unit_has_neg : HasNeg unit := tt1.

Instance unit_is_ring : IsRing tt2 tt tt1 tt2 tt := {}.

Theorem unit_ring_trivial : 1 == 0.
Proof. reflexivity. Qed.

Section Context.

Context {S : Type} `{is_ring : IsRing S}.

Definition unit_lsmul (x : S) (y : unit) : unit := y.

Global Instance unit_has_lsmul : HasLSMul S unit := unit_lsmul.

Global Instance unit_is_left_module : IsLeftModule tt2 tt tt1
  add zero neg mul one unit_lsmul := {}.
Proof. all: constructor. Qed.

End Context.


Axiom pair : nat -> nat -> nat -> Prop.
Axiom pl : (nat -> Prop) -> (nat -> Prop) -> (nat -> Prop).
Axiom plImpR : forall k P Q,
  pl P Q k -> forall (Q':nat -> Prop),
    (forall k', Q k' -> Q' k') ->
    pl P Q' k.

Definition nexists (P:nat -> nat -> Prop) : nat -> Prop :=
  fun k' => exists k, P k k'.

Goal forall a A m,
  True ->
  (pl A (nexists (fun x => (nexists
    (fun y => pl (pair a (S x)) (pair a (S y))))))) m.
Proof.
  intros.
  eapply plImpR; [ | intros; econstructor; econstructor; eauto].
  clear H;
    match goal with
       | |- (pl _ (pl (pair _ ?x) _)) _ => replace x with 0
    end.
Admitted.


Require Import Forcing.

Axiom Obj : Type.
Axiom Hom : Obj -> Obj -> Type.

Notation "P ≤ Q" := (forall R, Hom Q R -> Hom P R) (at level 70).
Notation "#" := (fun (R : Obj) (k : Hom _ R) => k).
Notation "f ∘ g" := (fun (R : Obj) (k : Hom _ R) => f R (g R k)) (at level 40).

Ltac _force c := force Obj Hom c.

Forcing Translate bool using Obj Hom.
Forcing Translate nat using Obj Hom.
Forcing Translate list using Obj Hom.

Inductive vect (A : Type) : nat -> Type :=
| nilv : vect A 0
| consv : A -> forall n, vect A n -> vect A (S n).

Forcing Translate vect using Obj Hom.

Goal True.
Proof.
_force (fun A n (v : vect A n) =>
          match v in vect _ n return (match n with |0 => bool |_ => nat end) with
            |nilv _ => true
            |consv _ _ x r => 1
          end).
exact I.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m19_5limbs_donna.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e414m17_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


(** * Typechecking: A Typechecker for STLC *)

(** The [has_type] relation of the STLC defines what it means for a
    term to belong to a type (in some context).  But it doesn't, by
    itself, give us an algorithm for _checking_ whether or not a term
    is well typed.

    Fortunately, the rules defining [has_type] are _syntax directed_
    -- that is, for every syntactic form of the language, there is
    just one rule that can be used to give a type to terms of that
    form.  This makes it straightforward to translate the typing rules
    into clauses of a typechecking _function_ that takes a term and a
    context and either returns the term's type or else signals that
    the term is not typable.  *)

(** This short chapter constructs such a function and proves it
    correct. *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.
From PLF Require MoreStlc.

Module STLCTypes.
Export STLC.

(* ################################################################# *)
(** * Comparing Types *)

(** First, we need a function to compare two types for equality... *)

Locate "Bool".

Fixpoint eqb_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | <{ Bool }> , <{ Bool }> =>
      true
  | <{ T11->T12 }>, <{ T21->T22 }> =>
      andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | _,_ =>
      false
  end.

(** ... and we need to establish the usual two-way connection between
    the boolean result returned by [eqb_ty] and the logical
    proposition that its inputs are equal. *)

Lemma eqb_ty_refl : forall T,
  eqb_ty T T = true.
Proof.
  intros T. induction T; simpl.
    reflexivity.
    rewrite IHT1. rewrite IHT2. reflexivity.  Qed.

Lemma eqb_ty__eq : forall T1 T2,
  eqb_ty T1 T2 = true -> T1 = T2.
Proof with auto.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  - (* T1=Bool *)
    reflexivity.
  - (* T1 = T1_1->T1_2 *)
    rewrite andb_true_iff in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst...  Qed.
End STLCTypes.

(* ################################################################# *)
(** * The Typechecker *)

(** The typechecker works by walking over the structure of the given
    term, returning either [Some T] or [None].  Each time we make a
    recursive call to find out the types of the subterms, we need to
    pattern-match on the results to make sure that they are not
    [None].  Also, in the [app] case, we use pattern matching to
    extract the left- and right-hand sides of the function's arrow
    type (and fail if the type of the function is not [T11->T12]
    for some [T11] and [T12]). *)

Module FirstTry.
Import STLCTypes.

Fixpoint type_check (Gamma : context) (t : tm) : option ty :=
  match t with
  | tm_var x =>
      Gamma x
  | <{\x:T2, t1}> =>
      match type_check (x |-> T2 ; Gamma) t1 with
      | Some T1 => Some <{T2->T1}>
      | _ => None
      end
  | <{t1 t2}> =>
      match type_check Gamma t1, type_check Gamma t2 with
      | Some <{T11->T12}>, Some T2 =>
          if eqb_ty T11 T2 then Some T12 else None
      | _,_ => None
      end
  | <{true}> =>
      Some <{Bool}>
  | <{false}> =>
      Some <{Bool}>
  | <{if guard then t else f}> =>
      match type_check Gamma guard with
      | Some <{Bool}> =>
          match type_check Gamma t, type_check Gamma f with
          | Some T1, Some T2 =>
              if eqb_ty T1 T2 then Some T1 else None
          | _,_ => None
          end
      | _ => None
      end
  end.

End FirstTry.

(* ################################################################# *)
(** * Digression: Improving the Notation *)

(** Before we consider the properties of this algorithm, let's write
    it out again in a cleaner way, using "monadic" notations in the
    style of Haskell to streamline the plumbing of options.  First, we
    define a notation for composing two potentially failing (i.e.,
    option-returning) computations: *)

Notation " x <- e1 ;; e2" := (match e1 with
                              | Some x => e2
                              | None => None
                              end)
         (right associativity, at level 60).

(** Second, we define [return] and [fail] as synonyms for [Some] and
    [None]: *)

Notation " 'return' e "
  := (Some e) (at level 60).

Notation " 'fail' "
  := None.

Module STLCChecker.
Import STLCTypes.

(** Now we can write the same type-checking function in a more
    imperative-looking style using these notations. *)

Fixpoint type_check (Gamma : context) (t : tm) : option ty :=
  match t with
  | tm_var x =>
    T <- Gamma x ;; return T
  | <{\x:T2, t1}> =>
      T1 <- type_check (x |-> T2 ; Gamma) t1 ;;
      return <{T2->T1}>
  | <{t1 t2}> =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1 with
      | <{T11->T12}> =>
          if eqb_ty T11 T2 then return T12 else fail
      | _ => fail
      end
  | <{true}> =>
      return <{ Bool }>
  | <{false}> =>
      return <{ Bool }>
  | <{if guard then t1 else t2}> =>
      Tguard <- type_check Gamma guard ;;
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match Tguard with
      | <{ Bool }> =>
          if eqb_ty T1 T2 then return T1 else fail
      | _ => fail
      end
  end.

(* ################################################################# *)
(** * Properties *)

(** To verify that the typechecking algorithm is correct, we show that
    it is _sound_ and _complete_ for the original [has_type]
    relation -- that is, [type_check] and [has_type] define the same
    partial function. *)

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - (* var *) rename s into x. destruct (Gamma x) eqn:H.
    rename t into T'. inversion H0. subst. eauto. solve_by_invert.
  - (* app *)
    remember (type_check Gamma t1) as TO1.
    destruct TO1 as [T1|]; try solve_by_invert;
    destruct T1 as [|T11 T12]; try solve_by_invert;
    remember (type_check Gamma t2) as TO2;
    destruct TO2 as [T2|]; try solve_by_invert.
    destruct (eqb_ty T11 T2) eqn: Heqb.
    apply eqb_ty__eq in Heqb.
    inversion H0; subst...
    inversion H0.
  - (* abs *)
    rename s into x, t into T1.
    remember (x |-> T1 ; Gamma) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve_by_invert.
    inversion H0; subst...
  - (* tru *) eauto.
  - (* fls *) eauto.
  - (* test *)
    remember (type_check Gamma t1) as TOc.
    remember (type_check Gamma t2) as TO1.
    remember (type_check Gamma t3) as TO2.
    destruct TOc as [Tc|]; try solve_by_invert.
    destruct Tc; try solve_by_invert;
    destruct TO1 as [T1|]; try solve_by_invert;
    destruct TO2 as [T2|]; try solve_by_invert.
    destruct (eqb_ty T1 T2) eqn:Heqb;
    try solve_by_invert.
    apply eqb_ty__eq in Heqb.
    inversion H0. subst. subst...
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof with auto.
  intros Gamma t T Hty.
  induction Hty; simpl.
  - (* T_Var *) destruct (Gamma x0) eqn:H0; assumption.
  - (* T_Abs *) rewrite IHHty...
  - (* T_App *)
    rewrite IHHty1. rewrite IHHty2.
    rewrite (eqb_ty_refl T2)...
  - (* T_True *) eauto.
  - (* T_False *) eauto.
  - (* T_If *) rewrite IHHty1. rewrite IHHty2.
    rewrite IHHty3. rewrite (eqb_ty_refl T1)...
Qed.

End STLCChecker.

(* ################################################################# *)
(** * Exercises *)

(** **** Exercise: 5 stars, standard (typechecker_extensions)

    In this exercise we'll extend the typechecker to deal with the
    extended features discussed in chapter [MoreStlc].  Your job
    is to fill in the omitted cases in the following. *)

Module TypecheckerExtensions.
(* Do not modify the following line: *)
Definition manual_grade_for_type_checking_sound : option (nat*string) := None.
(* Do not modify the following line: *)
Definition manual_grade_for_type_checking_complete : option (nat*string) := None.
Import MoreStlc.
Import STLCExtended.

Fixpoint eqb_ty (T1 T2 : ty) : bool :=
  match T1,T2 with
  | <{{Nat}}>, <{{Nat}}> =>
      true
  | <{{Unit}}>, <{{Unit}}> =>
      true
  | <{{T11 -> T12}}>, <{{T21 -> T22}}> =>
      andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | <{{T11 * T12}}>, <{{T21 * T22}}> =>
      andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | <{{T11 + T12}}>, <{{T21 + T22}}> =>
      andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | <{{List T11}}>, <{{List T21}}> =>
      eqb_ty T11 T21
  | _,_ =>
      false
  end.

Lemma eqb_ty_refl : forall T,
  eqb_ty T T = true.
Proof.
  intros T.
  induction T; simpl; auto;
    rewrite IHT1; rewrite IHT2; reflexivity.  Qed.

Lemma eqb_ty__eq : forall T1 T2,
  eqb_ty T1 T2 = true -> T1 = T2.
Proof.
  intros T1.
  induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq;
    try reflexivity;
    try (rewrite andb_true_iff in H0; inversion H0 as [Hbeq1 Hbeq2];
         apply IHT1_1 in Hbeq1; apply IHT1_2 in Hbeq2; subst; auto);
    try (apply IHT1 in Hbeq; subst; auto).
 Qed.

Fixpoint type_check (Gamma : context) (t : tm) : option ty :=
  match t with
  | tm_var x =>
      match Gamma x with
      | Some T => return T
      | None   => fail
      end
  | <{ \ x1 : T1, t2 }> =>
      T2 <- type_check (x1 |-> T1 ; Gamma) t2 ;;
      return <{{T1 -> T2}}>
  | <{ t1 t2 }> =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1 with
      | <{{T11 -> T12}}> =>
          if eqb_ty T11 T2 then return T12 else fail
      | _ => fail
      end
  | tm_const _ =>
      return <{{Nat}}>
  | <{ succ t1 }> =>
      T1 <- type_check Gamma t1 ;;
      match T1 with
      | <{{Nat}}> => return <{{Nat}}>
      | _ => fail
      end
  | <{ pred t1 }> =>
      T1 <- type_check Gamma t1 ;;
      match T1 with
      | <{{Nat}}> => return <{{Nat}}>
      | _ => fail
      end
  | <{ t1 * t2 }> =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1, T2 with
      | <{{Nat}}>, <{{Nat}}> => return <{{Nat}}>
      | _,_        => fail
      end
  | <{ t.fst }> =>
    match type_check Gamma t with
    | Some <{{T1 * T2}}> => return T1
    | _ => fail
    end
  | <{ t.snd }> =>
    match type_check Gamma t with
    | Some <{{T1 * T2}}> => return T2
    | _ => fail
    end
  | <{ if0 guard then t else f }> =>
      Tguard <- type_check Gamma guard ;;
      T1 <- type_check Gamma t ;;
      T2 <- type_check Gamma f ;;
      match Tguard with
      | <{{Nat}}> => if eqb_ty T1 T2 then return T1 else fail
      | _ => fail
      end

  (* Complete the following cases. *)

  (* sums *)
  | <{ inl T2 t }> =>
    T1 <- type_check Gamma t ;;
    return <{{T1 + T2}}>
  | <{ inr T1 t }> =>
    T2 <- type_check Gamma t ;;
    return <{{T1 + T2}}>
  | <{ case t of | inl x1 => t1 | inr x2 => t2 }> =>
    match type_check Gamma t with
    | Some <{{T1 + T2}}> =>
      T3  <- type_check (x1 |-> T1; Gamma) t1 ;;
      T3' <- type_check (x2 |-> T2; Gamma) t2 ;;
      if eqb_ty T3 T3' then return T3 else fail
    | _ => fail
    end

  (* lists (the [tlcase] is given for free) *)
  | <{ nil T }> => return <{{List T}}>
  | <{ h :: t }> =>
    Th <- type_check Gamma h ;;
    match type_check Gamma t with
    | Some <{{List T}}> => if eqb_ty T Th then return <{{List T}}> else fail
    | _ => fail
    end
  | <{ case t0 of | nil => t1 | x21 :: x22 => t2 }> =>
      match type_check Gamma t0 with
      | Some <{{List T}}> =>
          match type_check Gamma t1,
                type_check (x21 |-> T ; x22 |-> <{{List T}}> ; Gamma) t2 with
          | Some T1', Some T2' =>
              if eqb_ty T1' T2' then Some T1' else None
          | _,_ => None
          end
      | _ => None
      end
  (* unit *)
  | <{ unit }> => return <{{Unit}}>
  (* pairs *)
  | <{(t1,t2)}> =>
    T1 <- type_check Gamma t1 ;;
    T2 <- type_check Gamma t2 ;;
    return <{{T1 * T2}}>
  (* let *)
  | <{let x=v in t}> =>
    Tv <- type_check Gamma v ;;
    type_check (x |-> Tv ; Gamma) t
  (* fix *)
  | <{ fix t }> =>
    match type_check Gamma t with
    | Some <{{T -> T'}}> => if eqb_ty T T' then return T else fail
    | _ => fail
    end
  end.

(** Just for fun, we'll do the soundness proof with just a bit more
    automation than above, using these "mega-tactics": *)

Ltac invert_typecheck Gamma t T :=
  remember (type_check Gamma t) as TO;
  destruct TO as [T|];
  try solve_by_invert; try (inversion H0; eauto); try (subst; eauto).

Ltac analyze T T1 T2 :=
  destruct T as [T1 T2| |T1 T2|T1| |T1 T2]; try solve_by_invert.

Ltac fully_invert_typecheck Gamma t T T1 T2 :=
  let TX := fresh T in
  remember (type_check Gamma t) as TO;
  destruct TO as [TX|]; try solve_by_invert;
  destruct TX as [T1 T2| |T1 T2|T1| |T1 T2];
  try solve_by_invert; try (inversion H0; eauto); try (subst; eauto).

Ltac case_equality S T :=
  destruct (eqb_ty S T) eqn: Heqb;
  inversion H0; apply eqb_ty__eq in Heqb; subst; subst; eauto.

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T ->
  has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - (* var *) rename s into x. destruct (Gamma x) eqn:H.
    rename t into T'. inversion H0. subst. eauto. solve_by_invert.
  - (* app *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    analyze T1 T11 T12.
    case_equality T11 T2.
  - (* abs *)
    rename s into x, t into T1.
    remember (x |-> T1 ; Gamma) as Gamma'.
    invert_typecheck Gamma' t0 T0.
  - (* const *) eauto.
  - (* scc *)
    rename t into t1.
    fully_invert_typecheck Gamma t1 T1 T11 T12.
  - (* prd *)
    rename t into t1.
    fully_invert_typecheck Gamma t1 T1 T11 T12.
  - (* mlt *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    analyze T1 T11 T12; analyze T2 T21 T22.
    inversion H0. subst. eauto.
  - (* test0 *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    invert_typecheck Gamma t3 T3.
    destruct T1; try solve_by_invert.
    case_equality T2 T3.
  - (* inl *)
    rename t into T2.
    invert_typecheck Gamma t0 T1.
  - (* inr *)
    rename t into T1.
    invert_typecheck Gamma t0 T2.
  - (* sum case *)
    invert_typecheck Gamma t1 T12.
    analyze T12 T1 T2.
    rename s into x1. rename s0 into x2.
    rename t1 into t0. rename t2 into t1. rename t3 into t2.
    invert_typecheck (x1 |-> T1; Gamma) t1 HT3.
    invert_typecheck (x2 |-> T2; Gamma) t2 HT3'.
    case_equality HT3 HT3'.
  - (* nil *)
    subst...
  - (* cons *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    analyze T2 T2' T2''.
    case_equality T2' T1.
  - (* tlcase *)
    rename s into x31, s0 into x32.
    fully_invert_typecheck Gamma t1 T1 T11 T12.
    invert_typecheck Gamma t2 T2.
    remember (x31 |-> T11 ; x32 |-> <{{List T11}}> ; Gamma) as Gamma'2.
    invert_typecheck Gamma'2 t3 T3.
    case_equality T2 T3.
  - (* unit *)
    eauto.
  - (* pair *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
  - (* fst *)
    invert_typecheck Gamma t T'.
    analyze T' T'1 T'2.
    inversion H0. subst. eauto.
  - (* snd *)
    invert_typecheck Gamma t T'.
    analyze T' T'1 T'2.
    inversion H0. subst. eauto.
  - (* let *)
    invert_typecheck Gamma t1 T'.
  - (* fix *)
    invert_typecheck Gamma t T'.
    analyze T' T'1 T'2.
    case_equality T'1 T'2.
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T ->
  type_check Gamma t = Some T.
Proof.
  intros Gamma t T Hty.
  induction Hty; simpl;
    try (rewrite IHHty);
    try (rewrite IHHty1);
    try (rewrite IHHty2);
    try (rewrite IHHty3);
    try (rewrite (eqb_ty_refl T0));
    try (rewrite (eqb_ty_refl T1));
    try (rewrite (eqb_ty_refl T2));
    try (rewrite (eqb_ty_refl T3));
    eauto.
  - destruct (Gamma x0); [assumption| solve_by_invert].
  - rewrite eqb_ty_refl.  reflexivity.
Qed.

End TypecheckerExtensions.
(** [] *)

(** **** Exercise: 5 stars, standard, optional (stlc_step_function)

    Above, we showed how to write a typechecking function and prove it
    sound and complete for the typing relation.  Do the same for the
    operational semantics -- i.e., write a _function_ [stepf] of type
    [tm -> option tm] and prove that it is sound and complete with
    respect to [step] from chapter [MoreStlc]. *)

Module StepFunction.
Import MoreStlc.
Import STLCExtended.

Fixpoint valueb (t : tm) : bool :=
  match t with
  | <{\x:T2, t1}> => true
  | tm_const _ => true
  | <{inl _ v}> => valueb v
  | <{inr _ v}> => valueb v
  | <{nil _}> => true
  | <{x :: xs}> => valueb x && valueb xs
  | <{unit}> => true
  | <{(a,b)}> => valueb a && valueb b
  | _ => false
  end.

(* Operational semantics as a Coq function. *)
Fixpoint stepf (t : tm) : option tm :=
  match t with
  | tm_var x => fail
  | <{ \ x1 : T1, t2 }> => fail
  | <{ t1 t2 }> =>
    match valueb t1, valueb t2 with
    | true, true => match t1 with
                   | <{\x1 : T1, t1'}> => Some <{ [x1:=t2]t1' }>
                   | _ => fail
                   end
    | true, false =>
      t2' <- stepf t2 ;; Some <{ t1 t2' }>
    | false, _ =>
      t1' <- stepf t1 ;; Some <{ t1' t2 }>
    end
  | tm_const _ => fail
  | <{ succ t1 }> =>
    match t1 with
    | tm_const n => Some (tm_const (S n))
    | _ => t1' <- stepf t1 ;; Some <{ succ t1' }>
    end
  | <{ pred t1 }> =>
    match t1 with
    | tm_const n => Some (tm_const (n - 1))
    | _ => t1' <- stepf t1 ;; Some <{ pred t1' }>
    end
  | <{ t1 * t2 }> =>
    match valueb t1, valueb t2 with
    | true, true => match t1, t2 with
                   | tm_const n1, tm_const n2 => Some (tm_const (n1 * n2))
                   | _, _ => fail
                   end
    | true, false =>
      t2' <- stepf t2 ;; Some <{ t1 * t2' }>
    | false, _ =>
      t1' <- stepf t1 ;; Some <{ t1' * t2 }>
    end
  | <{(t1,t2)}> =>
    match valueb t1, valueb t2 with
    | false, _ => t1' <- stepf t1 ;; Some <{(t1', t2)}>
    | true, false => t2' <- stepf t2 ;; Some <{(t1, t2')}>
    | _, _ => fail
    end
  | <{ t.fst }> =>
    match stepf t with
    | None => match t with
             | <{(t1,t2)}> => if valueb t1 then
                             if valueb t2 then
                             Some t1
                             else fail
                             else fail
             | _ => fail
             end
    | Some t' => Some <{ t'.fst }>
    end
  | <{ t.snd }> =>
    match stepf t with
    | None => match t with
             | <{(t1,t2)}> => if valueb t1 then
                             if valueb t2 then
                             Some t2
                             else fail
                             else fail
             | _ => fail
             end
    | Some t' => Some <{ t'.snd }>
    end
  | <{ if0 guard then t else f }> =>
    match guard with
    | tm_const 0 => Some t
    | tm_const _ => Some f
    | g => g' <- stepf g ;; Some <{ if0 g' then t else f }>
    end
  | <{ inl T2 t }> => t' <- stepf t ;; Some <{ inl T2 t' }>
  | <{ inr T1 t }> => t' <- stepf t ;; Some <{ inr T1 t' }>
  | <{ case t of | inl x1 => t1 | inr x2 => t2 }> =>
    match stepf t with
    | None => match t with
             | <{ inl T2 t' }> => if valueb t'
                                 then Some <{[x1:=t']t1}>
                                 else fail
             | <{ inr T1 t' }> => if valueb t'
                                 then Some <{[x2:=t']t2}>
                                 else fail
             | _ => fail
             end
    | Some t' => Some <{ case t' of | inl x1 => t1 | inr x2 => t2  }>
    end
  | <{ nil T }> => fail
  | <{ h :: t }> =>
    match valueb h, valueb t with
    | false, _ => h' <- stepf h ;; Some <{ h' :: t }>
    | true, false => t' <- stepf t ;; Some <{ h :: t' }>
    | _, _ => fail
    end
  | <{ case t0 of | nil => t1 | x21 :: x22 => t2 }> =>
    match stepf t0 with
    | None => match t0 with
             | <{ nil _ }> => Some t1
             | <{ h :: t }> => if valueb h then
                             if valueb t then
                             Some <{[x22 := t]([x21 := h]t2)}>
                             else fail
                             else fail
             | _ => fail
             end
    | Some t0' => Some <{ case t0' of | nil => t1 | x21 :: x22 => t2 }>
    end
  | <{ unit }> => fail
  | <{let x=v in t}> =>
    match valueb v with
    | true => Some <{[x:=v]t}>
    | false => v' <- stepf v ;; Some <{let x=v' in t}>
    end
  | <{ fix t }> =>
    match t with
    | <{\xf:T, t}> => Some <{ [xf:=fix (\xf:T, t)]t }>
    | _ => t' <- stepf t ;; Some <{ fix t' }>
    end
  end.

Hint Unfold stepf : core.

Theorem sound_valueb : forall t,
  valueb t = true -> value t.
Proof.
  intro. induction t; intro; eauto; try solve_by_invert.
  - (* cons *)
    inversion H. rewrite andb_true_iff in H1. destruct H1. eauto.
  - (* pair *)
    inversion H. rewrite andb_true_iff in H1. destruct H1. eauto.
Qed.

Theorem complete_valueb : forall t,
  value t -> valueb t = true.
Proof.
  intros. induction H; auto; simpl; rewrite IHvalue1; rewrite IHvalue2; easy.
Qed.

Hint Resolve complete_valueb : core.
Hint Resolve sound_valueb : core.

Theorem no_step_for_values : forall t,
  value t -> stepf t = None.
Proof.
  intros. induction H; auto; simpl;
          try (rewrite IHvalue; auto);
          try (rewrite IHvalue1; rewrite IHvalue2; auto);
          try (apply complete_valueb in H; apply complete_valueb in H0;
               rewrite H; rewrite H0;
               auto).
Qed.

From PLF Require Import MyTactics.

Ltac solve_stepf :=
  repeat (MyTactics.solve_stepf_step tm stepf valueb).

(* Soundness of [stepf]. *)
Theorem sound_stepf : forall t t',
    stepf t = Some t'  ->  t --> t'.
Proof.
  intro.
  induction t; intros t' H; inversion H; clear H; auto.
  (* I intentionally split the cases manually because the proof
   runs for pretty long time and I want to keep track of the progress
   *)
  - (* App *)
    solve_stepf.
  - (* Succ *)
    solve_stepf.
  - (* Pred *)
    solve_stepf.
  - (* Mult *)
    solve_stepf.
  - (* If0 *)
    solve_stepf.
  - (* Inl *)
    solve_stepf.
  - (* Inr *)
    solve_stepf.
  - (* Case Either *)
    solve_stepf.
  - (* Cons *)
    solve_stepf.
  - (* Case List *)
    solve_stepf.
  - (* Pair *)
    solve_stepf.
  - (* Fst *)
    solve_stepf.
  - (* Snd *)
    solve_stepf.
  - (* Let *)
    solve_stepf.
  - (* Fix *)
    solve_stepf.
Qed.

Ltac solve_stepf_converse_step := MyTactics.solve_stepf_converse_step
                                  tm step value stepf valueb
                                  complete_valueb
                                  sound_valueb
                                  no_step_for_values.
Ltac solve_stepf_converse :=
  repeat solve_stepf_converse_step.

(* Completeness of [stepf]. *)
Theorem complete_stepf : forall t t',
    t --> t'  ->  stepf t = Some t'.
Proof.
  intros.
  induction H.
  - (* ST_Abs *)
    solve_stepf_converse.
  - (* ST_App1 *)
    solve_stepf_converse.
  - (* ST_App2 *)
    solve_stepf_converse.
  - (* ST_Succ *)
    solve_stepf_converse.
  - (* ST_SuccNat *)
    solve_stepf_converse.
  - (* ST_Pred *)
    solve_stepf_converse.
  - (* ST_PredNat *)
    solve_stepf_converse.
  - (* ST_Mulconsts *)
    solve_stepf_converse.
  - (* ST_Mult1 *)
    solve_stepf_converse.
  - (* ST_Mult2 *)
    solve_stepf_converse.
  - (* ST_If0 *)
    solve_stepf_converse.
  - (* ST_If0_Zero *)
    solve_stepf_converse.
  - (* ST_If0_Nonzero *)
    solve_stepf_converse.
  - (* ST_Inl *)
    solve_stepf_converse.
  - (* ST_Inr *)
    solve_stepf_converse.
  - (* ST_Case *)
    solve_stepf_converse.
  - (* ST_CaseInl *)
    solve_stepf_converse.
  - (* ST_CaseInr *)
    solve_stepf_converse.
  - (* ST_Cons1 *)
    solve_stepf_converse.
  - (* ST_Cons2 *)
    solve_stepf_converse.
  - (* ST_Lcase1 *)
    solve_stepf_converse.
  - (* ST_LcaseNil *)
    solve_stepf_converse.
  - (* ST_LcaseCons *)
    solve_stepf_converse.
  - (* ST_Pair1 *)
    solve_stepf_converse.
  - (* ST_Pair2 *)
    solve_stepf_converse.
  - (* ST_Fst1 *)
    solve_stepf_converse.
  - (* ST_FstPair *)
    inversion H; subst; solve_stepf_converse.
  - (* ST_Snd1 *)
    solve_stepf_converse.
  - (* ST_SndPair *)
    inversion H; subst; solve_stepf_converse.
  - (* ST_Let1 *)
    solve_stepf_converse.
  - (* ST_LetValue *)
    solve_stepf_converse.
  - (* ST_Fix1 *)
    solve_stepf_converse.
  - (* ST_FixAbs *)
    solve_stepf_converse.
Qed.

End StepFunction.
(** [] *)

(** **** Exercise: 5 stars, standard, optional (stlc_impl)

    Using the Imp parser described in the [ImpParser] chapter
    of _Logical Foundations_ as a guide, build a parser for extended
    STLC programs.  Combine it with the typechecking and stepping
    functions from the above exercises to yield a complete typechecker
    and interpreter for this language. *)

Module StlcImpl.
  Import StepFunction.

  (* I decided not to solve this problem *)

End StlcImpl.
(** [] *)

(* 2020-09-09 21:08 *)