(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
Require Export CoRN.algebra.COrdAbs.
From Coq Require Import Lia.
Set Automatic Introduction.

(* Begin_SpecReals *)

Section OrdField_Cauchy.

(**
** Cauchy sequences
%\begin{convention}% Let [R] be an ordered field.
%\end{convention}%
*)
Variable R : COrdField.

(* begin hide *)
Set Implicit Arguments.
Unset Strict Implicit.
(* end hide *)

Definition Cauchy_prop (g : nat -> R) : CProp := forall e : R,
 [0] [<] e -> {N : nat | forall m, N <= m -> AbsSmall e (g m[-]g N)}.

(* begin hide *)
Set Strict Implicit.
Unset Implicit Arguments.
(* end hide *)

(* Def. CauchyP, Build_CauchyP *)
(* Should be defined in terms of CauchyP *)

(**
Implicit arguments turned off, because Coq makes a mess of it in combination
with the coercions
*)

Record CauchySeq : Type :=
 {CS_seq   :> nat -> R;
  CS_proof :  Cauchy_prop CS_seq}.

Definition SeqLimit (seq : nat -> R) (lim : R) : CProp := forall e : R,
 [0] [<] e -> {N : nat | forall m, N <= m -> AbsSmall e (seq m[-]lim)}.

(* End_SpecReals *)

(**
We now prove that the property of being a Cauchy sequence is preserved
through the usual algebraic operations (addition, subtraction and
multiplication -- and division, provided some additional conditions
hold).

%\begin{convention}% Let [R] be an ordered field.
%\end{convention}%
*)

Theorem CS_seq_bounded : forall g : nat -> R, Cauchy_prop g ->
 {K : R | [0] [<] K | {N : nat | forall m, N <= m -> AbsSmall K (g m)}}.
Proof.
 intros g Hg.
 unfold Cauchy_prop in |- *.
 elim (Hg _ (pos_one _)).
 intros N H1.
 exists (g N[^]2[-]g N[+]Two).
  apply less_leEq_trans with (nring (R:=R) 7 [/]FourNZ).
   apply pos_div_four; apply nring_pos; auto with arith.
  astepl ([0][+]nring (R:=R) 7 [/]FourNZ).
  apply shift_plus_leEq.
  rstepr ((g N[-][1] [/]TwoNZ)[^]2).
  apply sqr_nonneg.
 exists N.
 intros m Hm.
 elim (H1 m Hm); intros.
 split.
  apply plus_cancel_leEq_rht with (z := [--](g N)).
  rstepr (g m[-]g N).
  rstepl ([--](g N[^]2[+]Two)).
  apply leEq_transitive with ([--]([1]:R)).
   apply inv_cancel_leEq.
   rstepl ([1]:R).
   rstepr (g N[^]2[+]Two).
   apply plus_cancel_leEq_rht with ([--][1]:R).
   rstepl ([0]:R).
   rstepr (g N[^]2[+][1]).
   apply leEq_transitive with (y := g N[^]2).
    apply sqr_nonneg.
   apply less_leEq; apply less_plusOne.
  assumption.
 apply plus_cancel_leEq_rht with (g N[-]Two).
 rstepr (g N[^]2).
 astepr (g N[*]g N).
 apply plus_cancel_leEq_rht with ([--](Two[*]g N)[+]Two).
 rstepl (g m[-]g N).
 rstepr (g N[*]g N[+][1][-]Two[*]g N[+][1]).
 apply leEq_transitive with (y := [1]:R).
  assumption.
 rstepl ([0][+]([1]:R)).
 apply plus_resp_leEq with (z := [1]:R).
 rstepr ((g N[-][1])[*](g N[-][1])).
 apply leEq_wdr with (y := (g N[-][1])[^]2).
  apply sqr_nonneg.
 algebra.
Qed.

Lemma CS_seq_const : forall c : R, Cauchy_prop (fun n => c).
Proof.
 exists 0.
 intros; astepr ([0]:R); apply zero_AbsSmall.
 apply less_leEq; auto.
Qed.

(**
%\begin{convention}% Assume [f] and [g] are Cauchy sequences on [R].
%\end{convention}%
*)

Variables f g : nat -> R.

Hypothesis Hf : Cauchy_prop f.
Hypothesis Hg : Cauchy_prop g.

Lemma CS_seq_plus : Cauchy_prop (fun m => f m[+]g m).
Proof.
 unfold Cauchy_prop in |- *.
 intros.
 set (e_div_4 := e [/]FourNZ) in *.
 cut ([0] [<] e_div_4); [ intro Heps | unfold e_div_4 in |- *; apply pos_div_four; auto ].
 unfold Cauchy_prop in Hf.
 unfold Cauchy_prop in Hg.
 elim (Hf e_div_4 Heps); intros N1 H21.
 elim (Hg e_div_4 Heps); intros N2 H31.
 exists (max N1 N2).
 intros.
 rstepl (e [/]TwoNZ[+]e [/]TwoNZ).
 rstepr (f m[-]f (max N1 N2)[+](g m[-]g (max N1 N2))).
 apply AbsSmall_plus.
  rstepr (f m[-]f N1[+](f N1[-]f (max N1 N2))).
  rstepl (e [/]FourNZ[+]e [/]FourNZ).
  apply AbsSmall_plus.
   apply H21; eauto with arith.
  apply AbsSmall_minus.
  apply H21; eauto with arith.
 rstepr (g m[-]g N2[+](g N2[-]g (max N1 N2))).
 rstepl (e [/]FourNZ[+]e [/]FourNZ).
 apply AbsSmall_plus.
  apply H31; eauto with arith.
 apply AbsSmall_minus.
 apply H31; eauto with arith.
Qed.

Lemma CS_seq_inv : Cauchy_prop (fun n => [--] (f n)).
Proof.
 red in |- *; intros e H.
 elim (Hf e H); intros N Hn.
 exists N; intros m Hm.
 apply AbsSmall_minus.
 rstepr (f m[-]f N).
 auto.
Qed.

Lemma CS_seq_mult : Cauchy_prop (fun n => f n[*]g n).
Proof.
 red in |- *; intros e He.
 elim (CS_seq_bounded f Hf); intros Mf HMf H.
 elim (CS_seq_bounded g Hg); intros Mg HMg H'.
 elim H; clear H; intros Nf HNf.
 elim H'; clear H'; intros Ng HNg.
 set (Mf_ap_zero := pos_ap_zero _ _ HMf) in *.
 set (Mg_ap_zero := pos_ap_zero _ _ HMg) in *.
 set (ef := e[/] _[//]mult_resp_ap_zero _ _ _ (twelve_ap_zero _) Mf_ap_zero) in *.
 set (eg := e[/] _[//]mult_resp_ap_zero _ _ _ (twelve_ap_zero _) Mg_ap_zero) in *.
 cut ([0] [<] ef); [ intro Hef
   | unfold ef in |- *; apply div_resp_pos; try apply mult_resp_pos; auto; apply pos_twelve ].
 cut ([0] [<] eg); [ intro Heg
   | unfold eg in |- *; apply div_resp_pos; try apply mult_resp_pos; auto; apply pos_twelve ].
 elim (Hf eg Heg); intros Pf HPf.
 elim (Hg ef Hef); intros Pg HPg.
 set (N := max (max Nf Pf) (max Ng Pg)) in *; exists N; intros m Hm.
 rstepr ((f m[-]f Pf[+][--](f N[-]f Pf))[*]g m[+] (g m[-]g Pg[+][--](g N[-]g Pg))[*]f N).
 apply AbsSmall_wdl_unfolded with (Three[*]((eg[+]eg)[*]Mg)[+]Three[*]((ef[+]ef)[*]Mf)).
  2: unfold eg, ef in |- *; rational.
 apply AbsSmall_plus; apply AbsSmall_mult; try apply AbsSmall_plus; try apply inv_resp_AbsSmall.
      apply HPf; apply le_trans with N; auto; unfold N in |- *; eauto with arith.
     apply HPf; apply le_trans with N; auto; unfold N in |- *; eauto with arith.
    apply HNg; auto; apply le_trans with N; auto; unfold N in |- *; eauto with arith.
   apply HPg; apply le_trans with N; auto; unfold N in |- *; eauto with arith.
  apply HPg; apply le_trans with N; auto; unfold N in |- *; eauto with arith.
 apply HNf; auto; apply le_trans with N; auto; unfold N in |- *; eauto with arith.
Qed.

(**
We now assume that [f] is, from some point onwards, greater than
some positive number.  The sequence of reciprocals is defined as
being constantly one up to that point, and the sequence of
reciprocals from then onwards.

%\begin{convention}%
Let [e] be a postive element of [R] and let [N:nat] be such that from
[N] onwards, [(f n) [#] [0]]
%\end{convention}%
*)

Variable e : R.
Hypothesis He : [0] [<] e.

Variable N : nat.
Hypothesis f_bnd : forall n : nat, N <= n -> e [<=] f n.

Lemma CS_seq_recip_def : forall n : nat, N <= n -> f n [#] [0].
Proof.
 intros.
 apply pos_ap_zero.
 apply less_leEq_trans with e; auto with arith.
Qed.

Definition CS_seq_recip_seq (n : nat) : R.
Proof.
 elim (lt_le_dec n N); intro Hdec.
  apply ([1]:R).
 apply ([1][/] _[//]CS_seq_recip_def n Hdec).
Defined.

Lemma CS_seq_recip : Cauchy_prop CS_seq_recip_seq.
Proof.
 red in |- *; intros d Hd.
 elim (Hf ((d[*]e[*]e) [/]TwoNZ));
   [ intros K HK | apply pos_div_two; repeat apply mult_resp_pos; auto ].
 exists (max K N); intros n Hn.
 apply AbsSmall_cancel_mult with (f (max K N)).
  apply less_leEq_trans with e; auto with arith.
 apply AbsSmall_cancel_mult with (f n).
  apply less_leEq_trans with e; eauto with arith.
 unfold CS_seq_recip_seq in |- *.
 elim lt_le_dec; intro; simpl in |- *.
  exfalso; apply le_not_lt with N n; eauto with arith.
 elim lt_le_dec; intro; simpl in |- *.
  exfalso; apply le_not_lt with N (max K N); eauto with arith.
 rstepr (f (max K N)[-]f n).
 apply AbsSmall_leEq_trans with (d[*]e[*]e).
  apply mult_resp_leEq_both.
     apply less_leEq; apply mult_resp_pos; auto.
    apply less_leEq; auto.
   apply mult_resp_leEq_lft.
    auto with arith.
   apply less_leEq; auto.
  auto with arith.
 auto with arith.
 rstepr (f (max K N)[-]f K[+](f K[-]f n)).
 apply AbsSmall_eps_div_two.
  auto with arith.
 apply AbsSmall_minus; apply HK.
 eauto with arith.
Qed.

End OrdField_Cauchy.

Arguments SeqLimit [R].

(**
The following lemma does not require the sequence to be Cauchy, but it fits
well here anyway.
*)

Lemma maj_upto_eps : forall (F : COrdField) (a : nat -> F) (n : nat) (eps : F),
 0 < n -> [0] [<] eps -> {k : nat | 1 <= k /\ k <= n /\ (forall i : nat, 1 <= i -> i <= n -> a i[-]eps [<=] a k)}.
Proof.
 intros F a n eps Hn Heps.
 induction  n as [| n Hrecn].
  elim (lt_irrefl _ Hn).
 clear Hrecn Hn.
 induction  n as [| n Hrecn].
  exists 1.
  repeat split. 1-2: reflexivity.
  intros.
  rewrite <- (le_antisym _ _ H H0).
  astepr (a 1[+][0]).
  unfold cg_minus in |- *.
  apply plus_resp_leEq_lft.
  astepr ([--]([0]:F)).
  apply less_leEq; apply inv_resp_less; auto.
 elim Hrecn; intros k Hk.
 cut (a (S (S n))[-]eps [<] a (S (S n))).
  intro H.
  elim (less_cotransitive_unfolded _ _ _ H (a k)); intro H4.
   exists k.
   elim Hk; intros H0 H2.
   elim H2; clear H2; intros H1 H2.
   repeat split.
     assumption.
    auto with arith.
   intros i H3 H5.
   elim (Cle_le_S_eq _ _ H5); intro H6.
    auto with arith.
   rewrite H6.
   apply less_leEq; assumption.
  exists (S (S n)).
  repeat split; auto with arith.
  intros i H0 H1.
  elim (Cle_le_S_eq _ _ H1); intro H2.
   apply leEq_transitive with (a k).
    elim Hk; intros H3 H5.
    elim H5; clear H5; intros H6 H7.
    auto with arith.
   apply less_leEq; assumption.
  rewrite H2; apply less_leEq; auto.
 rstepr (a (S (S n))[-][0]).
 apply minus_resp_less_rht.
 assumption.
Qed.

Section Mult_Continuous.

Variable R : COrdField.
(**
** Multiplication is continuous
%\begin{convention}% Let [R] be an ordered field.
%\end{convention}%
*)

Lemma smaller : forall x y : R,
 [0] [<] x -> [0] [<] y -> {z : R | [0] [<] z | z [<=] x /\ z [<=] y}.
Proof.
 intros x y H H0.
 elim (less_cotransitive_unfolded _ _ _ (half_3 _ _ H) y); intro.
  exists (Half[*]x).
   apply mult_resp_pos. apply pos_half. auto.
    split; apply less_leEq. apply half_3. auto. auto.
   cut (Half[*]y [<] y). intro. exists (Half[*]y).
  apply mult_resp_pos. apply pos_half. auto.
    split; apply less_leEq. apply less_transitive_unfolded with y. auto. auto.
   auto.
 apply half_3. auto.
Qed.

Lemma estimate_abs : forall x : R, {X : R | [0] [<] X | AbsSmall X x}.
Proof.
 intros.
 unfold AbsSmall in |- *.
 cut (x [<] x[+][1]). intro H.
  elim (less_cotransitive_unfolded _ x (x[+][1]) H [--]x); intro.
   exists ([--]x[+][1]).
    apply leEq_less_trans with ([--]x).
     2: apply less_plusOne.
    apply less_leEq; apply mult_cancel_less with (Two:R).
     apply pos_two.
    astepl ([0]:R); rstepr ([--]x[-]x).
    apply shift_less_minus.
    astepl x; auto.
   split; apply less_leEq.
    astepr ([--][--]x). apply inv_resp_less. apply less_plusOne.
    apply less_transitive_unfolded with ([--]x). auto. apply less_plusOne.
    exists (x[+][1]).
   apply less_leEq_trans with (([1]:R) [/]TwoNZ).
    apply pos_div_two; apply pos_one.
   apply shift_leEq_plus; rstepl (([--][1]:R) [/]TwoNZ).
   apply shift_div_leEq.
    apply pos_two.
   rstepr (x[+]x); apply shift_leEq_plus.
   unfold cg_minus in |- *; apply shift_plus_leEq'.
   rstepr (x[+][1]); apply less_leEq; auto.
  split; apply less_leEq.
   astepr ([--][--]x). apply inv_resp_less. auto. auto.
   apply less_plusOne.
Qed.

Lemma mult_contin : forall x y e : R, [0] [<] e ->
 {c : R | [0] [<] c | {d : R | [0] [<] d | forall x' y' : R,
 AbsSmall c (x[-]x') -> AbsSmall d (y[-]y') -> AbsSmall e (x[*]y[-]x'[*]y')}}.
Proof.
 intros x y e H.
 set (e2 := e [/]TwoNZ) in *.
 cut ([0] [<] e2). intro H0. 2: unfold e2 in |- *; apply pos_div_two; auto.
  elim (estimate_abs x). intro X. intros H1a H1b.
 elim (estimate_abs y). intro Y. intros H2 H3.
 cut (Y [#] [0]). intro H4.
  set (eY := e2[/] Y[//]H4) in *; exists eY.
   unfold eY in |- *. apply div_resp_pos. auto. auto.
   cut ([0] [<] X[+]eY). intro H5.
   cut (X[+]eY [#] [0]). intro H6.
    exists (e2[/] X[+]eY[//]H6).
     apply div_resp_pos. auto. auto.
      intros.
    apply AbsSmall_wdr_unfolded with ((x[-]x')[*]y[+]x'[*](y[-]y')).
     apply AbsSmall_eps_div_two.
      apply AbsSmall_wdl_unfolded with ((e [/]TwoNZ[/] Y[//]H4)[*]Y).
       apply mult_AbsSmall; auto.
      rational.
     apply AbsSmall_wdl_unfolded with ((X[+](e [/]TwoNZ[/] Y[//]H4))[*]
       (e [/]TwoNZ[/] X[+](e [/]TwoNZ[/] Y[//]H4)[//]H6)).
      apply mult_AbsSmall; auto.
      apply AbsSmall_wdr_unfolded with (x[+](x'[-]x)).
       apply AbsSmall_plus; auto. apply AbsSmall_minus. auto.
       rational.
     rational.
    rational.
   apply Greater_imp_ap. auto.
   apply plus_resp_pos; auto.
  unfold eY in |- *; apply div_resp_pos; auto.
 apply Greater_imp_ap. auto.
Qed.

(** Addition is also continuous. *)

Lemma plus_contin : forall (x y e : R), [0] [<] e ->
 {c : R | [0] [<] c | {d : R | [0] [<] d | forall x' y',
 AbsSmall c (x[-]x') -> AbsSmall d (y[-]y') -> AbsSmall e (x[+]y[-] (x'[+]y'))}}.
Proof.
 intros.
 cut ([0] [<] e [/]TwoNZ). intro.
  exists (e [/]TwoNZ). auto.
   exists (e [/]TwoNZ). auto.
   intros.
  apply AbsSmall_wdr_unfolded with (x[-]x'[+](y[-]y')).
   apply AbsSmall_eps_div_two; auto.
  rational.
 apply div_resp_pos. apply pos_two. auto.
Qed.

End Mult_Continuous.

Section Monotonous_functions.

(**
** Monotonous Functions

Finally, we study several properties of monotonous functions and
characterize them in some way.

%\begin{convention}% Let [R] be an ordered field.
%\end{convention}%
*)
Variable R : COrdField.

(**
We begin by characterizing the preservation of less (less or equal)
in terms of preservation of less or equal (less).
*)

Lemma resp_less_char' : forall (P : R -> CProp) (f : forall x, P x -> R) x y Hx Hy,
 (x [#] y -> f x Hx [#] f y Hy) -> (x [<=] y -> f x Hx [<=] f y Hy) ->
 x [<] y -> f x Hx [<] f y Hy.
Proof.
 intros.
 elim (ap_imp_less _ _ _ (X (less_imp_ap _ _ _ X0))); intros.
  auto.
 exfalso.
 apply less_irreflexive_unfolded with (x := f x Hx).
 apply leEq_less_trans with (f y Hy); auto.
 apply H; apply less_leEq; auto.
Qed.

Lemma resp_less_char : forall (f : R -> R) x y,
 (x [#] y -> f x [#] f y) -> (x [<=] y -> f x [<=] f y) -> x [<] y -> f x [<] f y.
Proof.
 intros.
 set (f' := fun (x : R) (H : True) => f x) in *.
 change (f' x I [<] f' y I) in |- *.
 apply resp_less_char' with (P := fun x : R => True); auto.
Qed.

Lemma resp_leEq_char' : forall (P : R -> CProp) (f : forall x : R, P x -> R) x y Hx Hy,
 (x [=] y -> f x Hx [=] f y Hy) -> (x [<] y -> f x Hx [<] f y Hy) ->
 x [<=] y -> f x Hx [<=] f y Hy.
Proof.
 intros.
 rewrite -> leEq_def.
 intro.
 cut (Not (x [<] y) /\ ~ x [=] y); intros.
  inversion_clear H1.
  apply H3.
  apply leEq_imp_eq; firstorder using leEq_def.
 split; intro.
  apply less_irreflexive_unfolded with (x := f y Hy).
  apply less_transitive_unfolded with (f x Hx); auto.
 apply less_irreflexive_unfolded with (x := f y Hy).
 apply less_leEq_trans with (f x Hx); auto.
 apply eq_imp_leEq; auto.
Qed.

Lemma resp_leEq_char : forall (f : R -> R) x y,
 (x [=] y -> f x [=] f y) -> (x [<] y -> f x [<] f y) -> x [<=] y -> f x [<=] f y.
Proof.
 intros.
 set (f' := fun (x : R) (H : True) => f x) in *.
 change (f' x I [<=] f' y I) in |- *.
 apply resp_leEq_char' with (P := fun x : R => True); auto.
Qed.

(**
Next, we see different characterizations of monotonous functions from
some subset of the natural numbers into [R].  Mainly, these
amount (for different types of functions) to proving that a function
is monotonous iff [f(i) [<] f(i+1)] for every [i].

Also, strictly monotonous functions are injective.
*)

Lemma local_mon_imp_mon : forall f : nat -> R,
 (forall i, f i [<] f (S i)) -> forall i j, i < j -> f i [<] f j.
Proof.
 simple induction j.
  intros H0; exfalso; inversion H0.
 clear j; intro j; intros H0 H1.
 elim (le_lt_eq_dec _ _ H1); intro.
  apply leEq_less_trans with (f j).
   apply less_leEq; apply H0; auto with arith.
  auto.
 rewrite <- b; apply X.
Qed.

Lemma local_mon_imp_mon' : forall f : nat -> R,
 (forall i, f i [<] f (S i)) -> forall i j, i <= j -> f i [<=] f j.
Proof.
 intros f H i j H0.
 elim (le_lt_eq_dec _ _ H0); intro.
  apply less_leEq; apply local_mon_imp_mon with (f := f); assumption.
 apply eq_imp_leEq; rewrite b; algebra.
Qed.

Lemma local_mon'_imp_mon' : forall f : nat -> R,
 (forall i, f i [<=] f (S i)) -> forall i j, i <= j -> f i [<=] f j.
Proof.
 intros; induction  j as [| j Hrecj].
  cut (i = 0); [ intro | auto with arith ].
  rewrite H1; apply leEq_reflexive.
 elim (le_lt_eq_dec _ _ H0); intro.
  apply leEq_transitive with (f j).
   apply Hrecj; auto with arith.
  apply H.
 rewrite b; apply leEq_reflexive.
Qed.

Lemma mon_imp_mon' : forall f : nat -> R,
 (forall i j, i < j -> f i [<] f j) -> forall i j, i <= j -> f i [<=] f j.
Proof.
 intros f H i j H0.
 elim (le_lt_eq_dec _ _ H0); intro.
  apply less_leEq; apply H; assumption.
 rewrite b; apply leEq_reflexive.
Qed.

Lemma mon_imp_inj : forall f : nat -> R,
 (forall i j, i < j -> f i [<] f j) -> forall i j, f i [=] f j -> i = j.
Proof.
 intros.
 cut (~ i <> j); [ lia | intro ].
 cut (i < j \/ j < i); [ intro | apply not_eq; auto ].
 inversion_clear H1; (exfalso; cut (f i [#] f j); [ apply eq_imp_not_ap; assumption | idtac ]).
  apply less_imp_ap; apply X; assumption.
 apply Greater_imp_ap; apply X; assumption.
Qed.

Lemma local_mon_imp_mon_lt : forall n (f : forall i, i < n -> R),
 (forall i H H', f i H [<] f (S i) H') -> forall i j Hi Hj, i < j -> f i Hi [<] f j Hj.
Proof.
 simple induction j.
  intros Hi Hj H0; exfalso; inversion H0.
 clear j; intro j; intros.
 elim (le_lt_eq_dec _ _ H); intro.
  cut (j < n); [ intro | auto with arith ].
  apply leEq_less_trans with (f j H0).
   apply less_leEq; apply X0; auto with arith.
  apply X.
 generalize Hj; rewrite <- b.
 intro; apply X.
Qed.

Lemma local_mon_imp_mon'_lt : forall n (f : forall i, i < n -> R),
 (forall i H H', f i H [<] f (S i) H') -> nat_less_n_fun f ->
 forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj.
Proof.
 intros.
 elim (le_lt_eq_dec _ _ H0); intros.
  apply less_leEq; apply local_mon_imp_mon_lt with n; auto.
 apply eq_imp_leEq; apply H; assumption.
Qed.

Lemma local_mon'_imp_mon'_lt : forall n (f : forall i, i < n -> R),
 (forall i H H', f i H [<=] f (S i) H') -> nat_less_n_fun f ->
 forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj.
Proof.
 simple induction j.
  intros.
  cut (i = 0); [ intro | auto with arith ].
  apply eq_imp_leEq; apply H0; auto.
 intro m; intros.
 elim (le_lt_eq_dec _ _ H2); intro.
  cut (m < n); [ intro | auto with arith ].
  apply leEq_transitive with (f m H3); auto.
  apply H1; auto with arith.
 apply eq_imp_leEq; apply H0; assumption.
Qed.

Lemma local_mon'_imp_mon'2_lt : forall n (f : forall i, i < n -> R),
 (forall i H H', f i H [<=] f (S i) H') -> forall i j Hi Hj, i < j -> f i Hi [<=] f j Hj.
Proof.
 intros; induction  j as [| j Hrecj].
  exfalso; inversion H0.
 elim (le_lt_eq_dec _ _ H0); intro.
  cut (j < n); [ intro | auto with arith ].
  apply leEq_transitive with (f j H1).
   apply Hrecj; auto with arith.
  apply H.
 generalize Hj; rewrite <- b.
 intro; apply H.
Qed.

Lemma mon_imp_mon'_lt : forall n (f : forall i, i < n -> R), nat_less_n_fun f ->
 (forall i j Hi Hj, i < j -> f i Hi [<] f j Hj) -> forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj.
Proof.
 intros.
 elim (le_lt_eq_dec _ _ H0); intro.
  apply less_leEq; auto.
 apply eq_imp_leEq; auto.
Qed.

Lemma mon_imp_inj_lt : forall n (f : forall i, i < n -> R),
 (forall i j Hi Hj, i < j -> f i Hi [<] f j Hj) ->
 forall i j Hi Hj, f i Hi [=] f j Hj -> i = j.
Proof.
 intros.
 cut (~ i <> j); intro.
  clear X H Hj Hi; lia.
 cut (i < j \/ j < i); [ intro | apply not_eq; auto ].
 inversion_clear H1; (exfalso; cut (f i Hi [#] f j Hj);
   [ apply eq_imp_not_ap; assumption | idtac ]).
  apply less_imp_ap; auto.
 apply Greater_imp_ap; auto.
Qed.

Lemma local_mon_imp_mon_le : forall n (f : forall i, i <= n -> R),
 (forall i H H', f i H [<] f (S i) H') -> forall i j Hi Hj, i < j -> f i Hi [<] f j Hj.
Proof.
 simple induction j.
  intros Hi Hj H0; exfalso; inversion H0.
 clear j; intro j; intros.
 elim (le_lt_eq_dec _ _ H); intro.
  cut (j <= n); [ intro | auto with arith ].
  apply leEq_less_trans with (f j H0).
   apply less_leEq; auto with arith.
  apply X.
 generalize Hj; rewrite <- b.
 auto.
Qed.

Lemma local_mon_imp_mon'_le : forall n (f : forall i, i <= n -> R),
 (forall i H H', f i H [<] f (S i) H') -> nat_less_n_fun' f ->
 forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj.
Proof.
 intros.
 elim (le_lt_eq_dec _ _ H0); intros.
  apply less_leEq; apply local_mon_imp_mon_le with n; auto.
 apply eq_imp_leEq; auto.
Qed.

Lemma local_mon'_imp_mon'_le : forall n (f : forall i, i <= n -> R),
 (forall i H H', f i H [<=] f (S i) H') -> nat_less_n_fun' f ->
 forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj.
Proof.
 simple induction j.
  intros.
  cut (i = 0); [ intro | auto with arith ].
  apply eq_imp_leEq; apply H0; auto.
 intro m; intros.
 elim (le_lt_eq_dec _ _ H2); intro.
  cut (m <= n); [ intro | auto with arith ].
  apply leEq_transitive with (f m H3); auto.
  apply H1; auto with arith.
 apply eq_imp_leEq; apply H0; assumption.
Qed.

Lemma local_mon'_imp_mon'2_le : forall n (f : forall i, i <= n -> R),
 (forall i H H', f i H [<=] f (S i) H') -> forall i j Hi Hj, i < j -> f i Hi [<=] f j Hj.
Proof.
 intros; induction  j as [| j Hrecj].
  exfalso; inversion H0.
 elim (le_lt_eq_dec _ _ H0); intro.
  cut (j <= n); [ intro | auto with arith ].
  apply leEq_transitive with (f j H1).
   apply Hrecj; auto with arith.
  apply H.
 generalize Hj; rewrite <- b.
 intro; apply H.
Qed.

Lemma mon_imp_mon'_le : forall n (f : forall i, i <= n -> R), nat_less_n_fun' f ->
 (forall i j Hi Hj, i < j -> f i Hi [<] f j Hj) -> forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj.
Proof.
 intros.
 elim (le_lt_eq_dec _ _ H0); intro.
  apply less_leEq; auto.
 apply eq_imp_leEq; auto.
Qed.

Lemma mon_imp_inj_le : forall n (f : forall i, i <= n -> R),
 (forall i j Hi Hj, i < j -> f i Hi [<] f j Hj) -> forall i j Hi Hj, f i Hi [=] f j Hj -> i = j.
Proof.
 intros.
 cut (~ i <> j); intro.
  clear H X Hj Hi; lia.
 cut (i < j \/ j < i); [ intro | apply not_eq; auto ].
 inversion_clear H1; (exfalso; cut (f i Hi [#] f j Hj);
   [ apply eq_imp_not_ap; assumption | idtac ]).
  apply less_imp_ap; auto.
 apply Greater_imp_ap; auto.
Qed.

(**
A similar result for %{\em %partial%}% functions.
*)

Lemma part_mon_imp_mon' : forall F (I : R -> CProp), (forall x, I x -> Dom F x) ->
 (forall x y Hx Hy, I x -> I y -> x [<] y -> F x Hx [<] F y Hy) ->
 forall x y Hx Hy, I x -> I y -> x [<=] y -> F x Hx [<=] F y Hy.
Proof.
 intros.
 rewrite -> leEq_def.
 intro.
 cut (x [=] y); intros.
  apply (less_irreflexive_unfolded _ (F x Hx)).
  astepl (F y Hy); auto.
 apply leEq_imp_eq.
  firstorder using leEq_def.
 rewrite -> leEq_def.
 intro.
 apply (less_irreflexive_unfolded _ (F x Hx)).
 apply less_transitive_unfolded with (F y Hy); firstorder using leEq_def.
Qed.

End Monotonous_functions.


Require Import Frap.

Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Proving Evenness *)

Inductive isEven : nat -> Prop :=
| Even_O : isEven O
| Even_SS : forall n, isEven n -> isEven (S (S n)).

Theorem even_256 : isEven 256.
Proof.
Admitted.

(** * Reifying the Syntax of a Trivial Tautology Language *)

Theorem true_galore : (True /\ True) -> (True \/ (True /\ (True -> True))).
Proof.
  tauto.
Qed.

Print true_galore.

(** * A Monoid Expression Simplifier *)

Section monoid.
  Variable A : Set.
  Variable e : A.
  Variable f : A -> A -> A.

  Infix "+" := f.

  Hypothesis assoc : forall a b c, (a + b) + c = a + (b + c).
  Hypothesis identl : forall a, e + a = a.
  Hypothesis identr : forall a, a + e = a.

  Inductive mexp : Set :=
  | Ident : mexp
  | Var : A -> mexp
  | Op : mexp -> mexp -> mexp.

  (* Next, we write an interpretation function. *)

  Fixpoint mdenote (me : mexp) : A :=
    match me with
      | Ident => e
      | Var v => v
      | Op me1 me2 => mdenote me1 + mdenote me2
    end.

  Ltac reify me :=
    match me with
      | e => Ident
      | ?me1 + ?me2 =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          constr:(Op r1 r2)
      | _ => constr:(Var me)
    end.

  (*Ltac monoid :=
    match goal with
      | [ |- ?me1 = ?me2 ] =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          change (mdenote r1 = mdenote r2);
            apply monoid_reflect; simplify
    end.

  Theorem t1 : forall a b c d, a + b + c + d = a + (b + c) + d.
    simplify; monoid.
    reflexivity.
  Qed.*)
End monoid.

(** * Set Simplification for Model Checking *)

(* Let's take a closer look at model-checking proofs like from last class. *)

(* Here's a simple transition system, where state is just a [nat], and where
 * each step subtracts 1 or 2. *)

Inductive subtract_step : nat -> nat -> Prop :=
| Subtract1 : forall n, subtract_step (S n) n
| Subtract2 : forall n, subtract_step (S (S n)) n.

Definition subtract_sys (n : nat) : trsys nat := {|
  Initial := {n};
  Step := subtract_step
|}.

Lemma subtract_ok :
  invariantFor (subtract_sys 5)
               (fun n => n <= 5).
Proof.
  eapply invariant_weaken.

  apply multiStepClosure_ok.
  simplify.
  (* Here we'll see that the Frap libary uses slightly different, optimized
   * versions of the model-checking relations.  For instance, [multiStepClosure]
   * takes an extra set argument, the _worklist_ recording newly discovered
   * states.  There is no point in following edges out of states that were
   * already known at previous steps. *)

  (* Now, some more manual iterations: *)
  eapply MscStep.
  closure.
  (* Ew.  What a big, ugly set expression.  Let's shrink it down to something
   * more readable, with duplicates removed, etc. *)
  simplify.
  (* How does the Frap library do that?  Proof by reflection is a big part of
   * it!  Let's develop a baby version of that automation.  The full-scale
   * version is in file Sets.v. *)
Abort.

(* Back to our example, which we can now finish without calling [simplify] to
 * reduces trees of union operations. *)
(*Lemma subtract_ok :
  invariantFor (subtract_sys 5)
               (fun n => n <= 5).
Proof.
  eapply invariant_weaken.

  apply multiStepClosure_ok.
  simplify.

  (* Now, some more manual iterations: *)
  eapply MscStep.
  closure.
  simplify_set.
  (* Success!  One subexpression shrunk.  Now for the other. *)
  simplify_set.
  (* Our automation doesn't handle set difference, so we finish up calling the
   * library tactic. *)
  simplify.

  eapply MscStep.
  closure.
  simplify_set.
  simplify_set.
  simplify.

  eapply MscStep.
  closure.
  simplify_set.
  simplify_set.
  simplify.

  eapply MscStep.
  closure.
  simplify_set.
  simplify_set.
  simplify.

  model_check_done.

  simplify.
  linear_arithmetic.
Qed.*)

(** * A Smarter Tautology Solver *)

Definition propvar := nat.

Inductive formula : Set :=
| Atomic : propvar -> formula
| Truth : formula
| Falsehood : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula.

Definition asgn := nat -> Prop.

Fixpoint formulaDenote (atomics : asgn) (f : formula) : Prop :=
  match f with
    | Atomic v => atomics v
    | Truth => True
    | Falsehood => False
    | And f1 f2 => formulaDenote atomics f1 /\ formulaDenote atomics f2
    | Or f1 f2 => formulaDenote atomics f1 \/ formulaDenote atomics f2
    | Imp f1 f2 => formulaDenote atomics f1 -> formulaDenote atomics f2
  end.

Section my_tauto.
  Variable atomics : asgn.

  Require Import ListSet.

  Definition add (s : set propvar) (v : propvar) := set_add eq_nat_dec v s.

  Fixpoint allTrue (s : set propvar) : Prop :=
    match s with
      | nil => True
      | v :: s' => atomics v /\ allTrue s'
    end.

  Theorem allTrue_add : forall v s,
    allTrue s
    -> atomics v
    -> allTrue (add s v).
  Proof.
    induct s; simplify; propositional;
      match goal with
        | [ |- context[if ?E then _ else _] ] => destruct E
      end; simplify; propositional.
  Qed.

  Theorem allTrue_In : forall v s,
    allTrue s
    -> set_In v s
    -> atomics v.
  Proof.
    induct s; simplify; equality.
  Qed.

  Fixpoint forward (f : formula) (known : set propvar) (hyp : formula)
           (cont : set propvar -> bool) : bool :=
    match hyp with
    | Atomic v => cont (add known v)
    | Truth => cont known
    | Falsehood => true
    | And h1 h2 => forward (Imp h2 f) known h1 (fun known' =>
                     forward f known' h2 cont)
    | Or h1 h2 => forward f known h1 cont && forward f known h2 cont
    | Imp _ _ => cont known
    end.

  Fixpoint backward (known : set propvar) (f : formula) : bool :=
    match f with
    | Atomic v => if In_dec eq_nat_dec v known then true else false
    | Truth => true
    | Falsehood => false
    | And f1 f2 => backward known f1 && backward known f2
    | Or f1 f2 => backward known f1 || backward known f2
    | Imp f1 f2 => forward f2 known f1 (fun known' => backward known' f2)
    end.
End my_tauto.

Lemma forward_ok : forall atomics hyp f known cont,
    forward f known hyp cont = true
    -> (forall known', allTrue atomics known'
                       -> cont known' = true
                       -> formulaDenote atomics f)
    -> allTrue atomics known
    -> formulaDenote atomics hyp
    -> formulaDenote atomics f.
Proof.
  induct hyp; simplify; propositional.

  apply H0 with (known' := add known p).
  apply allTrue_add.
  assumption.
  assumption.
  assumption.

  eapply H0.
  eassumption.
  assumption.

  eapply IHhyp1 in H.
  simplify; propositional.
  simplify.
  eapply IHhyp2.
  eassumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.

  apply andb_true_iff in H; propositional.
  eapply IHhyp1.
  eassumption.
  assumption.
  assumption.
  assumption.

  apply andb_true_iff in H; propositional.
  eapply IHhyp2.
  eassumption.
  assumption.
  assumption.
  assumption.

  eapply H0.
  eassumption.
  assumption.
Qed.

Lemma backward_ok' : forall atomics f known,
    backward known f = true
    -> allTrue atomics known
    -> formulaDenote atomics f.
Proof.
  induct f; simplify; propositional.

  cases (in_dec Nat.eq_dec p known); propositional.
  eapply allTrue_In.
  eassumption.
  unfold set_In.
  assumption.
  equality.

  equality.

  apply andb_true_iff in H; propositional.
  eapply IHf1.
  eassumption.
  assumption.

  apply andb_true_iff in H; propositional.
  eapply IHf2.
  eassumption.
  assumption.

  apply orb_true_iff in H; propositional.
  left.
  eapply IHf1.
  eassumption.
  assumption.
  right.
  eapply IHf2.
  eassumption.
  assumption.

  eapply forward_ok.
  eassumption.
  simplify.
  eapply IHf2.
  eassumption.
  assumption.
  assumption.
  assumption.
Qed.

Theorem backward_ok : forall f,
    backward [] f = true
    -> forall atomics, formulaDenote atomics f.
Proof.
  simplify.
  apply backward_ok' with (known := []).
  assumption.
  simplify.
  propositional.
Qed.

(* Find the position of an element in a list. *)
Ltac position x ls :=
  match ls with
  | [] => constr:(@None nat)
  | x :: _ => constr:(Some 0)
  | _ :: ?ls' =>
    let p := position x ls' in
    match p with
    | None => p
    | Some ?n => constr:(Some (S n))
    end
  end.

(* Compute a duplicate-free list of all variables in [P], combining it with
 * [acc]. *)
Ltac vars_in P acc :=
  match P with
  | True => acc
  | False => acc
  | ?Q1 /\ ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | ?Q1 \/ ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | ?Q1 -> ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | _ =>
    let pos := position P acc in
    match pos with
    | Some _ => acc
    | None => constr:(P :: acc)
    end
  end.

(* Reification of formula [P], with a pregenertaed list [vars] of variables it
 * may mention *)
Ltac reify_tauto' P vars :=
  match P with
  | True => Truth
  | False => Falsehood
  | ?Q1 /\ ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(And q1 q2)
  | ?Q1 \/ ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(Or q1 q2)
  | ?Q1 -> ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(Imp q1 q2)
  | _ =>
    let pos := position P vars in
    match pos with
    | Some ?pos' => constr:(Atomic pos')
    end
  end.

(* Our final tactic implementation is now fairly straightforward.  First, we
 * [intro] all quantifiers that do not bind [Prop]s.  Then we reify.  Finally,
 * we call the verified procedure through a lemma. *)

Ltac my_tauto :=
  repeat match goal with
           | [ |- forall x : ?P, _ ] =>
             match type of P with
               | Prop => fail 1
               | _ => intro
             end
         end;
  match goal with
    | [ |- ?P ] =>
      let vars := vars_in P (@nil Prop) in
      let p := reify_tauto' P vars in
      change (formulaDenote (nth_default False vars) p)
  end;
  apply backward_ok; reflexivity.

(* A few examples demonstrate how the tactic works: *)

Theorem mt1 : True.
Proof.
  my_tauto.
Qed.

Print mt1.

Theorem mt2 : forall x y : nat, x = y -> x = y.
Proof.
  my_tauto.
Qed.

Print mt2.

Theorem mt3 : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  -> y > z /\ (x < y \/ x < S y).
Proof.
  my_tauto.
Qed.

Print mt3.

Theorem mt4 : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
Proof.
  my_tauto.
Qed.

Print mt4.

Theorem mt4' : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
Proof.
  tauto.
Qed.

Print mt4'.


Require Import Basics.
Require Import Types.
Require Import Diagrams.Graph.
Require Import Diagrams.Diagram.
Require Import Diagrams.ParallelPair.
Require Import Diagrams.Cocone.
Require Import Colimits.Colimit.
Require Import HIT.Coeq.

Generalizable All Variables.

(** * Coequalizer as a colimit *)

(** In this file, we define [Coequalizer] the coequalizer of two maps as the colimit of a particuliar diagram, and then show that it is equivalent to [Coeq] the primitive coequalizer defined as an HIT. *)

(** ** [Coequalizer] *)

Section Coequalizer.

  Context {A B : Type}.

  Definition IsCoequalizer (f g : B -> A)
    := IsColimit (parallel_pair f g).

  Definition Coequalizer (f g : B -> A)
    := Colimit (parallel_pair f g).

  (** ** Equivalence with [Coeq] *)

  Context {f g : B -> A}.

  Definition cocone_Coeq : Cocone (parallel_pair f g) (Coeq f g).
  Proof.
    serapply Build_Cocone.
    + intros []; [exact (coeq o g)| exact coeq].
    + intros i j phi x; destruct i, j, phi; simpl;
      [ exact (cglue x) | reflexivity ].
  Defined.

  Lemma iscoequalizer_Coeq `{Funext}
    : IsColimit (parallel_pair f g) (Coeq f g).
  Proof.
    serapply (Build_IsColimit cocone_Coeq).
    serapply Build_UniversalCocone.
    intros X.
    serapply isequiv_adjointify.
    - intros C.
      serapply Coeq_rec.
      + exact (legs C false).
      + intros b.
        etransitivity.
        * exact (legs_comm C true false true b).
        * exact (legs_comm C true false false b)^.
    - intros C.
      serapply path_cocone.
      + intros i x; destruct i; simpl.
        * exact (legs_comm C true false false x).
        * reflexivity.
      + intros i j phi x; destruct i, j, phi; simpl.
        * hott_simpl.
          match goal with
          | [|- ap (Coeq_rec ?a ?b ?c) _ @ _ = _ ]
            => rewrite (Coeq_rec_beta_cglue a b c)
          end.
          hott_simpl.
        * reflexivity.
    - intros F.
      apply path_forall.
      match goal with
        | [|- ?G == _ ] => simple refine (Coeq_ind (fun w => G w = F w) _ _)
      end.
      + reflexivity.
      + intros b; simpl.
        rewrite transport_paths_FlFr.
        rewrite Coeq_rec_beta_cglue.
        hott_simpl.
  Defined.

  Definition equiv_Coeq_Coequalizer `{Funext}
    : Coeq f g <~> Coequalizer f g.
  Proof.
    serapply colimit_unicity.
    3: eapply iscoequalizer_Coeq.
    eapply iscolimit_colimit.
  Defined.

End Coequalizer.


Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export String.

Inductive typ : Set :=
| typ_top   : typ
| typ_bot   : typ
| typ_nat   : typ
| typ_bvar  : nat -> typ
| typ_fvar  : var -> typ
| typ_and   : typ -> typ -> typ
| typ_mu :    typ -> typ
| typ_arrow : typ -> typ -> typ
| typ_rcd : var -> typ -> typ.

Coercion typ_bvar : nat >-> typ.
Coercion typ_fvar : atom >-> typ.

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_nat         => typ_nat
  | typ_top         => typ_top
  | typ_bot         => typ_bot
  | typ_bvar J      => if K === J then U else (typ_bvar J)
  | typ_fvar X      => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_and T1 T2 => typ_and (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_mu T        => typ_mu (open_tt_rec (S K) U T)
  | typ_rcd l T => typ_rcd l (open_tt_rec K U T)
  end.

(* T type U name *)
Definition open_tt T U := open_tt_rec 0 U T.

(** Types as locally closed pre-types *)

Inductive type : typ -> Prop :=
  | type_top :
      type typ_top
  | type_nat :
      type typ_nat
  | type_bot :
      type typ_bot
  | type_var : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2)
  | type_and : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_and T1 T2)
  | type_rcd : forall l T,
      type T ->
      type (typ_rcd l T)
  | type_mu : forall L T,
      (forall X, X \notin L -> type (open_tt T (typ_fvar X))) ->
      type (typ_mu T).

Hint Constructors type : core.

Fixpoint subst_tt (Z : atom) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_bot => typ_bot
  | typ_nat => typ_nat
  | typ_bvar J => typ_bvar J
  | typ_fvar X => if X == Z then U else (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_and T1 T2 => typ_and (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_mu T => typ_mu (subst_tt Z U T)
  | typ_rcd l T => typ_rcd l (subst_tt Z U T)
  end.

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top => {}
  | typ_nat => {}
  | typ_bot => {}
  | typ_bvar J => {}
  | typ_fvar X => {{ X }}
  | typ_arrow T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_and T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_mu T => (fv_tt T)
  | typ_rcd l T => fv_tt T
  end.

Fixpoint fl_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top => {}
  | typ_nat => {}
  | typ_bot => {}
  | typ_bvar J => {}
  | typ_fvar X => {}
  | typ_arrow T1 T2 => (fl_tt T1) `union` (fl_tt T2)
  | typ_mu T => (fl_tt T)
  | typ_rcd X T => {{ X }} `union` fl_tt T
  | typ_and T1 T2 => (fl_tt T1) `union` (fl_tt T2)
  end.

Inductive binding : Set :=
  | bind_sub : binding
  | bind_typ : typ -> binding.

Definition env := list (atom * binding).
Notation empty := (@nil (atom * binding)).

Inductive WFS : env -> typ -> Prop :=
| WFS_top : forall E, WFS E typ_top
| WFS_bot : forall E, WFS E typ_bot
| WFS_nat : forall E, WFS E typ_nat
| WFS_fvar : forall X E,
    binds X bind_sub E ->
    WFS E (typ_fvar X)
| WFS_arrow : forall E A B,
    WFS E A ->
    WFS E B ->
    WFS E (typ_arrow A B)
| WFS_and : forall E A B,
    WFS E A ->
    WFS E B ->
    WFS E (typ_and A B)
| WFS_rcd : forall E l T,
    WFS E T ->
    WFS E (typ_rcd l T)
| WFS_rec : forall L E A,
    (forall  X, X \notin L ->
        WFS (X ~ bind_sub ++ E) (open_tt A (typ_rcd X (open_tt A X)))) ->
      (forall  X, X \notin L ->
        WFS (X ~ bind_sub ++ E) (open_tt A X)) ->
      WFS E (typ_mu A).

Inductive wf_env : env -> Prop :=
  | wf_env_empty :
      wf_env empty
  | wf_env_sub : forall (E : env) (X : atom) ,
      wf_env E ->
      X \notin dom E ->
      wf_env (X ~ bind_sub ++ E)
  | wf_env_typ : forall (E : env) (x : atom) (T : typ),
      wf_env E ->
      WFS E T ->
      x `notin` dom E ->
      wf_env (x ~ bind_typ T ++ E).

Inductive toplike : env -> typ -> Prop :=
| toplike_base : forall E,
     wf_env E ->
     toplike E typ_top
 | toplike_and : forall (T1 T2:typ) E,
     toplike E T1 ->
     toplike E T2 ->
     toplike E (typ_and T1 T2)
 | toplike_arrow : forall (A B:typ) E,
     toplike E B ->
     WFS E A ->
     toplike E (typ_arrow A B)
 | toplike_rcd : forall A E l,
     toplike E A ->
     toplike E (typ_rcd l A)
 | toplike_rec : forall (L:vars) (B:typ) E,
       ( forall X, X \notin  L  -> toplike (X ~ bind_sub ++ E) ( open_tt B X )  )  ->
       toplike E (typ_mu B).

Inductive Sub : env -> typ -> typ -> Prop :=
| S_nat: forall E,
    wf_env E ->
    Sub E typ_nat typ_nat
| S_fvar: forall E X,
    wf_env E ->
    WFS E (typ_fvar X) ->
    Sub E (typ_fvar X) (typ_fvar X)
| S_bot : forall E A,
    wf_env E ->
    WFS E A ->
    Sub E typ_bot A
| S_arrow: forall E A1 A2 B1 B2,
    Sub E B1 A1 ->
    Sub E A2 B2 ->
    Sub E (typ_arrow A1 A2) (typ_arrow B1 B2)
| S_and : forall E A B1 B2,
    Sub E A B1 ->
    Sub E A B2 ->
    Sub E A (typ_and B1 B2)
| S_andL : forall E A1 A2 B,
    Sub E A1 B ->
    WFS E A2 ->
    Sub E (typ_and A1 A2) B
| S_andR : forall E A1 A2 B,
    Sub E A2 B ->
    WFS E A1 ->
    Sub E (typ_and A1 A2) B
| S_rec: forall L A1 A2 E,
    (forall X,
        X \notin L -> WFS (X ~ bind_sub ++ E) (open_tt A1 X)) ->
    (forall X,
        X \notin L -> WFS (X ~ bind_sub ++ E) (open_tt A2 X)) ->
    (forall X,
        X \notin L ->
        Sub (X ~ bind_sub ++ E) (open_tt A1 (typ_rcd X (open_tt A1 X))) (open_tt A2 (typ_rcd X (open_tt A2 X)))) ->
    Sub E (typ_mu A1) (typ_mu A2)
| S_rcd : forall A B l E,
    Sub E A B ->
    Sub E (typ_rcd l A) (typ_rcd l B)
| S_top: forall A B E,
    WFS E A ->
    toplike E B ->
    Sub E A B.

Inductive Mode := Neg | Pos.

Definition flip (m : Mode) : Mode :=
  match m with
  | Neg => Pos
  | Pos => Neg
  end.

Definition equiv E A B := Sub E A B /\ Sub E B A.

Inductive dis : env -> typ -> typ -> Prop :=    (* defn dis *)
 | dis_IntArr : forall (E:env) (A1 A2:typ),
     wf_env E ->
     WFS E (typ_arrow A1 A2) ->
     dis E typ_nat (typ_arrow A1 A2)
  | dis_ArrInt : forall (E:env) (A1 A2:typ),
     wf_env E ->
     WFS E (typ_arrow A1 A2) ->
     dis E (typ_arrow A1 A2) typ_nat
  | dis_IntRec : forall (E:env) (T:typ),
     wf_env E ->
     WFS E (typ_mu T) ->
     dis E typ_nat (typ_mu T)
  | dis_RecInt : forall (E:env) (T:typ),
     wf_env E ->
     WFS E (typ_mu T) ->
     dis E (typ_mu T) typ_nat
  | dis_ArrRec : forall (E:env) (A1 A2 T:typ),
     wf_env E ->
     WFS E (typ_arrow A1 A2) ->
     WFS E (typ_mu T) ->
     dis E (typ_arrow A1 A2) (typ_mu T)
  | dis_RecArr : forall (E:env) (A1 A2 T:typ),
     wf_env E ->
     WFS E (typ_arrow A1 A2) ->
     WFS E (typ_mu T) ->
     dis E  (typ_mu T) (typ_arrow A1 A2)
  | dis_IntVar : forall (E:env) (X:atom),
     WFS E (typ_fvar X) ->
     wf_env E ->
     dis E typ_nat (typ_fvar X)
  | dis_VarInt : forall (E:env) (X:atom),
     WFS E (typ_fvar X) ->
     wf_env E ->
     dis E (typ_fvar X) typ_nat
 | dis_ArrVar : forall (E:env) (A1 A2:typ) (X:atom),
     wf_env E ->
     WFS E (typ_fvar X) ->
     WFS E (typ_arrow A1 A2) ->
     dis E (typ_arrow A1 A2) (typ_fvar X)
  | dis_VarArr : forall (E:env) (A1 A2:typ) (X:atom),
     wf_env E ->
     WFS E (typ_fvar X) ->
     WFS E (typ_arrow A1 A2) ->
     dis E (typ_fvar X) (typ_arrow A1 A2)
 | dis_RecVar : forall (E:env) (T:typ) (X:atom),
     wf_env E ->
     WFS E (typ_fvar X) ->
     WFS E (typ_mu T) ->
     dis E (typ_mu T) (typ_fvar X)
 | dis_VarRec : forall (E:env) (T:typ) (X:atom),
     wf_env E ->
     WFS E (typ_fvar X) ->
     WFS E (typ_mu T) ->
     dis E (typ_fvar X) (typ_mu T)
 | dis_IntRcd: forall E A X,
     wf_env E ->
     WFS E (typ_rcd X A) ->
     dis E typ_nat (typ_rcd X A)
 | dis_RcdInt: forall E A X,
     wf_env E ->
     WFS E (typ_rcd X A) ->
     dis E (typ_rcd X A) typ_nat
 | dis_ArrRcd: forall E A X B1 B2,
     wf_env E ->
     WFS E (typ_rcd X A) ->
     WFS E (typ_arrow B1 B2) ->
     dis E (typ_arrow B1 B2) (typ_rcd X A)
 | dis_RcdArr: forall E A X B1 B2,
     wf_env E ->
     WFS E (typ_rcd X A) ->
     WFS E (typ_arrow B1 B2) ->
     dis E (typ_rcd X A) (typ_arrow B1 B2)
 | dis_RecRcd: forall E A X B,
     wf_env E ->
     WFS E (typ_rcd X A) ->
     WFS E (typ_mu B) ->
     dis E (typ_mu B) (typ_rcd X A)
 | dis_RcdRec: forall E A X B,
     wf_env E ->
     WFS E (typ_rcd X A) ->
     WFS E (typ_mu B) ->
     dis E (typ_rcd X A) (typ_mu B)
 | dis_RcdVar: forall E A X Y,
     wf_env E ->
     WFS E (typ_rcd X A) ->
     WFS E (typ_fvar Y) ->
     dis E (typ_rcd X A) (typ_fvar Y)
 | dis_VarRcd: forall E A X Y,
     wf_env E ->
     WFS E (typ_rcd X A) ->
     WFS E (typ_fvar Y) ->
     dis E (typ_fvar Y) (typ_rcd X A)
 | dis_topL : forall (E:env) (A B:typ) ,
     wf_env E ->
     WFS E A ->
     toplike E B ->
     dis E A B
 | dis_topR : forall (E:env) (A B:typ) ,
     wf_env E ->
     WFS E B ->
     toplike E A ->
     dis E A B
 | dis_andL : forall (E:env) (A1 A2 B:typ),
     dis E A1 B ->
     dis E A2 B ->
     dis E (typ_and A1 A2) B
 | dis_andR : forall (E:env) (A B1 B2:typ),
     dis E A B1 ->
     dis E A B2 ->
     dis E A (typ_and B1 B2)
 | dis_VarVar : forall (E:env) (X1 X2:atom),
     wf_env E ->
     WFS E (typ_fvar X1) ->
     WFS E (typ_fvar X2) ->
     X1 <> X2 ->
     dis E (typ_fvar X1) (typ_fvar X2)
 | dis_ArrArr : forall (E:env) (A1 A2 B1 B2:typ),
     WFS E A1 ->
     WFS E B1 ->
     dis E A2 B2 ->
     dis E (typ_arrow A1 A2) (typ_arrow B1 B2)
 | dis_RcdRcd: forall E A X B Y,
     X <> Y ->
     WFS E A ->
     WFS E B ->
     wf_env E ->
     dis E (typ_rcd X A) (typ_rcd Y B)
 | dis_RcdRcdEq: forall E A X B,
     dis E A B ->
     dis E (typ_rcd X A) (typ_rcd X B)
 | dis_RecRec : forall L E A1 A2,
     ( forall X , X \notin L -> WFS ([(X, bind_sub)] ++ E) (open_tt A1 X)) ->
     ( forall X , X \notin L -> WFS ([(X, bind_sub)] ++ E) (open_tt A2 X)) ->
     ( forall  X , X \notin  L  ->  dis ((X ~ bind_sub) ++ E) (open_tt A1 X) (open_tt A2 X)) ->
     dis E (typ_mu A1) (typ_mu A2).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let E := gather_atoms_with (fun x : typ => fv_tt x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  let G := gather_atoms_with (fun x : typ => fl_tt x) in
  constr:(A `union` B `union`  E  \u F \u G).

Hint Constructors Sub WFS   wf_env toplike   dis: core.

(* ********************************************************************** *)
(** ** Properties of type substitution in types *)

(** The next lemma is the strengthened induction hypothesis for the
    lemma that follows, which states that opening a locally closed
    term is the identity.  This lemma is not otherwise independently
    useful. *)

Lemma open_tt_rec_type_aux : forall T j V i U,
  i <> j ->
  open_tt_rec j V T = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof with congruence || eauto.
  induction T; intros j V i U Neq H; simpl in *; inversion H; f_equal...
    destruct (j === n)... destruct (i === n)...
Qed.

(** Opening a locally closed term is the identity.  This lemma depends
    on the immediately preceding lemma. *)

Lemma open_tt_rec_type : forall T U k,
  type T ->
  T = open_tt_rec k U T.
Proof with auto.
  intros T U k Htyp. revert k.
  induction Htyp; intros k; simpl; f_equal...
  unfold open_tt in *.
  pick fresh X.
  apply open_tt_rec_type_aux with (j:=0) (V:=(typ_fvar X))...
Qed.

(** If a name is fresh for a term, then substituting for it is the
    identity. *)

Lemma subst_tt_fresh : forall Z U T,
   Z `notin` fv_tt T ->
   T = subst_tt Z U T.
Proof with auto.
  induction T; simpl; intro H; f_equal...
  Case "typ_fvar".
    destruct (a == Z)...
    contradict H; fsetdec.
Qed.

(** Substitution commutes with opening under certain conditions.  This
    lemma depends on the fact that opening a locally closed term is
    the identity. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P k,
  type P ->
  subst_tt X P (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_tt X P T2) (subst_tt X P T1).
Proof with auto.
  intros T1 T2 X P k WP. revert k.
  induction T1; intros k; simpl; f_equal...
  Case "typ_bvar".
    destruct (k === n); subst...
  Case "typ_fvar".
    destruct (a == X); subst... apply open_tt_rec_type...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero. *)

Lemma subst_tt_open_tt : forall T1 T2 (X:atom) P,
  type P ->
  subst_tt X P (open_tt T1 T2) = open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_open_tt_rec...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---here, we're opening the term with a variable.  In
    practice, this lemma seems to be needed as a left-to-right rewrite
    rule, when stated in its current form. *)

Lemma subst_tt_open_tt_var : forall (X Y:atom) P T,
  Y <> X ->
  type P ->
  open_tt (subst_tt X P T) Y = subst_tt X P (open_tt T Y).
Proof with congruence || auto.
  intros X Y P T Neq Wu.
  unfold open_tt.
  rewrite subst_tt_open_tt_rec...
  simpl.
  destruct (Y == X)...
Qed.

(** The next lemma states that opening a term is equivalent to first
    opening the term with a fresh name and then substituting for the
    name.  This is actually the strengthened induction hypothesis for
    the version we use in practice. *)

Lemma subst_tt_intro_rec : forall X T2 U k,
  X `notin` fv_tt T2 ->
  open_tt_rec k U T2 = subst_tt X U (open_tt_rec k (typ_fvar X) T2).
Proof with congruence || auto.
  induction T2; intros U k Fr; simpl in *; f_equal...
  Case "typ_bvar".
    destruct (k === n)... simpl. destruct (X == X)...
  Case "typ_fvar".
    destruct (a == X)... contradict Fr; fsetdec.
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero.  *)

Lemma subst_tt_intro : forall X T2 U,
  X `notin` fv_tt T2 ->
  open_tt T2 U = subst_tt X U (open_tt T2 X).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
Qed.

Lemma subst_tt_type : forall Z P T,
  type T ->
  type P ->
  type (subst_tt Z P T).
Proof with auto.
  intros Z P T HT HP.
  induction HT; simpl...
  destruct (X == Z)...
  pick fresh Y.
  apply type_mu with (L:=L \u {{Z}})...
  intros.
  rewrite subst_tt_open_tt_var...
Qed.

(* *********************************************************************** *)
(** * ## Automation *)

(** We add as hints the fact that local closure is preserved under
    substitution.  This is part of our strategy for automatically
    discharging local-closure proof obligations. *)

Hint Resolve subst_tt_type  : core.

(** We also add as hints the lemmas concerning [body_e]. *)

(** When reasoning about the [binds] relation and [map], we
    occasionally encounter situations where the binding is
    over-simplified.  The following hint undoes that simplification,
    thus enabling [Hint]s from the MetatheoryEnv library. *)

Definition relation (X:Type) := X -> X -> Prop.

Section Star.

  Variable A : Type.
  Variable R : relation A.

  Inductive star: relation A:=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

  Lemma star_one:
    forall a b, R a b -> star a b.
  Proof.
    eauto using star.
  Qed.

  Lemma star_trans:
    forall a b, star a b -> forall c, star b c -> star a c.
  Proof.
    induction 1; eauto using star.
  Qed.

  Hypothesis R_functional:
    forall a b c, R a b -> R a c -> b = c.

  Lemma star_star_inv:
    forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
  Proof.
    induction 1; intros.
    - auto.
    - inversion H1; subst.
      + right. eauto using star.
      + assert (b = b0) by (eapply R_functional; eauto). subst b0.
        apply IHstar; auto.
  Qed.

  Definition irred a : Prop := forall b, ~(R a b).

  Lemma finseq_unique:
    forall a b,
      star a b -> irred b -> forall b',
      star a b' -> irred b' ->
      b = b'.
  Proof.
    intros a b s.
    induction s; intros; eauto.
    unfold irred in H.
    destruct H0; eauto.
    assert (not (R a b)) by eauto.
    contradiction.
    destruct H1.
    unfold irred in H2.
    assert (not (R a b)) by eauto.
    contradiction.
    eapply IHs; eauto.
    assert (b = b0).
    apply R_functional with (a:=a).
    apply H.
    apply H1.
    subst.
    auto.
  Qed.

End Star.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Lists.List. Import ListNotations.
From Coq Require Import Strings.String.
Require Import maps.
Require Import smallstep.

Hint Constructors multi.

(* このオプションの章は、Pierceによる Types and Programming Languages （和訳：型システム入門）の12章に基づいています。 *)

(*------------MoreStlcと同じ----------*)

(* 構文と操作的意味 *)
Inductive ty : Type :=
  | Bool : ty
  | Arrow : ty -> ty -> ty
  | Prod : ty -> ty -> ty
.

Inductive tm : Type :=

  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm

  | pair : tm -> tm -> tm
  | fst : tm -> tm
  | snd : tm -> tm

  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm.

(* 置換 *)
Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | var y => if eqb_string x y then s else t
  | abs y T t1 =>
      abs y T (if eqb_string x y then t1 else (subst x s t1))
  | app t1 t2 => app (subst x s t1) (subst x s t2)
  | pair t1 t2 => pair (subst x s t1) (subst x s t2)
  | fst t1 => fst (subst x s t1)
  | snd t1 => snd (subst x s t1)
  | tru => tru
  | fls => fls
  | test t0 t1 t2 =>
      test (subst x s t0) (subst x s t1) (subst x s t2)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* 簡約 *)
Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (abs x T11 t12)
  | v_pair : forall v1 v2,
      value v1 ->
      value v2 ->
      value (pair v1 v2)
  | v_tru : value tru
  | v_fls : value fls
.

Hint Constructors value.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (app (abs x T11 t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1 t2')

  | ST_Pair1 : forall t1 t1' t2,
        t1 --> t1' ->
        (pair t1 t2) --> (pair t1' t2)
  | ST_Pair2 : forall v1 t2 t2',
        value v1 ->
        t2 --> t2' ->
        (pair v1 t2) --> (pair v1 t2')
  | ST_Fst : forall t1 t1',
        t1 --> t1' ->
        (fst t1) --> (fst t1')
  | ST_FstPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (fst (pair v1 v2)) --> v1
  | ST_Snd : forall t1 t1',
        t1 --> t1' ->
        (snd t1) --> (snd t1')
  | ST_SndPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (snd (pair v1 v2)) --> v2

  | ST_TestTrue : forall t1 t2,
        (test tru t1 t2) --> t1
  | ST_TestFalse : forall t1 t2,
        (test fls t1 t2) --> t2
  | ST_Test : forall t0 t0' t1 t2,
        t0 --> t0' ->
        (test t0 t1 t2) --> (test t0' t1 t2)

where "t1 '-->' t2" := (step t1 t2).

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

Notation step_normal_form := (normal_form step).

Lemma value__normal : forall t, value t -> step_normal_form t.
Proof with eauto.
  intros t H; induction H; intros [t' ST]; inversion ST...
Qed.

(* 型付け *)
Definition context := partial_map ty.

Inductive has_type : context -> tm -> ty -> Prop :=

  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (var x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (update Gamma x T11) t12 T12 ->
      has_type Gamma (abs x T11 t12) (Arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (Arrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (app t1 t2) T2

  | T_Pair : forall Gamma t1 t2 T1 T2,
      has_type Gamma t1 T1 ->
      has_type Gamma t2 T2 ->
      has_type Gamma (pair t1 t2) (Prod T1 T2)
  | T_Fst : forall Gamma t T1 T2,
      has_type Gamma t (Prod T1 T2) ->
      has_type Gamma (fst t) T1
  | T_Snd : forall Gamma t T1 T2,
      has_type Gamma t (Prod T1 T2) ->
      has_type Gamma (snd t) T2

  | T_True : forall Gamma,
      has_type Gamma tru Bool
  | T_False : forall Gamma,
      has_type Gamma fls Bool
  | T_Test : forall Gamma t0 t1 t2 T,
      has_type Gamma t0 Bool ->
      has_type Gamma t1 T ->
      has_type Gamma t2 T ->
      has_type Gamma (test t0 t1 t2) T
.

Hint Constructors has_type.

Hint Extern 2 (has_type _ (app _ _) _) => eapply T_App; auto.
Hint Extern 2 (_ = _) => compute; reflexivity.

(* コンテキスト不変性 *)
Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (abs y T11 t12)

  | afi_pair1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (pair t1 t2)
  | afi_pair2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (pair t1 t2)
  | afi_fst : forall x t,
      appears_free_in x t ->
      appears_free_in x (fst t)
  | afi_snd : forall x t,
      appears_free_in x t ->
      appears_free_in x (snd t)

  | afi_test0 : forall x t0 t1 t2,
      appears_free_in x t0 ->
      appears_free_in x (test t0 t1 t2)
  | afi_test1 : forall x t0 t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (test t0 t1 t2)
  | afi_test2 : forall x t0 t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (test t0 t1 t2)
.

Hint Constructors appears_free_in.

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  -
    apply T_Var... rewrite <- Heqv...
  -
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold update, t_update. destruct (eqb_stringP x y)...
  -
    apply T_Pair...
  -
    eapply T_Test...
Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; inversion Hafi; subst...
  -
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...
Qed.

Corollary typable_empty__closed : forall t T,
    has_type empty t T ->
    closed t.
Proof.
  intros. unfold closed. intros x H1.
  destruct (free_in_context _ _ _ _ H1 H) as [T' C].
  inversion C. Qed.

(* 保存 *)
Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (update Gamma x U) t S ->
     has_type empty v U ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  induction t;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  -
    simpl. rename s into y.
    unfold update, t_update in H1.
    destruct (eqb_stringP x y).
    +

      subst.
      inversion H1; subst. clear H1.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    +

      apply T_Var...
  -
    rename s into y. rename t into T11.
    apply T_Abs...
    destruct (eqb_stringP x y).
    +

      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (eqb_string y x)...
    +

      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y z)...
      subst. rewrite false_eqb_string...
Qed.

Theorem preservation : forall t t' T,
     has_type empty t T ->
     t --> t' ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  -

    inversion HE; subst...
    +

      apply substitution_preserves_typing with T1...
      inversion HT1...
  -
    inversion HT...
  -
    inversion HT...
Qed.

(* 決定性 *)
Lemma step_deterministic :
   deterministic step.
Proof with eauto.
   unfold deterministic.
   intros t t' t'' E1 E2.
   generalize dependent t''.
   induction E1; intros t'' E2; inversion E2; subst; clear E2...
   - inversion H3.
   - exfalso; apply value__normal in H...
   - inversion E1.
   - f_equal...
   - exfalso; apply value__normal in H1...
   - exfalso; apply value__normal in H3...
   - exfalso; apply value__normal in H...
   - f_equal...
   - f_equal...
   - exfalso; apply value__normal in H1...
   - exfalso; apply value__normal in H...
   - f_equal...
   - f_equal...
   - exfalso.
     inversion E1; subst.
     + apply value__normal in H0...
     + apply value__normal in H1...
   - exfalso.
     inversion H2; subst.
     + apply value__normal in H...
     + apply value__normal in H0...
   - f_equal...
   - exfalso.
     inversion E1; subst.
     + apply value__normal in H0...
     + apply value__normal in H1...
   - exfalso.
     inversion H2; subst.
     + apply value__normal in H...
     + apply value__normal in H0...
   -
       inversion H3.
   -
       inversion H3.
   - inversion E1.
   - inversion E1.
   - f_equal...
Qed.

(*------------MoreStlcと同じ----------*)

(*----------------正規化---------------*)
(*
 ゴールはすべての型付けされた項が正規形に簡約されることの証明です。
 すべての型付けされた項が値になるということを証明したほうが便利。
  この強い方は、いずれにしろ弱い方から進行補題を使って得ることができますが(なぜでしょう？)、 最初から強い方を証明すれば進行性は必要ありません。
 そして、進行性を再び証明することは上では行いませんでした。
 *)

Definition halts (t:tm) : Prop := exists t', t -->* t' /\ value t'.

Lemma value_halts : forall v, value v -> halts v.
Proof.
  intros v H. unfold halts.
  exists v. split.
  apply multi_refl.
  assumption.
Qed.

(*
 R bool t とは、tが型boolの閉じた項でtが値になって止まることである
 R (T1 -> T2) t とは、tが型 T1 -> T2 の閉じた項で、tが値になり、かつ、 R T1 s となる任意の項sについて、R T2 (t s) となることである。
 *)

(*
次のような定義は無理
定義される型がコンストラクタ引数の型の矢印の左に現れてはいけない
      Inductive R : ty -> tm -> Prop :=
      | R_bool : forall b t, has_type empty t Bool ->
                      halts t ->
                      R Bool t
      | R_arrow : forall T1 T2 t, has_type empty t (Arrow T1 T2) ->
                      halts t ->
                      (forall s, R T1 s -> R T2 (app t s)) ->
                      R (Arrow T1 T2) t.
*)

Fixpoint R (T:ty) (t:tm) {struct T} : Prop :=
  has_type empty t T /\ halts t /\
  (match T with
   | Bool => True
   | Arrow T1 T2 => (forall s, R T1 s -> R T2 (app t s))

   | Prod T1 T2 => False
   end).

Lemma R_halts : forall {T} {t}, R T t -> halts t.
Proof.
  intros. destruct T; unfold R in H; inversion H; inversion H1; assumption.
Qed.

Lemma R_typable_empty : forall {T} {t}, R T t -> has_type empty t T.
Proof.
  intros. destruct T; unfold R in H; inversion H; inversion H1; assumption.
Qed.

(* R_T の要素であるか否かは簡約によって変化しない *)
Lemma step_preserves_halting : forall t t', (t --> t') -> (halts t <-> halts t').
Proof.
 intros t t' ST. unfold halts.
 split.
 -
  intros [t'' [STM V]].
  inversion STM; subst.
   exfalso. apply value__normal in V. unfold normal_form in V. apply V. exists t'. auto.
   rewrite (step_deterministic _ _ _ ST H). exists t''. split; assumption.
 -
  intros [t'0 [STM V]].
  exists t'0. split; eauto.
Qed.

Lemma step_preserves_R : forall T t t', (t --> t') -> R T t -> R T t'.
Proof.
 induction T; intros t t' E Rt; unfold R; fold R; unfold R in Rt; fold R in Rt;
               destruct Rt as [typable_empty_t [halts_t RRt]].
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  auto.
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  intros.
  eapply IHT2.
  apply ST_App1. apply E.
  apply RRt; auto.
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto. assumption.
Qed.

Lemma multistep_preserves_R : forall T t t',
  (t -->* t') -> R T t -> R T t'.
Proof.
  intros T t t' STM; induction STM; intros.
  assumption.
  apply IHSTM. eapply step_preserves_R. apply H. assumption.
Qed.

Lemma step_preserves_R' : forall T t t',
  has_type empty t T -> (t --> t') -> R T t' -> R T t.
Proof with eauto.

  induction T; intros;
    destruct H1 as [H1 [H2 H3]].
  -
    split... apply step_preserves_halting in H0. apply H0 in H2. split...
  -
    split... split. apply step_preserves_halting with (t' := t')...
    intros.
    eapply IHT2...
    eapply T_App. apply H. apply R_typable_empty. apply H4.
  -
    split... split... apply step_preserves_halting with (t':= t')...
Qed.

Lemma multistep_preserves_R' : forall T t t',
  has_type empty t T -> (t -->* t') -> R T t' -> R T t.
Proof.
  intros T t t' HT STM.
  induction STM; intros.
    assumption.
    eapply step_preserves_R'. assumption. apply H. apply IHSTM.
    eapply preservation; eauto. auto.
Qed.

(* 多重置換、多重拡張、インスタンス化 *)
(* 多重置換(multiple substitutions)と型付けコンテキストの多重拡張(multiple extensions)についての事実 *)

(* 多重置換 *)
Definition env := list (string * tm).

Fixpoint msubst (ss:env) (t:tm) {struct ss} : tm :=
match ss with
| nil => t
| ((x,s)::ss') => msubst ss' ([x:=s]t)
end.

(* 型割当て *)
Definition tass := list (string * ty).

Fixpoint mupdate (Gamma : context) (xts : tass) :=
  match xts with
  | nil => Gamma
  | ((x,v)::xts') => update (mupdate Gamma xts') x v
  end.

Fixpoint lookup {X:Set} (k : string) (l : list (string * X)) {struct l}
              : option X :=
  match l with
    | nil => None
    | (j,x) :: l' =>
      if eqb_string j k then Some x else lookup k l'
  end.

Fixpoint drop {X:Set} (n:string) (nxs:list (string * X)) {struct nxs}
            : list (string * X) :=
  match nxs with
    | nil => nil
    | ((n',x)::nxs') =>
        if eqb_string n' n then drop n nxs'
        else (n',x)::(drop n nxs')
  end.

(* インスタンス化 *)
Inductive instantiation : tass -> env -> Prop :=
| V_nil :
    instantiation nil nil
| V_cons : forall x T v c e,
    value v -> R T v ->
    instantiation c e ->
    instantiation ((x,T)::c) ((x,v)::e).

(* 置換についての補題 *)
Lemma vacuous_substitution : forall t x,
     ~ appears_free_in x t ->
     forall t', [x:=t']t = t.
Proof with eauto.
  induction t; intros; try solve_by_invert; simpl...
  -
    destruct (eqb_string x s) eqn:IH...
    destruct H. apply eqb_string_true_iff in IH; subst...
  -
    rewrite IHt1... rewrite IHt2...
  -
    destruct (eqb_string x s) eqn:IH...
    apply eqb_string_false_iff in IH. rewrite IHt...
  -
    rewrite IHt2... rewrite IHt1...
  -
    rewrite IHt...
  -
    rewrite IHt...
  -
    rewrite IHt1... rewrite IHt2... rewrite IHt3...
Qed.

Lemma subst_closed: forall t,
     closed t ->
     forall x t', [x:=t']t = t.
Proof.
  intros. apply vacuous_substitution. apply H. Qed.

Lemma subst_not_afi : forall t x v,
    closed v -> ~ appears_free_in x ([x:=v]t).
Proof with eauto.   unfold closed, not.
  induction t; intros x v P A; simpl in A.
    -
     destruct (eqb_stringP x s)...
     inversion A; subst. auto.
    -
     inversion A; subst...
    -
     destruct (eqb_stringP x s)...
     + inversion A; subst...
     + inversion A; subst...
    -
     inversion A; subst...
    -
     inversion A; subst...
    -
     inversion A; subst...
    -
     inversion A.
    -
     inversion A.
    -
     inversion A; subst...
Qed.

Lemma duplicate_subst : forall t' x t v,
  closed v -> [x:=t]([x:=v]t') = [x:=v]t'.
Proof.
  intros. eapply vacuous_substitution. apply subst_not_afi. auto.
Qed.

Lemma swap_subst : forall t x x1 v v1,
    x <> x1 ->
    closed v -> closed v1 ->
    [x1:=v1]([x:=v]t) = [x:=v]([x1:=v1]t).
Proof with eauto.
 induction t; intros; simpl; try reflexivity.
  -
   destruct (eqb_stringP x s); destruct (eqb_stringP x1 s).
   + subst. exfalso...
   + subst. simpl. rewrite <- eqb_string_refl. apply subst_closed...
   + subst. simpl. rewrite <- eqb_string_refl. rewrite subst_closed...
   + simpl. rewrite false_eqb_string... rewrite false_eqb_string...
  -
    rewrite IHt1... rewrite IHt2...
  -
    destruct (eqb_string x1 s) eqn:IH1... destruct (eqb_string x s) eqn:IH...
    rewrite IHt...
  -
    rewrite IHt1... rewrite IHt2...
  -
    rewrite IHt...
  -
    rewrite IHt...
  -
    rewrite IHt1... rewrite IHt2... rewrite IHt3...
Qed.

(* 多重置換の性質 *)

Lemma msubst_closed: forall t, closed t -> forall ss, msubst ss t = t.
Proof.
  induction ss.
    reflexivity.
    destruct a. simpl. rewrite subst_closed; assumption.
Qed.

(* 閉じた環境とは、閉じた項のみを含む環境 *)
Fixpoint closed_env (env:env) {struct env} :=
  match env with
  | nil => True
  | (x,t)::env' => closed t /\ closed_env env'
  end.

Lemma subst_msubst: forall env x v t, closed v -> closed_env env ->
    msubst env ([x:=v]t) = [x:=v](msubst (drop x env) t).
Proof.
  induction env0; intros; auto.
  destruct a. simpl.
  inversion H0. fold closed_env in H2.
  destruct (eqb_stringP s x).
  - subst. rewrite duplicate_subst; auto.
  - simpl. rewrite swap_subst; eauto.
Qed.

Lemma msubst_var: forall ss x, closed_env ss ->
   msubst ss (var x) =
   match lookup x ss with
   | Some t => t
   | None => var x
  end.
Proof.
  induction ss; intros.
    reflexivity.
    destruct a.
     simpl. destruct (eqb_string s x).
      apply msubst_closed. inversion H; auto.
      apply IHss. inversion H; auto.
Qed.

Lemma msubst_abs: forall ss x T t,
  msubst ss (abs x T t) = abs x T (msubst (drop x ss) t).
Proof.
  induction ss; intros.
    reflexivity.
    destruct a.
      simpl. destruct (eqb_string s x); simpl; auto.
Qed.

Lemma msubst_app : forall ss t1 t2, msubst ss (app t1 t2) = app (msubst ss t1) (msubst ss t2).
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite <- IHss. auto.
Qed.

(* 多重拡張の性質 *)

Lemma mupdate_lookup : forall (c : tass) (x:string),
    lookup x c = (mupdate empty c) x.
Proof.
  induction c; intros.
    auto.
    destruct a. unfold lookup, mupdate, update, t_update. destruct (eqb_string s x); auto.
Qed.

Lemma mupdate_drop : forall (c: tass) Gamma x x',
      mupdate Gamma (drop x c) x'
    = if eqb_string x x' then Gamma x' else mupdate Gamma c x'.
Proof.
  induction c; intros.
  - destruct (eqb_stringP x x'); auto.
  - destruct a. simpl.
    destruct (eqb_stringP s x).
    + subst. rewrite IHc.
      unfold update, t_update. destruct (eqb_stringP x x'); auto.
    + simpl. unfold update, t_update. destruct (eqb_stringP s x'); auto.
      subst. rewrite false_eqb_string; congruence.
Qed.

(* インスタンス化の性質 *)
Lemma instantiation_domains_match: forall {c} {e},
    instantiation c e ->
    forall {x} {T},
      lookup x c = Some T -> exists t, lookup x e = Some t.
Proof.
  intros c e V. induction V; intros x0 T0 C.
    solve_by_invert.
    simpl in *.
    destruct (eqb_string x x0); eauto.
Qed.

Lemma instantiation_env_closed : forall c e,
  instantiation c e -> closed_env e.
Proof.
  intros c e V; induction V; intros.
    econstructor.
    unfold closed_env. fold closed_env.
    split. eapply typable_empty__closed. eapply R_typable_empty. eauto.
        auto.
Qed.

Lemma instantiation_R : forall c e,
    instantiation c e ->
    forall x t T,
      lookup x c = Some T ->
      lookup x e = Some t -> R T t.
Proof.
  intros c e V. induction V; intros x' t' T' G E.
    solve_by_invert.
    unfold lookup in *. destruct (eqb_string x x').
      inversion G; inversion E; subst. auto.
      eauto.
Qed.

Lemma instantiation_drop : forall c env,
    instantiation c env ->
    forall x, instantiation (drop x c) (drop x env).
Proof.
  intros c e V. induction V.
    intros. simpl. constructor.
    intros. unfold drop. destruct (eqb_string x x0); auto. constructor; eauto.
Qed.

(* multistep ==>* についての合同補題 *)
Lemma multistep_App2 : forall v t t',
  value v -> (t -->* t') -> (app v t) -->* (app v t').
Proof.
  intros v t t' V STM. induction STM.
   apply multi_refl.
   eapply multi_step.
     apply ST_App2; eauto. auto.
Qed.

(* R補題 *)
Lemma msubst_preserves_typing : forall c e,
     instantiation c e ->
     forall Gamma t S, has_type (mupdate Gamma c) t S ->
     has_type Gamma (msubst e t) S.
Proof.
  induction 1; intros.
    simpl in H. simpl. auto.
    simpl in H2. simpl.
    apply IHinstantiation.
    eapply substitution_preserves_typing; eauto.
    apply (R_typable_empty H0).
Qed.

Lemma msubst_pair : forall ss t1 t2,
  msubst ss (pair t1 t2) = pair (msubst ss t1) (msubst ss t2).
Proof.
   induction ss; intros.
     auto.
     destruct a. simpl. auto.
Qed.

Lemma msubst_true : forall ss, msubst ss tru = tru.
Proof.
  induction ss; intros.
    auto.
    destruct a.
       simpl. auto.
Qed.

Lemma msubst_false : forall ss, msubst ss fls = fls.
Proof.
  induction ss; intros.
    auto.
    destruct a.
       simpl. auto.
Qed.

Lemma msubst_if : forall ss t0 t1 t2,
  msubst ss (test t0 t1 t2) = test (msubst ss t0) (msubst ss t1) (msubst ss t2).
Proof.
   induction ss; intros.
     auto.
     destruct a. simpl. auto.
Qed.

Lemma multistep_If : forall t1 t1' t2 t3,
  (t1 -->* t1') -> (test t1 t2 t3) -->* (test t1' t2 t3).
Proof.
  intros t1 t1' t2 t3 STM. induction STM.
  apply multi_refl.
  eapply multi_step.
  apply ST_Test; eauto. auto.
Qed.

Lemma multistep_pair1 : forall t1 t1' t2,
  (t1 -->* t1') -> (pair t1 t2) -->* (pair t1' t2).
Proof.
  intros. induction H.
  auto. eapply multi_step. apply ST_Pair1. apply H.
  auto.
Qed.

Lemma multistep_pair2 : forall t1 t2' t2,
    value t1 -> t2 -->* t2' -> (pair t1 t2) -->* (pair t1 t2').
Proof.
  intros. induction H0.
  auto. eapply multi_step. apply ST_Pair2. apply H.
  apply H0.
  auto.
Qed.

Lemma multistep_pair : forall t1 t1' t2 t2',
  (t1 -->* t1') -> (value t1') -> (t2 -->* t2') -> (pair t1 t2) -->* (pair t1' t2').
Proof.
  intros. induction H. destruct H1. auto. eapply multi_step.
  apply ST_Pair2. assumption. apply H. apply multistep_pair2. assumption. assumption.
  eapply multi_step. apply ST_Pair1. apply H. apply IHmulti in H0. assumption.
Qed.

(* メインの補題 *)

Lemma msubst_R : forall c env t T,
    has_type (mupdate empty c) t T ->
    instantiation c env ->
    R T (msubst env t).
Proof.
  intros c env0 t T HT V.
  generalize dependent env0.
  remember (mupdate empty c) as Gamma.
  assert (forall x, Gamma x = lookup x c).
    intros. rewrite HeqGamma. rewrite mupdate_lookup. auto.
  clear HeqGamma.
  generalize dependent c.
  induction HT; intros.

  -
   rewrite H0 in H. destruct (instantiation_domains_match V H) as [t P].
   eapply instantiation_R; eauto.
   rewrite msubst_var. rewrite P. auto. eapply instantiation_env_closed; eauto.

  -
    rewrite msubst_abs.
    assert (WT: has_type empty (abs x T11 (msubst (drop x env0) t12)) (Arrow T11 T12)).
    { eapply T_Abs. eapply msubst_preserves_typing.
      { eapply instantiation_drop; eauto. }
      eapply context_invariance.
      { apply HT. }
      intros.
      unfold update, t_update. rewrite mupdate_drop. destruct (eqb_stringP x x0).
      + auto.
      + rewrite H.
        clear - c n. induction c.
        simpl. rewrite false_eqb_string; auto.
        simpl. destruct a. unfold update, t_update.
        destruct (eqb_string s x0); auto. }
    unfold R. fold R. split.
       auto.
     split. apply value_halts. apply v_abs.
     intros.
     destruct (R_halts H0) as [v [P Q]].
     pose proof (multistep_preserves_R _ _ _ P H0).
     apply multistep_preserves_R' with (msubst ((x,v)::env0) t12).
       eapply T_App. eauto.
       apply R_typable_empty; auto.
       eapply multi_trans. eapply multistep_App2; eauto.
       eapply multi_R.
       simpl. rewrite subst_msubst.
       eapply ST_AppAbs; eauto.
       eapply typable_empty__closed.
       apply (R_typable_empty H1).
       eapply instantiation_env_closed; eauto.
       eapply (IHHT ((x,T11)::c)).
          intros. unfold update, t_update, lookup. destruct (eqb_string x x0); auto.
       constructor; auto.

  -
    rewrite msubst_app.
    destruct (IHHT1 c H env0 V) as [_ [_ P1]].
    pose proof (IHHT2 c H env0 V) as P2. fold R in P1. auto.
  -
    rewrite msubst_pair.
    generalize V; intro VV.
    apply IHHT1 with (env0:= env0) in V; try assumption.
    apply IHHT2 with (env0:= env0) in VV; try assumption.
    pose proof (R_halts V) as V0; pose proof (R_halts VV) as VV0.
    apply R_typable_empty in V.
    apply R_typable_empty in VV.
    destruct V0 as [v [V1 V2]]. destruct VV0 as [vv [VV1 VV2]].

    split. constructor; assumption.
    split. unfold halts. exists (pair v vv). split. apply multistep_pair; assumption.
    constructor; assumption.
    admit.

  -
    apply IHHT with (env0:= env0) in H.
    inversion H.
    inversion H1.
    inversion H3.
    apply V.
  -
    apply IHHT with (env0:= env0) in H; try assumption.
    inversion H.
    inversion H1.
    inversion H3.
  -
    rewrite msubst_true.
    split. apply T_True. split... unfold halts. exists tru. split. apply multi_refl. constructor. constructor.
  -
    rewrite msubst_false. split. apply T_False. split. exists fls. split. constructor. constructor. constructor.
  -
    rewrite msubst_if.
    assert (WT: has_type empty (test (msubst env0 t0) (msubst env0 t1) (msubst env0 t2)) T).
      apply T_Test; eapply msubst_preserves_typing; eauto;
        eapply context_invariance; eauto; intros; rewrite <- mupdate_lookup;  auto.

    pose proof (IHHT1 c H env0 V) as IH1.
    destruct (R_halts IH1) as [v [P Q]].
    assert (R Bool v).
        eapply multistep_preserves_R. apply P. apply IH1.
   pose proof (R_typable_empty IH1).
   inversion Q; subst.
   (* abs : impossible *)
   inversion H0.
   inversion H2.

    (* pair : impossible *)
   inversion H0.
   inversion H4.

    (* true *)
    eapply multistep_preserves_R' with (msubst env0 t1). subst.
    assumption.
    eapply multi_trans.
    apply multistep_If. eapply P.
    eapply multi_R. apply ST_TestTrue.
    apply (IHHT2 c H env0 V).

    (* false *)
    eapply multistep_preserves_R' with (msubst env0 t2).
    assumption.
    eapply multi_trans. apply multistep_If. eapply P.
    eapply multi_R. apply ST_TestFalse.
    apply (IHHT3 c H env0 V).
Admitted.

Theorem normalization : forall t T, has_type empty t T -> halts t.
Proof.
  intros.
  replace t with (msubst nil t) by reflexivity.
  apply (@R_halts T).
  apply (msubst_R nil); eauto.
  eapply V_nil.
Qed.


Require Export Ensembles.
From ZornsLemma Require Import EnsemblesImplicit.
From ZornsLemma Require Export Families.
From ZornsLemma Require Export IndexedFamilies.
From ZornsLemma Require Export FiniteTypes.
From ZornsLemma Require Import EnsemblesSpec.

Record TopologicalSpace : Type := {
  point_set : Type;
  open : Ensemble point_set -> Prop;
  open_family_union : forall F : Family point_set,
    (forall S : Ensemble point_set, In F S -> open S) ->
    open (FamilyUnion F);
  open_intersection2: forall U V:Ensemble point_set,
    open U -> open V -> open (Intersection U V);
  open_full : open Full_set
}.

Arguments open {t}.
Arguments open_family_union {t}.
Arguments open_intersection2 {t}.

Lemma open_empty: forall X:TopologicalSpace,
  open (@Empty_set (point_set X)).
Proof.
intros.
rewrite <- empty_family_union.
apply open_family_union.
intros.
destruct H.
Qed.

Lemma open_union2: forall {X:TopologicalSpace}
  (U V:Ensemble (point_set X)), open U -> open V -> open (Union U V).
Proof.
intros.
assert (Union U V = FamilyUnion (Couple U V)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
exists U; auto with sets.
exists V; auto with sets.
destruct H1.
destruct H1.
left; trivial.
right; trivial.

rewrite H1; apply open_family_union.
intros.
destruct H2; trivial.
Qed.

Lemma open_indexed_union: forall {X:TopologicalSpace} {A:Type}
  (F:IndexedFamily A (point_set X)),
  (forall a:A, open (F a)) -> open (IndexedUnion F).
Proof.
intros.
rewrite indexed_to_family_union.
apply open_family_union.
intros.
destruct H0.
rewrite H1; apply H.
Qed.

Lemma open_finite_indexed_intersection:
  forall {X:TopologicalSpace} {A:Type}
    (F:IndexedFamily A (point_set X)),
    FiniteT A -> (forall a:A, open (F a)) ->
    open (IndexedIntersection F).
Proof.
intros.
induction H.
rewrite empty_indexed_intersection.
apply open_full.

assert (IndexedIntersection F = Intersection
  (IndexedIntersection (fun x:T => F (Some x)))
  (F None)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
constructor.
constructor.
intros; apply H1.
apply H1.
destruct H1.
destruct H1.
constructor.
destruct a.
apply H1.
apply H2.
rewrite H1.
apply open_intersection2.
apply IHFiniteT.
intros; apply H0.
apply H0.

destruct H1.
assert (IndexedIntersection F =
  IndexedIntersection (fun x:X0 => F (f x))).
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct H3.
intro; apply H3.
constructor.
destruct H3.
intro; rewrite <- H2 with a.
apply H3.
rewrite H3.
apply IHFiniteT.
intro; apply H0.
Qed.

Definition closed {X:TopologicalSpace} (F:Ensemble (point_set X)) :=
  open (Ensembles.Complement F).

Lemma closed_complement_open: forall {X:TopologicalSpace}
  (U:Ensemble (point_set X)), closed (Ensembles.Complement U) ->
  open U.
Proof.
intros.
red in H.
rewrite Complement_Complement in H.
assumption.
Qed.

Lemma closed_union2: forall {X:TopologicalSpace}
  (F G:Ensemble (point_set X)),
  closed F -> closed G -> closed (Union F G).
Proof.
intros.
red in H, H0.
red.
assert (Ensembles.Complement (Union F G) =
  Intersection (Ensembles.Complement F)
               (Ensembles.Complement G)).
unfold Ensembles.Complement.
apply Extensionality_Ensembles; split; red; intros.
constructor.
auto with sets.
auto with sets.
destruct H1.
red; red; intro.
destruct H3.
apply (H1 H3).
apply (H2 H3).

rewrite H1.
apply open_intersection2; assumption.
Qed.

Lemma closed_intersection2: forall {X:TopologicalSpace}
  (F G:Ensemble (point_set X)),
  closed F -> closed G -> closed (Intersection F G).
Proof.
intros.
red in H, H0.
red.
assert (Ensembles.Complement (Intersection F G) =
  Union (Ensembles.Complement F)
        (Ensembles.Complement G)).
apply Extensionality_Ensembles; split; red; intros.
apply NNPP.
red; intro.
unfold Ensembles.Complement in H1.
unfold In in H1.
contradict H1.
constructor.
apply NNPP.
red; intro.
auto with sets.
apply NNPP.
red; intro.
auto with sets.

red; red; intro.
destruct H2.
destruct H1; auto with sets.

rewrite H1; apply open_union2; trivial.
Qed.

Lemma closed_family_intersection: forall {X:TopologicalSpace}
  (F:Family (point_set X)),
  (forall S:Ensemble (point_set X), In F S -> closed S) ->
  closed (FamilyIntersection F).
Proof.
intros.
unfold closed in H.
red.
assert (Ensembles.Complement (FamilyIntersection F) =
  FamilyUnion [ S:Ensemble (point_set X) |
                  In F (Ensembles.Complement S) ]).
apply Extensionality_Ensembles; split; red; intros.
apply NNPP.
red; intro.
red in H0; red in H0.
contradict H0.
constructor.
intros.
apply NNPP.
red; intro.
contradict H1.
exists (Ensembles.Complement S).
constructor.
rewrite Complement_Complement; assumption.
assumption.
destruct H0.
red; red; intro.
destruct H2.
destruct H0.
pose proof (H2 _ H0).
contradiction H3.

rewrite H0; apply open_family_union.
intros.
destruct H1.
pose proof (H _ H1).
rewrite Complement_Complement in H2; assumption.
Qed.

Lemma closed_indexed_intersection: forall {X:TopologicalSpace}
  {A:Type} (F:IndexedFamily A (point_set X)),
  (forall a:A, closed (F a)) -> closed (IndexedIntersection F).
Proof.
intros.
rewrite indexed_to_family_intersection.
apply closed_family_intersection.
intros.
destruct H0.
rewrite H1; trivial.
Qed.

Lemma closed_finite_indexed_union: forall {X:TopologicalSpace}
  {A:Type} (F:IndexedFamily A (point_set X)),
  FiniteT A -> (forall a:A, closed (F a)) ->
  closed (IndexedUnion F).
Proof.
intros.
red.
assert (Ensembles.Complement (IndexedUnion F) =
  IndexedIntersection (fun a:A => Ensembles.Complement (F a))).
apply Extensionality_Ensembles; split; red; intros.
constructor.
intros.
red; red; intro.
contradiction H1.
exists a.
assumption.
destruct H1.
red; red; intro.
destruct H2.
contradiction (H1 a).

rewrite H1; apply open_finite_indexed_intersection; trivial.
Qed.

Hint Unfold closed : topology.
Hint Resolve (@open_family_union) (@open_intersection2) open_full
  open_empty (@open_union2) (@open_indexed_union)
  (@open_finite_indexed_intersection) (@closed_complement_open)
  (@closed_union2) (@closed_intersection2) (@closed_family_intersection)
  (@closed_indexed_intersection) (@closed_finite_indexed_union)
  : topology.

Section Build_from_closed_sets.

Variable X:Type.
Variable closedP : Ensemble X -> Prop.
Hypothesis closedP_empty: closedP Empty_set.
Hypothesis closedP_union2: forall F G:Ensemble X,
  closedP F -> closedP G -> closedP (Union F G).
Hypothesis closedP_family_intersection: forall F:Family X,
  (forall G:Ensemble X, In F G -> closedP G) ->
  closedP (FamilyIntersection F).

Definition Build_TopologicalSpace_from_closed_sets : TopologicalSpace.
refine (Build_TopologicalSpace X
  (fun U:Ensemble X => closedP (Ensembles.Complement U)) _ _ _).
intros.
replace (Ensembles.Complement (FamilyUnion F)) with
  (FamilyIntersection [ G:Ensemble X | In F (Ensembles.Complement G) ]).
apply closedP_family_intersection.
destruct 1.
rewrite <- Complement_Complement.
apply H; trivial.
apply Extensionality_Ensembles; split; red; intros.
intro.
destruct H1.
destruct H0.
absurd (In (Ensembles.Complement S) x).
intro.
contradiction H3.
apply H0.
constructor.
rewrite Complement_Complement; trivial.
constructor.
destruct 1.
apply NNPP; intro.
contradiction H0.
exists (Ensembles.Complement S); trivial.

intros.
replace (Ensembles.Complement (Intersection U V)) with
  (Union (Ensembles.Complement U) (Ensembles.Complement V)).
apply closedP_union2; trivial.
apply Extensionality_Ensembles; split; red; intros.
intro.
destruct H2.
destruct H1; contradiction H1.
apply NNPP; intro.
contradiction H1.
constructor; apply NNPP; intro; contradiction H2;
  [ left | right ]; trivial.

apply eq_ind with (1 := closedP_empty).
apply Extensionality_Ensembles; split; auto with sets;
  red; intros.
contradiction H.
constructor.
Defined.

Lemma Build_TopologicalSpace_from_closed_sets_closed:
  forall (F:Ensemble (point_set Build_TopologicalSpace_from_closed_sets)),
  closed F <-> closedP F.
Proof.
intros.
unfold closed.
simpl.
rewrite Complement_Complement.
split; trivial.
Qed.

End Build_from_closed_sets.

Arguments Build_TopologicalSpace_from_closed_sets {X}.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.

Local Open Scope kripke_model.
Import KripkeModelNotation_Intuitionistic.

Section DownwardsClosure.

Context {worlds : Type}
        {R: Relation worlds}
        {po_R: PreOrder Krelation}
        {J: Join worlds}
        {SA: SeparationAlgebra worlds}
        {uSA: UpwardsClosedSeparationAlgebra worlds}.

  (** *Downwards CLosure*)

Definition DownwardsClosure_J: Join worlds.
Proof. exact (fun m1 m2 m: worlds => exists n1 n2, m1 <= n1 /\ m2 <= n2 /\ join n1 n2 m).
Defined.

Definition DownwardsClosure_SA:
  @SeparationAlgebra worlds (DownwardsClosure_J).
Proof.
  constructor.
  + (* join_comm *)
    intros.
    destruct H as [n1 [n2 [? [? ?]]]].
    exists n2, n1.
    split; [| split]; auto.
    apply join_comm; auto.
  + (* join_assoc *)
    intros.
    destruct H as [mx'' [my'' [? [? ?]]]].
    destruct H0 as [mxy' [mz' [? [? ?]]]].
    destruct (join_Korder_up _ _ _ _ H2 H0) as [mx' [my' [? [? ?]]]].
    destruct (join_assoc _ _ _ _ _ H5 H4) as [myz' [? ?]].
    exists myz'.
    split.
    - exists my', mz'; split; [| split]; auto.
      etransitivity; eauto.
    - exists mx', myz'; split; [| split]; auto.
      * etransitivity; eauto.
      * reflexivity.
Defined.

Lemma DownwardsClosure_increasing: forall m, @increasing' _ _ J m <-> @increasing _ _ (DownwardsClosure_J) m.
Proof.
  intros.
  unfold increasing', increasing; split; intros.
  + destruct H0 as [m0 [n0 [? [? ?]]]].
    etransitivity; [eassumption |].
    eapply H; [| eassumption].
    auto.
  + apply H.
    exists n, n0.
    split; [| split]; auto; reflexivity.
Qed.

Definition DownwardsClosure_DownwardsClosed:
  @DownwardsClosedSeparationAlgebra worlds _ (DownwardsClosure_J).
Proof.
  intros until n2; intros.
  exists m.
  split; [| reflexivity].
  destruct H as [m1' [m2' [? [? ?]]]].
  exists m1', m2'.
  split; [| split]; auto; etransitivity; eauto.
Qed.

Definition DownwardsClosure_UpwardsClosed : @UpwardsClosedSeparationAlgebra worlds _ (DownwardsClosure_J).
Proof.
  intros until m2; intros.
  simpl in *.
  destruct H as [n1 [n2 [? [? ?]]]].
  destruct (join_Korder_up _ _ _ _ H2 H0) as [n1' [n2' [? [? ?]]]].
  exists n1, n2; split; [| split]; auto.
  exists n1', n2'; split; [| split]; auto.
Qed.

Definition DownwardsClosure_USA {USA': UnitalSeparationAlgebra' worlds}: @UnitalSeparationAlgebra worlds _ (DownwardsClosure_J).
Proof.
  constructor.
  intros.
  destruct (incr'_exists n) as [u [? ?]].
  destruct H as [n' [H1 H2]].
  exists u; split; auto.
  + exists n'; split; auto.
    exists u, n'; split; [| split]; auto; reflexivity.
  + rewrite <- DownwardsClosure_increasing; auto.
Defined.

Definition DownwardsClosure_incrSA {incrSA: IncreasingSeparationAlgebra worlds}: @IncreasingSeparationAlgebra worlds _ (DownwardsClosure_J).
Proof.
  constructor.
  simpl.
  intros.
  hnf; intros.
  destruct H as [n1 [n2 [? [? ?]]]].
  etransitivity; [eauto |].
  eapply all_increasing; eauto.
Qed.

End DownwardsClosure.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Theory.Adjunction.

Generalizable All Variables.

#[local] Obligation Tactic := intros.

(* The category Adj(C,D), of adjoint functors between C and D:

    objects                (F, U, F ⊣ U)
    arrows                 (σ : F ⟹ F', τ : U ⟹ U')
    identity               identity of natural transformation
    composition            pairwise composition of natural transformations
*)

Program Definition Adj (C D : Category) : Category := {|
  obj := ∃ (F : D ⟶ C) (U : C ⟶ D), F ⊣ U;
  hom := fun x y => (`1 x ⟹ `1 y) ∧ (`1`2 x ⟹ `1`2 y);
  id  := fun x => (nat_id, nat_id);
  compose := fun _ _ _ f g => (fst f ∙ fst g, snd f ∙ snd g)
|}.
Next Obligation. apply prod_setoid. Defined.
Next Obligation.
  proper; simpl in *; simplify;
  rewrites; reflexivity.
Qed.
Next Obligation. split; simpl; cat. Qed.
Next Obligation. split; simpl; cat. Qed.
Next Obligation. split; simpl; cat. Qed.
Next Obligation. split; simpl; cat. Qed.


Require Import Ascii.

Inductive Decidable (P : Prop) : Prop :=
| dec_true : P -> Decidable P
| dec_false : ~ P -> Decidable P.

Inductive pbool : Prop :=
| ptrue
| pfalse.

Definition compute_dec (P : Prop) {d : Decidable P} :=
match d with
| dec_true _ _ => ptrue
| dec_false _ _ => pfalse
end.

Lemma DecidableBoolEq (a b : bool) : (Decidable (a = b)).
Proof.
destruct a; destruct b; try (now left); now right.
Qed.

Lemma DecidableAsciiEq (a b : ascii) : (Decidable (a = b)).
Proof.
assert ({a = b} + {a <> b}) by repeat decide equality.
destruct H; [ now left | now right ].
Defined.


Require Import Coq.ZArith.BinInt.
Require Import coqutil.Z.Lia.

Section Riscv.

  Open Scope Z_scope.

  Record MetricLog := mkMetricLog {
    instructions: Z;
    stores: Z;
    loads: Z; (* Note that this also includes loads of the PC *)
    jumps: Z;
  }.

  Definition EmptyMetricLog := mkMetricLog 0 0 0 0.

  Definition withInstructions i log := mkMetricLog i (stores log) (loads log) (jumps log).
  Definition withStores s log := mkMetricLog (instructions log) s (loads log) (jumps log).
  Definition withLoads l log := mkMetricLog (instructions log) (stores log) l (jumps log).
  Definition withJumps j log := mkMetricLog (instructions log) (stores log) (loads log) j.

  Definition addMetricInstructions n log := withInstructions (instructions log + n) log.
  Definition addMetricStores n log := withStores (stores log + n) log.
  Definition addMetricLoads n log := withLoads (loads log + n) log.
  Definition addMetricJumps n log := withJumps (jumps log + n) log.

  Definition subMetricInstructions n log := withInstructions (instructions log - n) log.
  Definition subMetricStores n log := withStores (stores log - n) log.
  Definition subMetricLoads n log := withLoads (loads log - n) log.
  Definition subMetricJumps n log := withJumps (jumps log - n) log.

  Definition metricSub(metric: MetricLog -> Z) finalM initialM: Z :=
    Z.sub (metric finalM) (metric initialM).

  Definition metricsOp op : MetricLog -> MetricLog -> MetricLog :=
    fun initialM finalM =>
      mkMetricLog
        (op instructions initialM finalM)
        (op stores initialM finalM)
        (op loads initialM finalM)
        (op jumps initialM finalM).

  Definition metricsSub := metricsOp metricSub.

  Definition metricLeq(metric: MetricLog -> Z) m1 m2: Prop :=
    (metric m1) <= (metric m2).

  Definition metricsLeq(m1: MetricLog)(m2: MetricLog): Prop :=
    metricLeq instructions m1 m2 /\
    metricLeq stores m1 m2 /\
    metricLeq loads m1 m2 /\
    metricLeq jumps m1 m2.

End Riscv.

Bind Scope MetricL_scope with MetricLog.
Delimit Scope MetricL_scope with metricsL.

Infix "<=" := metricsLeq : MetricL_scope.
Infix "-" := metricsSub : MetricL_scope.

#[global] Hint Unfold
     withInstructions
     withLoads
     withStores
     withJumps
     addMetricInstructions
     addMetricLoads
     addMetricStores
     addMetricJumps
     subMetricInstructions
     subMetricLoads
     subMetricStores
     subMetricJumps
     metricsOp
     metricSub
     metricsSub
     metricLeq
     metricsLeq
  : unf_metric_log.

Ltac unfold_MetricLog := autounfold with unf_metric_log in *.

Ltac fold_MetricLog :=
  match goal with
  | _ : _ |- context[?x] =>
    match x with
    | {| instructions := instructions ?y;
         stores := stores ?y;
         loads := loads ?y;
         jumps := jumps ?y; |} => replace x with y by (destruct y; reflexivity)
    end
  end.

Ltac simpl_MetricLog :=
  cbn [fst snd] in *; (* Unfold logs in tuples *)
  cbn [instructions loads stores jumps] in *.

Ltac try_equality_MetricLog :=
  repeat match goal with
         | H : MetricLog |- context[{| instructions := ?i; |}] =>
           progress replace i with (instructions H) by blia
         | H : MetricLog |- context[{| stores := ?i; |}] =>
           progress replace i with (stores H) by blia
         | H : MetricLog |- context[{| loads := ?i; |}] =>
           progress replace i with (loads H) by blia
         | H : MetricLog |- context[{| jumps := ?i; |}] =>
           progress replace i with (jumps H) by blia
         end.

Ltac solve_MetricLog :=
  repeat unfold_MetricLog;
  repeat simpl_MetricLog;
  try_equality_MetricLog;
  blia || f_equal; blia || fold_MetricLog.