(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_22.

Coq < Goal forall q c b t h:Prop, ((~q -> (c /\ b)) /\ (~t -> (b /\ h)) /\ ~(q /\ t)) -> b.
1 subgoal

  ============================
   forall q c b t h : Prop,
   (~ q -> c /\ b) /\ (~ t -> b /\ h) /\ ~ (q /\ t) -> b

Unnamed_thm < intros.
1 subgoal

  q : Prop
  c : Prop
  b : Prop
  t : Prop
  h : Prop
  H : (~ q -> c /\ b) /\ (~ t -> b /\ h) /\ ~ (q /\ t)
  ============================
   b

Unnamed_thm < elim H.
1 subgoal

  q : Prop
  c : Prop
  b : Prop
  t : Prop
  h : Prop
  H : (~ q -> c /\ b) /\ (~ t -> b /\ h) /\ ~ (q /\ t)
  ============================
   (~ q -> c /\ b) -> (~ t -> b /\ h) /\ ~ (q /\ t) -> b

Unnamed_thm < intro.
1 subgoal

  q : Prop
  c : Prop
  b : Prop
  t : Prop
  h : Prop
  H : (~ q -> c /\ b) /\ (~ t -> b /\ h) /\ ~ (q /\ t)
  H0 : ~ q -> c /\ b
  ============================
   (~ t -> b /\ h) /\ ~ (q /\ t) -> b

Unnamed_thm < intro.
1 subgoal

  q : Prop
  c : Prop
  b : Prop
  t : Prop
  h : Prop
  H : (~ q -> c /\ b) /\ (~ t -> b /\ h) /\ ~ (q /\ t)
  H0 : ~ q -> c /\ b
  H1 : (~ t -> b /\ h) /\ ~ (q /\ t)
  ============================
   b

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
tauto.

Unnamed_thm is defined

Coq <

*)

Require Import Classical.
Section Exercise_22.
Goal forall q c b t h:Prop, ((~q -> (c /\ b)) /\ (~t -> (b /\ h)) /\ ~(q /\ t)) -> b.
intros.
elim H.
intro.
intro.
 tauto.
 Qed.


Require Import Reals.

Require Import OLlibs.List_Type.
Require Import List.

Require Import RL.Utilities.riesz_logic_List_more.
Require Import RL.Utilities.Rpos.
Require Import RL.Utilities.polynomials.

Require Import RL.Utilities.Lim_seq_US.

Require Import Lra.
Require Import Lia.

Require Import Coquelicot.Continuity.
Require Import Coquelicot.Hierarchy.
Require Import Coquelicot.Rcomplements.

Local Open Scope R_scope.

(** Infinitary pigeonhole principle *)
Axiom IPP : forall (u : nat -> nat) m,
    (forall n, u n < m)%nat ->
    {' (phi, i) & prod (subseq_support phi)
                       ((i < m)%nat *
                        (forall n, u (phi n) = i))}.

(** Equivalent definition of the limit on reals *)
Lemma lim_def_eps : forall (u : nat -> R_UniformSpace) (l : R_UniformSpace),
    (forall (eps : posreal), exists N, forall n, (N <= n)%nat -> Rabs (u n - l) < eps) ->
    is_lim_seq u l.
Proof.
  intros u l Hlim.
  intros P [eps H].
  specialize (Hlim eps) as [N Hlim].
  split with N.
  intros n Hle.
  specialize (Hlim n Hle).
  apply H.
  apply Hlim.
Qed.

Lemma lim_def_eps_inv : forall (u : nat -> R_UniformSpace) (l : R_UniformSpace),
    is_lim_seq u l ->
    forall (eps : posreal), exists N, forall n, (N <= n)%nat -> Rabs (u n - l) < eps.
Proof.
  intros u l Hlim eps.
  specialize (Hlim (fun x => Rabs (x - l) < eps)).
  assert (locally l (fun x => Rabs (x - l) < eps)).
  { split with eps.
    intros y Hball; apply Hball. }
  specialize (Hlim H); clear H.
  apply Hlim.
Qed.

(** A bound on the sequence is also a bound on the limit *)
Lemma is_lim_seq_ub : forall (u : nat -> R_UniformSpace) (l : R_UniformSpace) ub,
    is_lim_seq u l ->
    (forall n, u n <= ub) ->
    l <= ub.
Proof.
  intros u l ub Hlim Hle.
  apply le_epsilon.
  intros eps Hpos.
  apply lim_def_eps_inv with _ _ (mkposreal eps Hpos) in Hlim as [N Hlim].
  simpl in Hlim.
  specialize (Hlim N (le_refl N)).
  assert (l - u N < eps).
  { unfold Rabs in Hlim.
    revert Hlim; case (Rcase_abs (u N - l)); lra. }
  specialize (Hle N).
  lra.
Qed.

Lemma is_lim_seq_lb : forall (u : nat -> R_UniformSpace) (l : R_UniformSpace) lb,
    is_lim_seq u l ->
    (forall n, lb <= u n) ->
    lb <= l.
Proof.
  intros u l lb Hlim Hle.
  apply Ropp_le_cancel.
  apply is_lim_seq_ub with (fun n => - u n).
  - intros P Hloc.
    destruct Hloc as [eps Hloc].
    specialize (Hlim (fun x => P ( -x))).
    assert (locally l (fun x => P (- x))).
    { split with eps.
      intros y Hball.
      apply Hloc.
      change (ball (- l) eps (- y)) with (Rabs (- y - (- l)) < eps).
      replace (- y - - l) with (- (y - l)) by lra.
      rewrite Rabs_Ropp.
      apply Hball. }
    specialize (Hlim H); clear H.
    apply Hlim.
  - intros n; specialize (Hle n); lra.
Qed.

(** Returns an antecedent of 1 lower than i if it exists, and 0 otherwise *)
Fixpoint u_n_ante_1 (u : nat -> R) i :=
  match i with
  | 0%nat => 0%nat
  | S i => if (R_eqb (u (S i)) 1) then (S i) else u_n_ante_1 u i
  end.

Lemma u_n_ante_1_lt : forall u i m,
    (i <= m)%nat ->
    (u_n_ante_1 u i < S m)%nat.
Proof.
  intros u i m; induction i; intros Hle.
  - simpl; lia.
  - simpl; case (R_eqb (u (S i)) 1); lia.
Qed.

Lemma u_n_ante_1_correct : forall u m,
    {i & prod (i < (S m))%nat (u i = 1)} ->
    u (u_n_ante_1 u m) = 1.
Proof.
  intros u m; induction m; intros [i [Hlt Heq]].
  - destruct i; [ | exfalso; lia].
    apply Heq.
  - case_eq (i =? S m); intros H; (apply Nat.eqb_eq in H + apply Nat.eqb_neq in H).
    + subst.
      simpl.
      case_eq (R_eqb (u (S m)) 1); intros H1; (apply R_eqb_eq in H1 + apply R_eqb_neq in H1); [ apply H1 | exfalso; lra].
    + assert (i < S m)%nat by lia.
      simpl.
      case_eq (R_eqb (u (S m)) 1); [intros H1; apply R_eqb_eq in H1; apply H1 | intros _].
      apply IHm.
      split with i.
      split; assumption.
Qed.

(** Instantiation of IPP where a sequence of function take the value 1 infinitely often on [0..m], and therefore there is subsequence of function always taking the value 1 on i \in [0..m] *)
Lemma IPP_eq_1 : forall (u : nat -> nat -> R) m,
    (forall n, {i & prod (i < m)%nat (u n i = 1)}) ->
    {' (phi , i) : (nat -> nat) * nat & prod (subseq_support phi)
                                             ((i < m)%nat *
                                              (forall n, u (phi n) i = 1))}.
Proof.
  intros u m H.
  destruct m.
  { specialize (H 0%nat) as [i [Hlt _]].
    exfalso; inversion Hlt. }
  destruct (IPP (fun n => u_n_ante_1 (fun i => u n i) m) (S m)) as [[phi i] [Hsubseq [Hlt Hipp]]].
  - intros n.
    apply u_n_ante_1_lt.
    reflexivity.
  - split with (phi, i).
    repeat split; try assumption.
    intros n; specialize (Hipp n).
    rewrite <- Hipp.
    apply u_n_ante_1_correct.
    apply (H (phi n)).
Qed.

(** A sequence on [lb;ub] has a converging subsequence *)
Axiom SequentialCompactness : forall (u : nat -> R) lb ub,
    (forall n, prod (lb <= u n) (u n <= ub)) ->
    {' (phi , l) & prod (subseq_support phi)
                        (is_lim_seq (fun n => u (phi n)) l)}.

(** A sequence on [lb;ub]^n has a converging subsequence *)
Lemma seq_compact_Rn : forall n lb ub (u : nat -> list R),
    (forall i, length (u i) = n) ->
    (forall i j, (j < n)%nat -> prod (lb <= nth j (u i) 0) (nth j (u i) 0 <= ub)) ->
    {' (phi, ul) & prod (subseq_support phi)
                       ((length ul = n) *
                        (forall j, (j < n)%nat -> is_lim_seq (fun i => nth j (u (phi i)) 0) (nth j ul 0)))}.
Proof.
  enough (forall k n lb ub (u : nat -> list R),
             (k < n)%nat ->
             (forall i, length (u i) = n) ->
             (forall i j, (j < n)%nat -> prod (lb <= nth j (u i) 0) (nth j (u i) 0 <= ub)) ->
             {' (phi, ul) & prod (subseq_support phi)
                                 ((length ul = n) *
                                  (forall j, (j <= k)%nat -> is_lim_seq (fun i => nth j (u (phi i)) 0) (nth j ul 0)))}).
  { intros n lb ub u Hlen Hborned.
    destruct n.
    2:{ destruct (X n (S n) lb ub u (Nat.lt_succ_diag_r n) Hlen Hborned) as [[phi ul] [Hsubseq [Hlenul Hlimul]]].
        split with (phi, ul).
        repeat split; try assumption.
        intros j Hlt.
        apply Hlimul.
        lia. }
    split with (fun x => x, nil).
    repeat split.
    - intros n; lia.
    - intros j Hlt.
      exfalso; lia. }
  induction k; intros n lb ub u Hlt Hlen Hborned.
  - destruct (SequentialCompactness (fun n => nth 0 (u n) 0) lb ub) as [[phi l] [Hsubseq Hlim]].
    { intros i.
      destruct (Hborned i 0%nat); try split; assumption. }
    split with (phi, l :: repeat 0 (n - 1)).
    repeat split; try assumption.
    + simpl; rewrite repeat_length.
      destruct n; [ inversion Hlt | ].
      lia.
    + intros j Hle.
      destruct j; try now inversion Hle.
  - destruct (IHk n lb ub u) as [[phi ul] [Hsubseq [Hlenul Hlimul]]]; try assumption; try lia.
    destruct (SequentialCompactness (fun n => nth (S k) (u (phi n)) 0) lb ub) as [[phi' l] [Hsubseq' Hlim]].
    { intros i.
      destruct (Hborned (phi i) (S k)); try split; assumption. }
    split with (fun i => phi (phi' i), replace ul l (S k)).
    repeat split.
    + intros i.
      apply lt_le_trans with (phi (S (phi' i))).
      * apply Hsubseq.
      * case_eq ((S (phi' i)) =? phi' (S i));
          intros Heq; [ apply Nat.eqb_eq in Heq | apply Nat.eqb_neq in Heq].
        -- subst.
           rewrite Heq.
           reflexivity.
        -- apply Nat.lt_le_incl.
           apply subseq_support_implies_incr; [assumption | ].
           assert (phi' i < phi' (S i))%nat.
           { apply Hsubseq'. }
           lia.
    + rewrite replace_length.
      apply Hlenul.
    + intros j Hle.
      inversion Hle; subst.
      * rewrite replace_nth_eq; try lia.
        eapply is_lim_seq_ext; [ | apply Hlim].
        auto.
      * rewrite replace_nth_neq; try lia.
        apply is_lim_seq_subseq with (fun i => nth j (u (phi i)) 0).
        -- split with phi'.
           split; try assumption.
           intros n.
           reflexivity.
        -- apply Hlimul.
           apply H0.
Qed.

(** Equivalent definition of limit on functions *)
Lemma lim_def_fun_eps {A} : forall (u : nat -> A -> R_UniformSpace) (l : A -> R_UniformSpace),
    (forall (eps : posreal), exists N, forall n, (N <= n)%nat -> forall a, Rabs (u n a - l a) < eps) ->
    is_lim_seq u l.
Proof.
  intros u l Hlim.
  intros P [eps H].
  specialize (Hlim eps) as [N Hlim].
  split with N.
  intros n Hle.
  specialize (Hlim n Hle).
  apply H.
  intros a.
  apply Hlim.
Qed.

Lemma lim_def_fun_eps_inv {A} : forall (u : nat -> A -> R_UniformSpace) (l : A -> R_UniformSpace),
    is_lim_seq u l ->
    forall (eps : posreal), exists N, forall n, (N <= n)%nat -> forall a, Rabs (u n a - l a) < eps.
Proof.
  intros u l Hlim eps.
  specialize (Hlim (fun x => forall a, Rabs (x a - l a) < eps)).
  assert (locally l (fun x => forall a, Rabs (x a - l a) < eps)).
  { split with eps.
    intros y Hball; apply Hball. }
  specialize (Hlim H); clear H.
  apply Hlim.
Qed.


(******************************************************************************)
(* Solutions of exercises : Type inference by canonical structures            *)
(******************************************************************************)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
Require Import choice fintype tuple finset.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(******************************************************************************)
(* Exercise 6.1.1                                                             *)
(******************************************************************************)

Lemma tuto_unit_enumP : Finite.axiom [:: tt]. Admitted.

Definition tuto_unit_finMixin := FinMixin tuto_unit_enumP.
Canonical Structure unit_finType := Eval hnf in FinType unit unit_finMixin.

(******************************************************************************)
(* Exercise 6.1.2                                                             *)
(******************************************************************************)

(* Here we use the multirule rewrite facility: the first rule in the *)
(*list which matches the goal is used. Note that this facility *)
(*complies with the ! and ? multiplicators. *)
Lemma tuto_option_enumP : forall T : finType, Finite.axiom (option_enum T).
Admitted.

(******************************************************************************)
(* Exercise 6.1.3                                                             *)
(******************************************************************************)

Definition tuto_sum_enum (T1 T2 : finType) : seq (T1 + T2) :=
  map (@inl _ _) (Finite.enum T1) ++ map (@inr _ _) (Finite.enum T2).

(* We describe this script as a trace of the search for the proof.
   Note that the view mechanism used in apply/hasP complies with *)
(*negation. The first subgoal is trivial because of the equality
   between applied constructors inl and inr. (discriminate). For the
   two last subgoals, remember the [] casing intropattern perfroms an
   injection on equalities *)
Lemma tuto_sum_enum_uniq : forall T1 T2, uniq (sum_enum T1 T2).
Admitted.

(* here is the clean script resulting from the proevious one *)

Lemma tuto_sum_enum_uniq_clean : forall T1 T2, uniq (sum_enum T1 T2).
Admitted.

(******************************************************************************)
(* Exercise 6.1.4                                                             *)
(******************************************************************************)

Check UniqFinMixin.

Definition tuto_prod_enum (T1 T2 : finType) : seq (T1 * T2) :=
  foldr (fun x1 => cat (map (pair x1) (enum T2))) [::] (enum T1).

Lemma prod_enum_uniq : forall T1 T2, uniq (tuto_prod_enum T1 T2).
Admitted.

(******************************************************************************)
(* Exercise 6.1.5                                                             *)
(******************************************************************************)

Section OpsTheory.

Variable T : finType.

Implicit Types A B C P Q : pred T.
Implicit Types x y : T.
Implicit Type s : seq T.

Lemma card0 : #|@pred0 T| = 0.
Admitted.

Lemma cardT : #|T| = size (enum T).
Admitted.

Lemma card1 : forall x, #|pred1 x| = 1.
Admitted.

Lemma tuto_pred0P : forall P, reflect (P =1 pred0) (pred0b P).
Admitted.

(******************************************************************************)
(* Exercise 6.1.6                                                             *)
(******************************************************************************)

Lemma tuto_cardUI : forall A B, #|[predU A & B]| + #|[predI A & B]| = #|A| + #|B|.
Admitted.

Lemma tuto_eq_card : forall A B, A =i B -> #|A| = #|B|.
Admitted.

(******************************************************************************)
(* Exercise 6.1.7                                                             *)
(******************************************************************************)

Lemma tuto_disjoint0 : forall A, [disjoint pred0 & A].
Admitted.

(* The congr tactic applies a congruence reasoning of the form *)
(* \overline{x} = \overline{y} -> f \overline{x} = f \overline{y}, *)
(* where f can be an n-ary function. It generates as many subgoals as *)
(* non-trivial pairwise equality between the arguments of f *)
Lemma tuto_disjoint_sym : forall A B, [disjoint A & B] = [disjoint B & A].
Admitted.

(* This is a difficult proof...And we need to investigate how disjoint is *)
(* defined. We see that its is defined using pred0b. *)
Search _ "disjoint _ & _".
Print disjoint.

(* We first start a case analysis on the fact that [predI A & C] is empty *)
(* or not. *)

(* Then, one of the main trick is to avoid using congruence with pred0b, but *)
(* with == 0. Indeed, using congruence with pred0b would amount to prove *)
(* that some characteristic functions are (Leibniz) equal when they are *)
(* only extentionaly equal... *)
(* In the first subgoal, we use the ssreflect syntax to replace a subterm by a *)
(*convertible one: rewrite -[t1]/t2, where t1 is the term (or the *)
(*pattern) present in the goal and t2 the convertible counterpart. *)
(* We also use a declarative step suff, together with the -> *)
(* intropattern, which rewrites the lemms instead of introducing it *)
(* Finally, we use the move/(_ x) tactic, which specializes a *)
(* universally quantified assumption to a particular value *)
(* In the second subgoal, we use the negative counterpart of pred0P, *)
(* namely pred0Pn. Again there is no specific lemma on [predU _ & _] *)
(* and [predI _ & _], since there are in fact only boolean disjunctions *)
(* and conjunctions. Some rewrite steps might make the collective \in *)
(*momentarily disappear, replaced by the generic mem applicative *)
(*membership predicate. In that case, a simplification \= should put *)
(*back everything in order.*)

Lemma tuto_disjointU : forall A B C,
  [disjoint predU A B & C] = [disjoint A & C] && [disjoint B & C].
Admitted.

(******************************************************************************)
(* Exercise 6.1.8                                                             *)
(******************************************************************************)

(* It can be usefull to browse the ssrbool library and/or to use the *)
(*Search command to find the most convenient reflexion lemmas, like *)
(*negbFE in this case *)
Lemma tuto_subsetP : forall A B,
  reflect {subset A <= B} (A \subset B).
Admitted.

Lemma tuto_subsetPn : forall A B,
  reflect (exists2 x, x \in A & x \notin B) (~~ (A \subset B)).
Admitted.

Lemma tuto_subset_eqP : forall A B,
  reflect (A =i B) ((A \subset B) && (B \subset A)).
Admitted.

(* In this proof, the tactic case/idP: (ltnn #|A|) on a False goal *)
(* proves false from (ltnn #|A|) := #|A| < #|A| = false, and generates *)
(*a new subgoal to prove that the current context implies  #|A| < #|A| *)
Lemma tuto_subset_cardP : forall A B,
  #|A| = #|B| -> reflect (A =i B) (A \subset B).
Admitted.

End OpsTheory.

(******************************************************************************)
(* Exercise 6.1.9                                                             *)
(******************************************************************************)

Section Quantifiers.

Variable T : finType.
Variable P : pred T.

Lemma tuto_existsP : reflect (exists x, P x) (existsb x, P x).
Admitted.

Lemma tuto_forallP : reflect (forall x, P x) (forallb x, P x).
Admitted.

Lemma tuto_negb_forall :  ~~ (forallb x, P x) = (existsb x, ~~ P x).
Admitted.

Lemma tuto_negb_exists : ~~ (existsb x, P x) = (forallb x, ~~ P x).
Admitted.

End Quantifiers.
(******************************************************************************)
(* Exercise 6.1.10                                                            *)
(******************************************************************************)

Section Extremas.

Variable T : finType.
Variable P : pred T.
Variable F : T -> nat.

(* P is non empty *)
Variable i0 : T.
Hypothesis Pi0 : P i0.

(* The small scale reflection methodology leads to defining boolean *)
(*predicates as often as possible *)

(* We hence first define a boolean predicate characterizing an *)
(*extremum of F for the arbirary boolean relation ord *)

(* We use here the ssreflect notation to define predicates :
[pred i | p i] defines the predicate (i => p i) *)

(* We also use the boolean implication ==> *)
Definition is_extremum ord :=
  [pred i | P i && forallb x, P x ==> ord (F i) (F x)].

(* Now let's characterize the notion of extremum in a logical (Prop) *)
(*way *)
Inductive extremum_spec (ord : rel nat) : T -> Prop :=
  ExtremumSpec i of P i & (forall j, P j -> ord (F i) (F j))
  : extremum_spec ord i.

(* Being minimimum for F is being extremum for leq *)
Definition is_min := is_extremum leq.

(* Being maxmimum for F is being extremum for geq *)
Definition is_max := is_extremum geq.

(* Now the pick function extracts a witness for a given predicates, *)
(*under the form of an option type. The odflt operator lifts an *)
(*element of the option type (option T) back to T by assigning a *)
(*default value to None. Here the default value is i0, the *)
(*nonemptiness witness *)
Definition Fmin := odflt i0 [pick x | is_min x].

Definition Fmax := odflt i0 [pick x | is_max x].

(* Let us prove that Fmin is an extremum for leq *)
(* The specification of the pick operation is pickP *)
(* The specification of the ex_minn operation is ex_minnP. Applying it *)
(*to a proof that a nat predicates is non empty generates the value *)
(*and its minimality property *)
Lemma Fmin_correct : extremum_spec leq Fmin.
Admitted.

(* here we need to show that F is bounded on T. In fact, the explicit *)
(* value of the maximum of F on the whole finType T can be computed by *)
(*iterating the binary  maximum operator maxn on the enumeration of *)
(*the elements of T. We show that it is a correct bound by induction *)
(*on the list enumerating the lements of T *)

Lemma Fmax_correct : extremum_spec geq Fmax.
Admitted.

End Extremas.
(******************************************************************************)
(* Exercise 6.1.11 to 6.1.21                                                  *)
(******************************************************************************)

(* The solution is the begining of the path.v file. Copy and play... *)

(******************************************************************************)
(* Exercise 6.2.1                                                             *)
(******************************************************************************)

Section Def.

Variable n : nat.
Variable T : Type.
(* The coercion is defined on the fly by the :> mark *)
Structure tuto_tuple_of  : Type :=
  TutoTuple {tuto_tval :> seq T; _ : size tuto_tval == n}.

Canonical Structure tuple_subType :=
  Eval hnf in [subType for tuto_tval by tuto_tuple_of_rect].

End Def.

Canonical Structure nil_tuto_tuple (T : Type) :=
   TutoTuple (erefl _ : @size T [::] == 0).

Canonical Structure cons_tuto_tuple n T x (t : tuto_tuple_of n T) :=
   TutoTuple (valP t : size (x :: t) == n.+1).

Lemma tuto_cat_tupleP : forall T n1 n2 (t1 : n1.-tuple T) (t2 : n2.-tuple T),
  size (t1 ++ t2) == n1 + n2.
Admitted.
Canonical Structure cat_tuple T n1 n2 t1 t2 := Tuple (@cat_tupleP T n1 n2 t1 t2).

Lemma drop_tupleP : forall T n m (t : n.-tuple T), size (drop m t) == n - m.
Admitted.

Canonical Structure drop_tuple T n m t := Tuple (@drop_tupleP T n m t).

Lemma take_tupleP : forall T n m (t : n.-tuple T), size (take m t) == minn m n.
Admitted.

Canonical Structure take_tuple T n m t := Tuple (@take_tupleP T n m t).

Lemma rot_tupleP : forall T n m (t : n.-tuple T), size (rot m t) == n.
Admitted.

Canonical Structure rot_tuple T n m t := Tuple (@rot_tupleP T n m t).

(******************************************************************************)
(* Exercise 6.2.1                                                             *)
(******************************************************************************)

Section TuplesExercises.

(* Note that this time we need a finType, so that cardinality is well *)
(*defined *)
Variables (T : finType)(n : nat).

Lemma tuto_size_tuple : forall (t : n.-tuple T), size t = n.
Admitted.

Lemma leq_card_tuple : forall (t : n.-tuple T), #|t| <= n.
Admitted.

Lemma uniq_card_tuple : forall (t : n.-tuple T), uniq t -> #|t| = n.
Admitted.

Search _"'I_ _".
Print ordinal.

(* The subtype is defined by:

Section OrdinalSub.

Variable n : nat.

Inductive ordinal : predArgType := Ordinal m of m < n.

Canonical Structure ordinal_subType :=
  [subType for nat_of_ord by ordinal_rect].

End OrdinalSub.
*)

Lemma tuto_tnth_nth : forall (x : T) (t : n.-tuple T) i, tnth t i = nth x t i.
Admitted.

(******************************************************************************)
(* Exercise 6.2.3                                                             *)
(******************************************************************************)

(* A first possibility uses the constructor of the ordinal inductive *)
(* type *)

Definition two := Ordinal (ltnSn 2).
Check two.
Eval compute in (val two).

(* Orelse we can cast the definition with the expected type and use *)
(*the generic subType constructor Sub *)
Definition two' : 'I_3 := Sub 2 (ltnSn 3).
Check two'.
Eval compute in (val two').

(* But in fact we only need to claim that the boolean test will *)
(*evaluate to true, and let the system check that for us *)
Definition two'' : 'I_3 := Sub 2 (refl_equal true).
Check two''.
Eval compute in (val two'').

Inductive odds : Set := Odds x of (odd x).

(* As opposed to the tuple case, this time the function from odds to *)
(*the type it should be a subtype of has to be defined manually*)
Definition nat_of_odds i := let: Odds m _ := i in m.

(* And now the subType definition, which should declared as canonical *)
Canonical Structure odds_subType :=
  Eval hnf in [subType for nat_of_odds by odds_rect].

(* Check that this require a canonical structure by replacing above
Canonical Structure odds_subType := by Definition .... := *)
Definition three : odds := Sub 3 (refl_equal true).

(******************************************************************************)
(* Exercise 6.2.4                                                             *)
(******************************************************************************)

(* WARNING : to be effective when the library where they are defined *)
(*is loaded, canonical structures should be defined (or re-defined) *)
(*outside sections... *)
Definition odds_eqMixin := Eval hnf in [eqMixin of odds by <:].

Canonical Structure odds_eqType := Eval hnf in EqType odds odds_eqMixin.

Definition tuto_tuple_eqMixin := Eval hnf in [eqMixin of n.-tuple T by <:].

Canonical Structure tuto_tuple_eqType :=
  Eval hnf in EqType (n.-tuple T) tuto_tuple_eqMixin.

Lemma tuto_map_tnth_enum : forall (t : n.-tuple T),
   map (tnth t) (enum 'I_n) = t.
Admitted.

Lemma tuto_eq_from_tnth : forall (t1 t2 : n.-tuple T),
  tnth t1 =1 tnth t2 -> t1 = t2.
Admitted.

End TuplesExercises.

(******************************************************************************)
(* Exercise 6.3.1                                                             *)
(******************************************************************************)

Section setOpsExos.

Variable T : finType.

Implicit Types a x : T.
Implicit Types A B C D : {set T}.

Lemma tuto_eqEsubset : forall A B,
   (A == B) = (A \subset B) && (B \subset A).
Admitted.

Lemma tuto_set1P : forall x a, reflect (x = a) (x \in [set a]).
Admitted.

Lemma tuto_setD1P : forall x A b,
  reflect (x != b /\ x \in A) (x \in A :\ b).
Admitted.

Lemma tuto_setIA : forall A B C, A :&: (B :&: C) = A :&: B :&: C.
Admitted.

Lemma tuto_setUIl : forall A B C,
   (A :&: B) :|: C = (A :|: C) :&: (B :|: C).
Admitted.

Lemma tuto_setCU : forall A B, ~: (A :|: B) = ~: A :&: ~: B.
Admitted.

End setOpsExos.

(******************************************************************************)
(* Exercise 6.3.2                                                             *)
(******************************************************************************)

Section MinSet.

Variable T : finType.
Notation sT := {set T}.

Implicit Types A B C : sT.
Implicit Type P : pred sT.

Definition tuto_minset P A :=
  forallb B : sT, (B \subset A) ==> ((B == A) == P B).

Lemma tuto_minset_eq : forall P1 P2 A,
  P1 =1 P2 -> minset P1 A = minset P2 A.
Admitted.

Lemma tuto_minsetP : forall P A,
reflect ((P A) /\ (forall B, P B -> B \subset A -> B = A))
       (minset P A).
Admitted.

Lemma tuto_minsetp : forall P A, minset P A -> P A.
Admitted.

Lemma tuto_minsetinf : forall P A B,
  minset P A -> P B -> B \subset A -> B = A.
Admitted.

Lemma tuto_ex_minset : forall P, (exists A, P A) -> {A | minset P A}.
Admitted.

Lemma tuto_minset_exists : forall P C,
   P C -> {A | minset P A & A \subset C}.
Admitted.

End MinSet.


(** Saturated sets constructions related to natural numbers: interpreting constructors,
    dependent pattern-matching and fixpoint. Does not support size annotations because
    the definition of (fNAT k) requires that the branch associated to the successor
    has to be defined for *all* numbers, not just those smaller than k. *)

Set Implicit Arguments.
Require Import basic Lambda Can Sat.
Require Import Models.

(** An abstract strong normalization model of natural numbers, set-
    theoretical interpretation. *)
Module Type SimpleNats (Import S:Sets).

  (** N is the type of natural numbers including neutral values.
      Nbot is a decidable subet of N. *)
  Parameter N Nbot : X.
  Parameter N_Nbot : N ⊆ Nbot.
  Parameter Ndec : forall n, n ∈ Nbot -> n∈N \/ ~n∈N.

  Parameter zero : X.
  Parameter succ : X -> X.
  Parameter succ_morph : Proper (eqX==>eqX) succ.
  Existing Instance succ_morph.

  (** Constructors produce non-neutral values *)
  Parameter zero_typ : zero ∈ N.
  Parameter succ_typ : forall n, n ∈ Nbot -> succ n ∈ N.
End SimpleNats.

(** A functor producing the realizability familes associated to natural
    numbers, given the set-theoretical intrepretation. *)
Module Make (Import S:Sets)(Import N:SimpleNats S).

(** Quantification over families *)
Definition piFAM F :=
  depSAT (fun P:X->SAT => Proper (eqX==>eqSAT)P) F.

Lemma piFAM_ax t F :
  inSAT t (piFAM F) <-> forall P, Proper (eqX==>eqSAT)P->inSAT t (F P).
split; intros.
 apply depSAT_elim with (1:=H)(x:=P)(2:=H0).

 apply depSAT_intro; auto.
 apply sat_sn with (F (fun _ => snSAT)).
 apply H.
 do 2 red; reflexivity.
Qed.

Instance piFAM_morph : Proper (((eqX==>eqSAT)==>eqSAT)==>eqSAT) piFAM.
do 2 red; intros.
apply interSAT_morph.
apply indexed_relation_id; intros (P,Pm); simpl; auto.
Qed.

(** * Functional applying constructors of Nat to A *)

Definition fNAT (A:X->SAT) (k:X) :=
  piFAM(fun P =>
        prodSAT (P zero)
       (prodSAT (depSAT (fun n => n ∈ Nbot) (fun n => prodSAT (A n) (prodSAT (P n) (P (succ n)))))
                (P k))).

Instance fNAT_morph : Proper ((eqX==>eqSAT)==>eqX==>eqSAT) fNAT.
do 3 red; intros.
apply piFAM_morph.
red; intros.
apply prodSAT_morph.
 apply H1; reflexivity.

 apply prodSAT_morph; auto.
 apply interSAT_morph.
 apply indexed_relation_id; intros.
 apply prodSAT_morph; auto with *.
 apply prodSAT_morph; auto with *.
Qed.

Lemma fNAT_def t A k :
  inSAT t (fNAT A k) <->
  forall P f g,
  Proper (eqX==>eqSAT) P ->
  inSAT f (P zero) ->
  inSAT g (depSAT(fun n=>n ∈ Nbot)(fun n => prodSAT (A n) (prodSAT (P n) (P (succ n))))) ->
  inSAT (App2 t f g) (P k).
intros.
unfold fNAT.
rewrite piFAM_ax.
apply fa_morph; intros P.
split; intros.
 apply prodSAT_elim with (2:=H1) in H; trivial.
 apply prodSAT_elim with (1:=H); trivial.

 apply prodSAT_intro'; intros f satf.
 apply prodSAT_intro'; intros g satg.
 apply H; trivial.
Qed.

Lemma fNAT_mono A B :
  (forall k, k ∈ Nbot -> inclSAT (A k) (B k)) ->
  forall k, inclSAT (fNAT A k) (fNAT B k).
unfold fNAT; intros.
apply interSAT_mono; intro P.
apply prodSAT_mono; auto with *.
apply prodSAT_mono; auto with *.
apply interSAT_mono; intros (n,tyn); simpl.
apply prodSAT_mono; auto with *.
apply H; trivial.
Qed.

(** * Realizability relation of Nat: fixpoint of fNAT *)

(** cNAT is the intersection of all families that are post-fixpoint (that is,
    P s.t. fNAT P included in P). Here we require k to be well-typed (k ∈ N),
    but we could do otherwise. Note that k∈N instead of k∈Nbot ensures that
    cNAT is neuSAT for neutral values. *)
Definition cNAT n :=
  depSAT (fun P => Proper (eqX==>eqSAT) P /\
                   forall k, k ∈ N -> inclSAT (fNAT P k) (P k)) (fun P => P n).

Instance cNAT_morph : Proper (eqX==>eqSAT) cNAT.
do 2 red; intros.
apply interSAT_morph.
apply indexed_relation_id; intros (P,(Pm,Pind)); simpl; auto.
Qed.

Lemma cNAT_post k :
  k ∈ N ->
  inclSAT (fNAT cNAT k) (cNAT k).
intros tyk t tsat.
unfold cNAT.
apply depSAT_intro; intros.
 apply sat_sn in tsat; trivial.

 apply H; trivial.
 revert t tsat.
 apply fNAT_mono.
 clear k tyk; intros k tyk t tsat.
 eapply depSAT_elim with (F:=fun P => P k); [apply tsat|].
 exact H.
Qed.

Definition fNAT' A k := condSAT (k∈N) (fNAT A k).

Lemma cNAT_pre_strict k :
  k ∈ N ->
  inclSAT (cNAT k) (fNAT cNAT k).
intros tyk t tsat.
apply condSAT_smaller with (P:=k ∈ N).
eapply depSAT_elim
 with (F:=fun P => P k) (1:=tsat) (x:=fNAT' cNAT).
split.
 do 2 red; intros; apply condSAT_morph.
  rewrite H; reflexivity.
 apply fNAT_morph; trivial; apply cNAT_morph.

 clear; intros k tyk.
 transitivity (fNAT cNAT k).
  apply fNAT_mono; clear; intros k tyk.
  destruct Ndec with (1:=tyk) as [tyk'|tyk'].
   unfold fNAT'; rewrite condSAT_ok; auto.
   apply cNAT_post; trivial.

   apply condSAT_neutral; trivial.

   unfold fNAT'; rewrite condSAT_ok; auto with *.
Qed.

Lemma cNAT_out k S :
  ~ k ∈ N ->
  inclSAT (cNAT k) S.
intros notn t tsat.
unfold cNAT, depSAT in tsat.
pose (P:= fun k => condSAT (k∈N) (cNAT k)).
assert (Pm : Proper (eqX==>eqSAT) P).
 do 2 red; intros.
 apply condSAT_morph.
  rewrite H; reflexivity.
  apply cNAT_morph; trivial.
assert (Ppost:forall k, k ∈ N -> inclSAT (fNAT P k) (P k)).
 clear.
intros.
 transitivity (fNAT cNAT k).
  apply fNAT_mono; clear; intros k tyk.
  unfold P.
  apply condSAT_smaller.

  red; intros; unfold P.
  rewrite condSAT_ok; trivial.
  apply cNAT_post; trivial.
specialize interSAT_elim with (1:=tsat)
    (x:=exist (fun P=>Proper(eqX==>eqSAT)P/\
                forall k,k∈N->inclSAT(fNAT P k)(P k)) P (conj Pm Ppost)).
simpl.
apply condSAT_neutral; red; auto with *.
Qed.

Lemma cNAT_pre k :
  k ∈ Nbot ->
  inclSAT (cNAT k) (fNAT cNAT k).
intros tyk t tsat.
destruct Ndec with (1:=tyk).
 apply cNAT_pre_strict; trivial.

 revert tsat; apply cNAT_out; trivial.
Qed.

(** Fixpoint equation *)
Lemma cNAT_eq : forall k, k ∈ N -> eqSAT (cNAT k) (fNAT cNAT k).
split.
 apply cNAT_pre; apply N_Nbot; trivial.
 apply cNAT_post; trivial.
Qed.

(** * Constructors *)

(** Interp of 0 *)
Definition ZE := Abs (Abs (Ref 1)).

Lemma ZE_iota t1 t2 :
  redp (App2 ZE t1 t2) t1.
unfold ZE.
eapply t_trans;[apply redp_app_l;apply t_step;apply red1_beta; reflexivity|].
unfold subst; simpl.
apply t_step.
apply red1_beta.
unfold subst; rewrite simpl_subst; trivial.
rewrite lift0; trivial.
Qed.

Lemma fNAT_ZE : forall A, inSAT ZE (fNAT A zero).
intros.
rewrite fNAT_def; intros.
unfold ZE.
eapply inSAT_context.
 intros.
 apply inSAT_exp; auto.
 exact H2.
unfold subst; simpl subst_rec.
apply inSAT_exp.
 apply sat_sn in H1; auto.
unfold subst; rewrite simpl_subst; auto.
rewrite lift0; auto.
Qed.

(** ZE realizes 0 *)
Lemma cNAT_ZE : inSAT ZE (cNAT zero).
rewrite cNAT_eq.
 apply fNAT_ZE.

 apply zero_typ.
Qed.

(** Interp of successor. Unlike in system F the function corresponding to the successor
    expects two arguments: the predecessor and the usual result of recursive call.
    S(n) is (fun f g => g n (n f g)) instead of the usual (fun f g => g (n f g)).
 *)

Definition SU := Abs (Abs (Abs
    (App2 (Ref 0) (Ref 2) (App2 (Ref 2) (Ref 1) (Ref 0))))).

Lemma SU_iota n t1 t2 :
  redp (App2 (App SU n) t1 t2) (App2 t2 n (App2 n t1 t2)).
unfold SU.
eapply t_trans.
 do 2 apply redp_app_l.
 apply t_step; apply red1_beta; reflexivity.
unfold subst; simpl.
eapply  t_trans.
 apply redp_app_l.
 apply t_step; apply red1_beta; reflexivity.
unfold subst; simpl.
rewrite simpl_subst; auto.
apply t_step; apply red1_beta.
unfold subst; simpl.
rewrite simpl_subst; auto.
rewrite simpl_subst; auto.
do 3 rewrite lift0.
reflexivity.
Qed.

Lemma fNAT_SU : forall A n t,
  n ∈ Nbot ->
  inSAT t (A n) ->
  inSAT t (fNAT A n) ->
  inSAT (App SU t) (fNAT A (succ n)).
intros A n t nty H H0.
unfold SU.
apply inSAT_exp;[auto|].
unfold subst; simpl subst_rec.
rewrite fNAT_def; intros.
eapply inSAT_context.
 intros.
 apply inSAT_exp; [right|].
  apply sat_sn in H2; trivial.
  eexact H4.
unfold subst; simpl subst_rec.
apply inSAT_exp; auto.
unfold subst; simpl subst_rec.
repeat rewrite simpl_subst; auto.
repeat rewrite lift0.
apply prodSAT_elim with (P n).
 apply prodSAT_elim with (2:=H).
 eapply (depSAT_elim _ H3); trivial.

 rewrite fNAT_def in H0.
 apply H0; trivial.
Qed.

(** SU realizes the successor *)
Lemma cNAT_SU n t :
  n ∈ Nbot ->
  inSAT t (cNAT n) ->
  inSAT (App SU t) (cNAT (succ n)).
intros.
rewrite cNAT_eq.
 apply fNAT_SU; trivial.
 apply cNAT_pre; trivial.

 apply succ_typ; trivial.
Qed.

End Make.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Typing
        Infrastructure
        Subtyping_inversion
        Key_Properties
        Deterministic
        rules_inf2
        dunfield.

Require Import Lia.

Lemma open_dexp_eqn_aux :
                forall ee1 ee2 x n,
       x `notin` fv_dexp ee1 ->
       x `notin` fv_dexp ee2 ->
       open_dexp_wrt_dexp_rec n (de_var_f x) ee1 = open_dexp_wrt_dexp_rec n (de_var_f x) ee2
       -> ee1 = ee2.
Proof.
  apply_mutual_ind dexp_mutind;
  apply_mutual_ind dexp_mutind;
  default_simp;
  try solve [eapply_first_hyp; eauto].
  lia.
Qed.

Lemma open_dexp_eqn : forall x ee1 ee2,
       x `notin` fv_dexp ee1 ->
       x `notin` fv_dexp ee2 ->
       open_dexp_wrt_dexp ee1 (de_var_f x) = open_dexp_wrt_dexp ee2 (de_var_f x)
       -> ee1 = ee2.
Proof.
  intros x ee1 ee2 H H0 H1.
  unfold open_dexp_wrt_dexp in H1.
  pose proof open_dexp_eqn_aux.
  eauto.
Qed.

Lemma subtyping_completeness : forall A B,
    isub A B -> sub A B.
Proof.
  intros A B H.
  induction* H.
Qed.

Lemma disjoint_completeness : forall A B,
    icfpDisjoint A B -> disjointSpec A B.
Proof.
  intros A B H. apply disjoint_eqv.
  induction~ H.
  (* H: icfpDisjointAx A B *)
  induction~ H.
  (* symm case *)
  applys~ disjoint_symmetric.
Qed.

(* completeness of typing with respect to the extended
 bidirectional type system in ICFP 2016 *)
Theorem typing_completeness : forall G ee dir A e,
    IBTyping G ee dir A e -> Typing G e dir A.
Proof.
  intros G ee dir A e Typ.
  induction* Typ.
Qed.


(*
(C) Copyright 2010, COQTAIL team

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

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

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

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

(** Properties of real functions sequences. *)

Require Import Reals.
Require Import RFsequence.
Require Import Lra.
Require Import Max.

Open Scope R_scope.

(* begin hide *)
Lemma ub_lt_2_pos : forall x ub lb, lb < x -> x < ub -> 0 < (ub-lb)/2.
Proof.
intros x ub lb lb_lt_x x_lt_ub.
 assert (T : 0 < ub - lb).
  lra.
 unfold Rdiv ; apply Rlt_mult_inv_pos ; intuition.
Qed.

Definition mkposreal_lb_ub : forall (x lb ub:R) (lb_lt_x:lb<x) (x_lt_ub:x<ub), posreal.
intros x lb ub lb_lt_x x_lt_ub.
 apply (mkposreal ((ub-lb)/2) (ub_lt_2_pos x ub lb lb_lt_x x_lt_ub)).
Defined.
(* end hide *)

Lemma RFseq_cvu_derivable : forall (fn fn':nat -> R -> R) (f g:R->R)
      (x lb ub:R) (lb_lt_x:lb < x) (x_lt_ub:x < ub),
      (forall (x:R) (n:nat), lb < x -> x < ub -> derivable_pt_lim (fn n) x (fn' n x)) ->
      (RFseq_cv_interv fn f lb ub) ->
      (RFseq_cvu fn' g ((lb + ub)/2) (mkposreal_lb_ub x lb ub lb_lt_x x_lt_ub)) ->
      (forall (x:R), lb < x -> x < ub -> continuity_pt g x) ->
      derivable_pt_lim f x (g x).
Proof.
intros fn fn' f g x lb ub lb_lt_x x_lt_ub Dfn_eq_fn' fn_CV_f fn'_CVU_g g_cont eps eps_pos.
 assert (eps_8_pos : 0 < eps / 8) by lra.
 destruct (g_cont x lb_lt_x x_lt_ub (eps/8)%R eps_8_pos) as (delta1, Hdelta1) ; clear g_cont ;
 destruct Hdelta1 as (delta1_pos, g_cont).
 assert (delta_pos : 0 < Rmin (Rmin ((x-lb)/2) ((ub-x)/2)) delta1).
  apply Rmin_pos ; [apply Rmin_pos | intuition] ; unfold Rdiv ;
  apply Rlt_mult_inv_pos ; intuition ; apply Rlt_Rminus ; intuition.
 pose (delta := mkposreal (Rmin (Rmin ((x-lb)/2) ((ub-x)/2)) delta1) (delta_pos)).
 exists delta ; intros h h_neq h_ub.
 assert (eps'_pos : 0 < (Rabs h) * eps / 4).
  unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat.
  apply Rabs_pos_lt ; assumption.
  lra.
 elim (fn_CV_f x lb_lt_x x_lt_ub ((Rabs h) * eps / 4)%R eps'_pos) ; intros N2 fnx_CV_fx.
 assert(lb_lt_xh : lb < x + h).
  apply Rlt_trans with (x - delta)%R.
  unfold delta.
  assert (Temp : forall a b c, a + c < b -> a < b - c).
   intros ; lra.
  apply Temp ; clear Temp ; apply Rle_lt_trans with (lb + Rmin ((x - lb) / 2) ((ub - x) / 2))%R.
  apply Rplus_le_compat_l ; apply Rmin_l.
  apply Rle_lt_trans with (lb + (x - lb) / 2)%R.
  apply Rplus_le_compat_l ; apply Rmin_l.
  replace (lb + (x - lb) / 2) with ((lb + x)/2) by field.
  assert (Temp : forall a b, a < b -> (a+b)/2 < b).
   clear ; intros a b a_lt_b.
   unfold Rdiv ; rewrite Rmult_plus_distr_r.
   lra.
  apply Temp ; assumption.
  apply Rplus_lt_compat_l.
  exact (proj2 (Rabs_def2 h delta h_ub)).
 assert(xh_lt_ub : x + h < ub).
  apply Rlt_trans with (x + delta).
  apply Rplus_lt_compat_l.
  exact (proj1 (Rabs_def2 h delta h_ub)).
  unfold delta.
  apply Rle_lt_trans with (x + Rmin ((x - lb) / 2) ((ub - x) / 2)).
  apply Rplus_le_compat_l ; apply Rmin_l.
  apply Rle_lt_trans with (x + (ub - x) / 2).
  apply Rplus_le_compat_l ; apply Rmin_r.
  replace (x + (ub - x) / 2) with ((ub + x)/2) by field.
  assert (Temp : forall a b, a < b -> (b+a)/2 < b).
   clear ; intros a b a_lt_b.
   unfold Rdiv ; rewrite Rmult_plus_distr_r.
   lra.
  apply Temp ; assumption.
 elim (fn_CV_f (x+h) lb_lt_xh xh_lt_ub ((Rabs h) * eps / 4) eps'_pos) ;
 clear fn_CV_f ; intros N1 fnxh_CV_fxh.
 elim (fn'_CVU_g (eps/8) eps_8_pos) ; intros N3 fn'c_CVU_gc.
 pose (N := max (max N1 N2) N3).
 assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn N x - h * (g x))) < (Rabs h)*eps).
 apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h) - (f x - fn N x)) +  Rabs ((fn N (x + h) - fn N x - h * g x))).
 apply Rabs_triang.
 apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h)) + Rabs (- (f x - fn N x)) + Rabs (fn N (x + h) - fn N x - h * g x)).
 apply Rplus_le_compat_r ; apply Rabs_triang.
 rewrite Rabs_Ropp.
 case (Rlt_le_dec h 0) ; intro sgn_h.
 assert (pr1 : forall c : R, x + h < c < x -> derivable_pt (fn N) c).
  intros c c_encad ; unfold derivable_pt.
  assert (lb_lt_c : lb < c).
   apply Rlt_trans with (x+h) ; intuition.
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with x ; intuition.
  exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
 assert (pr2 : forall c : R, x + h < c < x -> derivable_pt id c).
  intros c c_encad ; apply derivable_id.
 assert (xh_x : x+h < x).
  lra.
 assert (pr3 : forall c : R, x + h <= c <= x -> continuity_pt (fn N) c).
  intros c c_encad ; apply derivable_continuous_pt.
  exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
  apply Rlt_le_trans with (x+h) ; intuition.
  apply Rle_lt_trans with x ; intuition.
 assert (pr4 : forall c : R, x + h <= c <= x -> continuity_pt id c).
  intros c c_encad ; apply derivable_continuous ; apply derivable_id.
 elim (MVT (fn N) id (x+h) x pr1 pr2 xh_x pr3 pr4) ; intros c Hc ; elim Hc ; clear Hc ; intros P Hc.
 assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = (fn N (x+h) - fn N x)).
  apply Rmult_eq_reg_l with (-1).
  replace (-1 * (h * derive_pt (fn N) c (pr1 c P))) with (-h * derive_pt (fn N) c (pr1 c P)) by field.
  replace (-1 * (fn N (x + h) - fn N x)) with (- (fn N (x + h) - fn N x)) by field.
  replace (-h) with (id x - id (x + h)).
  rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
  replace (- (fn N (x + h) - fn N x)) with (fn N x - fn N (x + h)) by field.
  assumption.
  unfold id ; field.
  apply Rlt_not_eq ; intuition.
 clear Hc.
 rewrite <- Hc'.
 replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
 replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
 rewrite Rabs_mult.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
 rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
 unfold N ; apply le_trans with (max N1 N2) ; apply le_max_l.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
 unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
 unfold N ; apply le_trans with (max N1 N2) ; [apply le_max_r | apply le_max_l].
 replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
 apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; rewrite <- Rmult_plus_distr_l ;
 apply Rmult_le_compat_l. apply Rabs_pos.
 apply Rabs_triang.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
          Rabs h * Rabs (g c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 apply fn'c_CVU_gc.
 unfold N ; apply le_max_r.
 unfold Boule.
 assert (Rabs (c - (lb + ub) / 2) < (ub - lb) / 2).
  apply Rabs_def1.
  assert (Temp : forall a b c, a < b + c -> a - b < c). intros ; lra.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 + (ub - lb) / 2) with ub by field.
  apply Rlt_trans with x ; [exact (proj2 P) | intuition].
  assert (Temp : forall a b c, a - b < c -> - b < c - a). intros ; lra.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 - ((ub - lb) / 2)) with lb by field.
  apply Rlt_trans with (x+h) ; [intuition | exact (proj1 P)].
  assumption.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
         Rabs h * (eps / 8)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ;
 rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
 unfold no_cond ; intuition. apply Rgt_not_eq ; exact (proj2 P).
 unfold R_dist. apply Rlt_trans with (Rabs h).
 apply Rabs_def1. apply Rlt_trans with 0.
 assert (Temp : forall a b, a < b -> a - b < 0).
  intros ; lra.
 apply Temp ; exact (proj2 P).
 apply Rabs_pos_lt ; assumption.
 apply Rle_lt_trans with h.
 rewrite Rabs_left1.
 apply Req_le ; field.
 apply Rlt_le ; assumption.
 assert (Temp : forall a b c, a + b < c -> b < c - a). intros ; lra.
 apply Temp ; clear Temp ; exact (proj1 P).
 apply Rlt_le_trans with delta ; [intuition | unfold delta ; apply Rmin_r].
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
 replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
 apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 lra.
 assert (lb_lt_c : lb < c).
   apply Rlt_trans with (x+h) ; intuition ; exact (proj1 P).
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with x ; intuition ; exact (proj2 P).
 assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
 assert (Temp : l = fn' N c).
  assert (Hl' := Dfn_eq_fn' c N lb_lt_c c_lt_ub).
  unfold derivable_pt_abs in Hl.
  clear -Hl Hl'.
  apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
  rewrite <- Temp.
  assert (Hl' : derivable_pt (fn N) c).
   exists l ; apply Hl.
  rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
  elim Hl' ; clear Hl' ; intros l' Hl'.
  assert (Main : l = l').
 apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
 rewrite Main ; reflexivity.
 reflexivity.
 assert (h_pos : h > 0).
  case sgn_h ; intro Hyp.
  assumption.
  apply False_ind ; apply h_neq ; symmetry ; assumption.
 clear sgn_h.
 assert (pr1 : forall c : R, x < c < x + h -> derivable_pt (fn N) c).
  intros c c_encad ; unfold derivable_pt.
  assert (lb_lt_c : lb < c).
   apply Rlt_trans with x ; intuition.
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with (x+h) ; intuition.
  exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
 assert (pr2 : forall c : R, x < c < x + h -> derivable_pt id c).
  intros c c_encad ; apply derivable_id.
 assert (xh_x : x < x + h).
  lra.
 assert (pr3 : forall c : R, x <= c <= x + h -> continuity_pt (fn N) c).
  intros c c_encad ; apply derivable_continuous_pt.
  exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
  apply Rlt_le_trans with x ; intuition.
  apply Rle_lt_trans with (x+h) ; intuition.
 assert (pr4 : forall c : R, x <= c <= x + h -> continuity_pt id c).
  intros c c_encad ; apply derivable_continuous ; apply derivable_id.
 elim (MVT (fn N) id x (x+h) pr1 pr2 xh_x pr3 pr4) ; intros c Hc ; elim Hc ; clear Hc ; intros P Hc.
 assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = (fn N (x+h) - fn N x)).
  replace (h * derive_pt (fn N) c (pr1 c P)) with ((id (x+h) - id x)* derive_pt (fn N) c (pr1 c P)).
  rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
  assumption.
  unfold id ; field.
 clear Hc.
 rewrite <- Hc'.
 replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
 replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
 rewrite Rabs_mult.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
 rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
 unfold N ; apply le_trans with (max N1 N2) ; apply le_max_l.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
 unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
 unfold N ; apply le_trans with (max N1 N2) ; [apply le_max_r | apply le_max_l].
 replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
 apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; rewrite <- Rmult_plus_distr_l ;
 apply Rmult_le_compat_l. apply Rabs_pos.
 apply Rabs_triang.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
          Rabs h * Rabs (g c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 apply fn'c_CVU_gc.
 unfold N ; apply le_max_r.
 unfold Boule.
 assert (Rabs (c - (lb + ub) / 2) < (ub - lb) / 2).
  apply Rabs_def1.
  assert (Temp : forall a b c, a < b + c -> a - b < c). intros ; lra.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 + (ub - lb) / 2) with ub by field.
  apply Rlt_trans with (x+h) ; [exact (proj2 P) | intuition].
  assert (Temp : forall a b c, a - b < c -> - b < c - a). intros ; lra.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 - ((ub - lb) / 2)) with lb by field.
  apply Rlt_trans with x ; [intuition | exact (proj1 P)].
  assumption.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
         Rabs h * (eps / 8)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ;
 rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
 unfold no_cond ; intuition. apply Rlt_not_eq ; exact (proj1 P).
 unfold R_dist. apply Rlt_trans with (Rabs h).
 apply Rabs_def1.
 assert (Temp : forall a b c, c < a + b -> c - a < b). intros ; lra.
 apply Temp ; clear Temp ; rewrite Rabs_right. exact (proj2 P).
 apply Rgt_ge ; assumption.
 assert (Temp : forall a b, a - b < c -> - b < c - a). intros ; lra.
 apply Temp ; apply Rlt_trans with x ; [| exact (proj1 P)].
 rewrite <- Rplus_0_r.
 apply Rplus_lt_compat_l.
 apply Ropp_lt_gt_0_contravar ; apply Rabs_pos_lt ; apply Rgt_not_eq ; assumption.
 apply Rle_lt_trans with h.
 rewrite Rabs_right. apply Req_le ; reflexivity.
 lra.
 apply Rlt_le_trans with delta ; [intuition | unfold delta ; apply Rmin_r].
 rewrite Rabs_right in h_ub ; intuition.
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
 replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
 apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 lra.
 assert (lb_lt_c : lb < c).
   apply Rlt_trans with x ; intuition ; exact (proj1 P).
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with (x+h) ; intuition ; exact (proj2 P).
 assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
 assert (Temp : l = fn' N c).
  assert (Hl' := Dfn_eq_fn' c N lb_lt_c c_lt_ub).
  unfold derivable_pt_abs in Hl.
  clear -Hl Hl'.
  apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
  rewrite <- Temp.
  assert (Hl' : derivable_pt (fn N) c).
   exists l ; apply Hl.
  rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
  elim Hl' ; clear Hl' ; intros l' Hl'.
  assert (Main : l = l').
 apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
 rewrite Main ; reflexivity.
 reflexivity.
 replace ((f (x + h) - f x) / h - g x) with ((/h) * ((f (x + h) - f x) - h * g x)).
 rewrite Rabs_mult ; rewrite Rabs_Rinv.
 replace eps with (/ Rabs h * (Rabs h * eps)).
 apply Rmult_lt_compat_l.
 apply Rinv_0_lt_compat ; apply Rabs_pos_lt ; assumption.
 replace (f (x + h) - f x - h * g x) with (f (x + h) - fn N (x + h) - (f x - fn N x) +
          (fn N (x + h) - fn N x - h * g x)) by field.
 assumption.
 field ; apply Rgt_not_eq ; apply Rabs_pos_lt ; assumption.
 assumption.
 field. assumption.
Qed.

Definition SFL_interv : forall (fn:nat -> R -> R) (r:posreal)
  (cv:forall x:R, Boule 0 r x -> {l:R | Un_cv (fun N:nat => SP fn N x) l }) (y:R), R.
Proof.
intros fn r cv x.
 case (Rlt_le_dec x r) ; intro x_bd1.
 case (Rlt_le_dec (-r) x) ; intro x_bd2.
 assert (x_bd : Boule 0 r x).
  apply Rabs_def1 ; rewrite Rminus_0_r ; assumption.
 destruct (cv _ x_bd) as (l, _) ; apply l.
 exact 0.
 exact 0.
Defined.

Lemma SFL_interv_right : forall fn r cv y, Boule 0 r y ->
     Un_cv (fun N:nat => SP fn N y) (SFL_interv fn r cv y).
Proof.
intros fn r cv y y_bd ; unfold SFL_interv ; case (Rlt_le_dec y r) ; intro y_bd1.
 case (Rlt_le_dec (- r) y) ; intro y_bd2.
 destruct (cv y
       (Rabs_def1 (y - 0) r
          (eq_ind_r (fun r0 : R => r0 < r) y_bd1 (Rminus_0_r y))
          (eq_ind_r (fun r0 : R => - r < r0) y_bd2 (Rminus_0_r y)))) as (l', Hl').
  assumption.
  clear -y_bd y_bd1 y_bd2 ;
  destruct (Rabs_def2 _ _ y_bd) as [H1 H2] ; rewrite Rminus_0_r in H1, H2 ;
  apply False_ind ; apply Rlt_irrefl with (-r) ; apply Rlt_le_trans with y ; assumption.
  clear -y_bd y_bd1; destruct (Rabs_def2 _ _ y_bd) as [H1 H2] ;
  rewrite Rminus_0_r in H1, H2 ; apply False_ind ; apply Rlt_irrefl with y ;
  apply Rlt_le_trans with r ; assumption.
Qed.

(** In a complete space, normal convergence implies uniform convergence *)
Lemma CVN_CVU_interv : forall (fn:nat -> R -> R) (r:posreal)
    (cv:forall x:R, Boule 0 r x -> {l:R | Un_cv (fun N:nat => SP fn N x) l }),
    CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL_interv fn r cv) 0 r.
Proof.
  intros; unfold CVU in |- *; intros.
  unfold CVN_r in X.
  elim X; intros An X0.
  elim X0; intros s H0.
  elim H0; intros.
  cut (Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n - s) 0).
  intro; unfold Un_cv in H3.
  elim (H3 eps H); intros N0 H4.
  exists N0; intros.
  apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)).
  rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)).
    rewrite Ropp_minus_distr';
      rewrite (Rabs_right (s - sum_f_R0 (fun k:nat => Rabs (An k)) n)).
  eapply sum_maj1.
  unfold SFL in |- *; case (cv y H6) ; intro.
  unfold SFL_interv.
  case (Rlt_le_dec y r) ; intro y_bd1.
  case (Rlt_le_dec (- r) y) ; intro y_bd2.
  destruct (cv y
         (Rabs_def1 (y - 0) r
            (eq_ind_r (fun r0 : R => r0 < r) y_bd1 (Rminus_0_r y))
            (eq_ind_r (fun r0 : R => - r < r0) y_bd2 (Rminus_0_r y)))) as (l, Hl).
   trivial.
   clear -H6 y_bd1 y_bd2 ;
   destruct (Rabs_def2 _ _ H6) as [H1 H2] ; rewrite Rminus_0_r in H1, H2 ;
   apply False_ind ; apply Rlt_irrefl with (-r) ; apply Rlt_le_trans with y ; assumption.
   clear -H6 y_bd1; destruct (Rabs_def2 _ _ H6) as [H1 H2] ;
   rewrite Rminus_0_r in H1, H2 ; apply False_ind ; apply Rlt_irrefl with y ;
   apply Rlt_le_trans with r ; assumption.
   apply H1.
  intro; elim H0; intros.
  rewrite (Rabs_right (An n0)).
  apply H8; apply H6.
  apply Rle_ge; apply Rle_trans with (Rabs (fn n0 y)).
  apply Rabs_pos.
  apply H8; apply H6.
  apply Rle_ge;
    apply Rplus_le_reg_l with (sum_f_R0 (fun k:nat => Rabs (An k)) n).
  rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm s);
    rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l;
      apply sum_incr.
  apply H1.
  intro; apply Rabs_pos.
  unfold R_dist in H4; unfold Rminus in H4; rewrite Ropp_0 in H4.
  assert (H7 := H4 n H5).
  rewrite Rplus_0_r in H7; apply H7.
  unfold Un_cv in H1; unfold Un_cv in |- *; intros.
  elim (H1 _ H3); intros.
  exists x; intros.
  unfold R_dist in |- *; unfold R_dist in H4.
  rewrite Rminus_0_r; apply H4; assumption.
Qed.


(** **** SNU 4190.310, 2016 Spring *)

(** Assignment 08 *)
(** Due: 2016/12/07 23:59 *)

(* Important:
   - Do NOT import other files.

   - You are NOT allowed to use the [admit] tactic.

   - You are ALLOWED to use any tactics including:
     [tauto], [intuition], [firstorder], [omega].

   - Just leave [exact FILL_IN_HERE] for those problems that you fail to prove.
*)

Require Export Coq.Bool.Bool.
Require Export Coq.Arith.Arith.
Require Export Coq.Arith.EqNat.
Require Export Coq.omega.Omega.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Maps.
Require Export Imp.
Require Export Hoare.

Definition FILL_IN_HERE {T: Type} : T.  Admitted.

Theorem hoare_if_wp : forall P1 P2 Q b c1 c2,
  {{P1}} c1 {{Q}} ->
  {{P2}} c2 {{Q}} ->
  {{fun st => (beval st b = true -> P1 st) /\ (beval st b = false -> P2 st) }}
    (IFB b THEN c1 ELSE c2 FI)
  {{Q}}.
Proof.
  intros Q1 Q2 Q b c1 c2 HTrue HFalse st st' HE [HQ1 HQ2].
  inversion HE; subst; eauto.
Qed.

Definition is_wp P c Q :=
  {{P}} c {{Q}} /\
  forall P', {{P'}} c {{Q}} -> (P' ->> P).

Fixpoint parity x :=
  match x with
  | 0 => 0
  | 1 => 1
  | S (S x') => parity x'
  end.

Fixpoint pow (b n: nat) : nat :=
  match n with
  | 0 => 1
  | S n' => b * pow b n'
  end.


Require Import Iron.Language.SystemF2.SubstTypeExp.
Require Import Iron.Language.SystemF2.SubstExpExp.
Require Export Iron.Language.SystemF2.Exp.

(* Single Step Evaluation *)
Inductive STEP : exp -> exp -> Prop :=
  (* value applications *)
  | ESLamApp
    :  forall t11 x12 v2
    ,  wnfX v2
    -> STEP (XApp (XLam t11 x12) v2) (substXX 0 v2 x12)

  | ESApp1
    :  forall x1 x1' x2
    ,  STEP x1 x1'
    -> STEP (XApp x1 x2) (XApp x1' x2)

  | ESApp2
    :  forall v1 x2 x2'
    ,  wnfX v1
    -> STEP x2 x2'
    -> STEP (XApp v1 x2) (XApp v1 x2')

  (* type applications *)
  | ESLAMAPP
    :  forall x12 t2
    ,  STEP (XAPP (XLAM x12) t2) (substTX 0 t2 x12)

  | ESAPP1
    :  forall x1 x1' t2
    ,  STEP x1 x1'
    -> STEP (XAPP x1 t2) (XAPP x1' t2).

Hint Constructors STEP.

(* Multi-step evaluation.
   A sequence of small step transitions.
   As opposed to STEPSL, this version has an append constructor
   ESAppend that makes it easy to join two evaluations together.
   We use this when converting big-step evaluations to small-step.
 *)
Inductive STEPS : exp -> exp -> Prop :=

 (* After no steps, we get the same exp.
    We need this constructor to match the EVDone constructor
    in the big-step evaluation, so we can convert between big-step
    and multi-step evaluations. *)
 | ESNone
   :  forall x1
   ,  STEPS x1 x1

 (* Take a single step. *)
 | ESStep
   :  forall x1 x2
   ,  STEP  x1 x2
   -> STEPS x1 x2

 (* Combine two evaluations into a third. *)
 | ESAppend
   :  forall x1 x2 x3
   ,  STEPS x1 x2 -> STEPS x2 x3
   -> STEPS x1 x3.

Hint Constructors STEPS.

(* Context lemmas.
   These help when proving something about a reduction in a given
   context. They're all trivial.
 *)
Lemma steps_app1
 :  forall x1 x1' x2
 ,  STEPS x1 x1'
 -> STEPS (XApp x1 x2) (XApp x1' x2).
Proof.
 intros. induction H; eauto.
Qed.
Hint Resolve steps_app1.

Lemma steps_app2
 :  forall v1 x2 x2'
 ,  wnfX v1
 -> STEPS x2 x2'
 -> STEPS (XApp v1 x2) (XApp v1 x2').
Proof.
 intros. induction H0; eauto.
Qed.
Hint Resolve steps_app2.

Lemma steps_APP1
 :  forall x1 x1' t2
 ,  STEPS x1 x1'
 -> STEPS (XAPP x1 t2) (XAPP x1' t2).
Proof.
 intros. induction H; eauto.
Qed.

(* Left linearised multi-step evaluation.
   As opposed to STEPS, this version provides a single step at a time
   and does not have an append constructor. This is convenient
   when converting a small-step evaluations to big-step, via the
   eval_expansion lemma. *)
Inductive STEPSL : exp -> exp -> Prop :=

 | ESLNone
   : forall x1
   , STEPSL x1 x1

 | ESLCons
   :  forall x1 x2 x3
   ,  STEP   x1 x2 -> STEPSL x2 x3
   -> STEPSL x1 x3.

Hint Constructors STEPSL.

(* Transitivity of left linearised multi-step evaluation.
   We use this when "flattening" a big step evaluation to the
   small step one. *)
Lemma stepsl_trans
 :  forall x1 x2 x3
 ,  STEPSL x1 x2 -> STEPSL x2 x3
 -> STEPSL x1 x3.
Proof.
 intros. induction H; burn.
Qed.

(* Linearise a regular multi-step evaluation.
   This flattens out all the append constructors, leaving us with
   a list of individual transitions.  *)
Lemma stepsl_of_steps
 :  forall x1 x2
 ,  STEPS  x1 x2
 -> STEPSL x1 x2.
Proof.
 intros. induction H; eauto using stepsl_trans.
Qed.