(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness of instruction selection for integer division *)

Require Import Coqlib.
Require Import Zquot.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Cminor.
Require Import Op.
Require Import CminorSel.
Require Import SelectOp.
Require Import SelectOpproof.
Require Import SelectDiv.

Open Local Scope cminorsel_scope.

(** * Main approximation theorems *)

Section Z_DIV_MUL.

Variable N: Z.      (**r number of relevant bits *)
Hypothesis N_pos: N >= 0.
Variable d: Z.      (**r divisor *)
Hypothesis d_pos: d > 0.

(** This is theorem 4.2 from Granlund and Montgomery, PLDI 1994. *)

Lemma Zdiv_mul_pos:
  forall m l,
  l >= 0 ->
  two_p (N+l) <= m * d <= two_p (N+l) + two_p l ->
  forall n,
  0 <= n < two_p N ->
  Zdiv n d = Zdiv (m * n) (two_p (N + l)).
Proof.
  intros m l l_pos [LO HI] n RANGE.
  exploit (Z_div_mod_eq n d). auto.
  set (q := n / d).
  set (r := n mod d).
  intro EUCL.
  assert (0 <= r <= d - 1).
    unfold r. generalize (Z_mod_lt n d d_pos). omega.
  assert (0 <= m).
    apply Zmult_le_0_reg_r with d. auto.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
  set (k := m * d - two_p (N + l)).
  assert (0 <= k <= two_p l).
    unfold k; omega.
  assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r).
    unfold k. rewrite EUCL. ring.
  assert (0 <= k * n).
    apply Zmult_le_0_compat; omega.
  assert (k * n <= two_p (N + l) - two_p l).
    apply Zle_trans with (two_p l * n).
    apply Zmult_le_compat_r. omega. omega.
    replace (N + l) with (l + N) by omega.
    rewrite two_p_is_exp.
    replace (two_p l * two_p N - two_p l)
       with (two_p l * (two_p N - 1))
         by ring.
    apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
    omega. omega.
  assert (0 <= two_p (N + l) * r).
    apply Zmult_le_0_compat.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
    omega.
  assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
    replace (two_p (N + l) * d - two_p (N + l))
       with (two_p (N + l) * (d - 1)) by ring.
    apply Zmult_le_compat_l.
    omega.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
  assert (0 <= m * n - two_p (N + l) * q).
    apply Zmult_le_reg_r with d. auto.
    replace (0 * d) with 0 by ring.  rewrite H2. omega.
  assert (m * n - two_p (N + l) * q < two_p (N + l)).
    apply Zmult_lt_reg_r with d. omega.
    rewrite H2.
    apply Zle_lt_trans with (two_p (N + l) * d - two_p l).
    omega.
    exploit (two_p_gt_ZERO l). omega. omega.
  symmetry. apply Zdiv_unique with (m * n - two_p (N + l) * q).
  ring. omega.
Qed.

Lemma Zdiv_unique_2:
  forall x y q, y > 0 -> 0 < y * q - x <= y -> Zdiv x y = q - 1.
Proof.
  intros. apply Zdiv_unique with (x - (q - 1) * y). ring.
  replace ((q - 1) * y) with (y * q - y) by ring. omega.
Qed.

Lemma Zdiv_mul_opp:
  forall m l,
  l >= 0 ->
  two_p (N+l) < m * d <= two_p (N+l) + two_p l ->
  forall n,
  0 < n <= two_p N ->
  Zdiv n d = - Zdiv (m * (-n)) (two_p (N + l)) - 1.
Proof.
  intros m l l_pos [LO HI] n RANGE.
  replace (m * (-n)) with (- (m * n)) by ring.
  exploit (Z_div_mod_eq n d). auto.
  set (q := n / d).
  set (r := n mod d).
  intro EUCL.
  assert (0 <= r <= d - 1).
    unfold r. generalize (Z_mod_lt n d d_pos). omega.
  assert (0 <= m).
    apply Zmult_le_0_reg_r with d. auto.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
  cut (Zdiv (- (m * n)) (two_p (N + l)) = -q - 1).
    omega.
  apply Zdiv_unique_2.
  apply two_p_gt_ZERO. omega.
  replace (two_p (N + l) * - q - - (m * n))
     with (m * n - two_p (N + l) * q)
       by ring.
  set (k := m * d - two_p (N + l)).
  assert (0 < k <= two_p l).
    unfold k; omega.
  assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r).
    unfold k. rewrite EUCL. ring.
  split.
  apply Zmult_lt_reg_r with d. omega.
  replace (0 * d) with 0 by omega.
  rewrite H2.
  assert (0 < k * n). apply Zmult_lt_0_compat; omega.
  assert (0 <= two_p (N + l) * r).
    apply Zmult_le_0_compat. exploit (two_p_gt_ZERO (N + l)); omega. omega.
  omega.
  apply Zmult_le_reg_r with d. omega.
  rewrite H2.
  assert (k * n <= two_p (N + l)).
    rewrite Zplus_comm. rewrite two_p_is_exp; try omega.
    apply Zle_trans with (two_p l * n). apply Zmult_le_compat_r. omega. omega.
    apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
  assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
    replace (two_p (N + l) * d - two_p (N + l))
       with (two_p (N + l) * (d - 1))
         by ring.
    apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO (N + l)). omega. omega.
  omega.
Qed.

(** This is theorem 5.1 from Granlund and Montgomery, PLDI 1994. *)

Lemma Zquot_mul:
  forall m l,
  l >= 0 ->
  two_p (N+l) < m * d <= two_p (N+l) + two_p l ->
  forall n,
  - two_p N <= n < two_p N ->
  Z.quot n d = Zdiv (m * n) (two_p (N + l)) + (if zlt n 0 then 1 else 0).
Proof.
  intros. destruct (zlt n 0).
  exploit (Zdiv_mul_opp m l H H0 (-n)). omega.
  replace (- - n) with n by ring.
  replace (Z.quot n d) with (- Z.quot (-n) d).
  rewrite Zquot_Zdiv_pos by omega. omega.
  rewrite Z.quot_opp_l by omega. ring.
  rewrite Zplus_0_r. rewrite Zquot_Zdiv_pos by omega.
  apply Zdiv_mul_pos; omega.
Qed.

End Z_DIV_MUL.

(** * Correctness of the division parameters *)

Lemma divs_mul_params_sound:
  forall d m p,
  divs_mul_params d = Some(p, m) ->
  0 <= m < Int.modulus /\ 0 <= p < 32 /\
  forall n,
  Int.min_signed <= n <= Int.max_signed ->
  Z.quot n d = Zdiv (m * n) (two_p (32 + p)) + (if zlt n 0 then 1 else 0).
Proof with (try discriminate).
  unfold divs_mul_params; intros d m' p' EQ.
  destruct (find_div_mul_params Int.wordsize
               (Int.half_modulus - Int.half_modulus mod d - 1) d 32)
  as [[p m] | ]...
  destruct (zlt 0 d)...
  destruct (zlt (two_p (32 + p)) (m * d))...
  destruct (zle (m * d) (two_p (32 + p) + two_p (p + 1)))...
  destruct (zle 0 m)...
  destruct (zlt m Int.modulus)...
  destruct (zle 0 p)...
  destruct (zlt p 32)...
  simpl in EQ. inv EQ.
  split. auto. split. auto. intros.
  replace (32 + p') with (31 + (p' + 1)) by omega.
  apply Zquot_mul; try omega.
  replace (31 + (p' + 1)) with (32 + p') by omega. omega.
  change (Int.min_signed <= n < Int.half_modulus).
  unfold Int.max_signed in H. omega.
Qed.

Lemma divu_mul_params_sound:
  forall d m p,
  divu_mul_params d = Some(p, m) ->
  0 <= m < Int.modulus /\ 0 <= p < 32 /\
  forall n,
  0 <= n < Int.modulus ->
  Zdiv n d = Zdiv (m * n) (two_p (32 + p)).
Proof with (try discriminate).
  unfold divu_mul_params; intros d m' p' EQ.
  destruct (find_div_mul_params Int.wordsize
               (Int.modulus - Int.modulus mod d - 1) d 32)
  as [[p m] | ]...
  destruct (zlt 0 d)...
  destruct (zle (two_p (32 + p)) (m * d))...
  destruct (zle (m * d) (two_p (32 + p) + two_p p))...
  destruct (zle 0 m)...
  destruct (zlt m Int.modulus)...
  destruct (zle 0 p)...
  destruct (zlt p 32)...
  simpl in EQ. inv EQ.
  split. auto. split. auto. intros.
  apply Zdiv_mul_pos; try omega. assumption.
Qed.

Lemma divs_mul_shift_gen:
  forall x y m p,
  divs_mul_params (Int.signed y) = Some(p, m) ->
  0 <= m < Int.modulus /\ 0 <= p < 32 /\
  Int.divs x y = Int.add (Int.shr (Int.repr ((Int.signed x * m) / Int.modulus)) (Int.repr p))
                         (Int.shru x (Int.repr 31)).
Proof.
  intros. set (n := Int.signed x). set (d := Int.signed y) in *.
  exploit divs_mul_params_sound; eauto. intros (A & B & C).
  split. auto. split. auto.
  unfold Int.divs. fold n; fold d. rewrite C by (apply Int.signed_range).
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv.
  rewrite Int.shru_lt_zero. unfold Int.add. apply Int.eqm_samerepr. apply Int.eqm_add.
  rewrite Int.shr_div_two_p. apply Int.eqm_unsigned_repr_r. apply Int.eqm_refl2.
  rewrite Int.unsigned_repr. f_equal.
  rewrite Int.signed_repr. rewrite Int.modulus_power. f_equal. ring.
  cut (Int.min_signed <= n * m / Int.modulus < Int.half_modulus).
  unfold Int.max_signed; omega.
  apply Zdiv_interval_1. generalize Int.min_signed_neg; omega. apply Int.half_modulus_pos.
  apply Int.modulus_pos.
  split. apply Zle_trans with (Int.min_signed * m). apply Zmult_le_compat_l_neg. omega. generalize Int.min_signed_neg; omega.
  apply Zmult_le_compat_r. unfold n; generalize (Int.signed_range x); tauto. tauto.
  apply Zle_lt_trans with (Int.half_modulus * m).
  apply Zmult_le_compat_r. generalize (Int.signed_range x); unfold n, Int.max_signed; omega. tauto.
  apply Zmult_lt_compat_l. generalize Int.half_modulus_pos; omega. tauto.
  assert (32 < Int.max_unsigned) by (compute; auto). omega.
  unfold Int.lt; fold n. rewrite Int.signed_zero. destruct (zlt n 0); apply Int.eqm_unsigned_repr.
  apply two_p_gt_ZERO. omega.
  apply two_p_gt_ZERO. omega.
Qed.

Theorem divs_mul_shift_1:
  forall x y m p,
  divs_mul_params (Int.signed y) = Some(p, m) ->
  m < Int.half_modulus ->
  0 <= p < 32 /\
  Int.divs x y = Int.add (Int.shr (Int.mulhs x (Int.repr m)) (Int.repr p))
                         (Int.shru x (Int.repr 31)).
Proof.
  intros. exploit divs_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C.
  unfold Int.mulhs. rewrite Int.signed_repr. auto.
  generalize Int.min_signed_neg; unfold Int.max_signed; omega.
Qed.

Theorem divs_mul_shift_2:
  forall x y m p,
  divs_mul_params (Int.signed y) = Some(p, m) ->
  m >= Int.half_modulus ->
  0 <= p < 32 /\
  Int.divs x y = Int.add (Int.shr (Int.add (Int.mulhs x (Int.repr m)) x) (Int.repr p))
                         (Int.shru x (Int.repr 31)).
Proof.
  intros. exploit divs_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C. f_equal. f_equal.
  rewrite Int.add_signed. unfold Int.mulhs. set (n := Int.signed x).
  transitivity (Int.repr (n * (m - Int.modulus) / Int.modulus + n)).
  f_equal.
  replace (n * (m - Int.modulus)) with (n * m +  (-n) * Int.modulus) by ring.
  rewrite Z_div_plus. ring. apply Int.modulus_pos.
  apply Int.eqm_samerepr. apply Int.eqm_add; auto with ints.
  apply Int.eqm_sym. eapply Int.eqm_trans. apply Int.eqm_signed_unsigned.
  apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl2. f_equal. f_equal.
  rewrite Int.signed_repr_eq. rewrite Zmod_small by assumption.
  apply zlt_false. omega.
Qed.

Theorem divu_mul_shift:
  forall x y m p,
  divu_mul_params (Int.unsigned y) = Some(p, m) ->
  0 <= p < 32 /\
  Int.divu x y = Int.shru (Int.mulhu x (Int.repr m)) (Int.repr p).
Proof.
  intros. exploit divu_mul_params_sound; eauto. intros (A & B & C).
  split. auto.
  rewrite Int.shru_div_two_p. rewrite Int.unsigned_repr.
  unfold Int.divu, Int.mulhu. f_equal. rewrite C by apply Int.unsigned_range.
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega).
  f_equal. rewrite (Int.unsigned_repr m).
  rewrite Int.unsigned_repr. f_equal. ring.
  cut (0 <= Int.unsigned x * m / Int.modulus < Int.modulus).
  unfold Int.max_unsigned; omega.
  apply Zdiv_interval_1. omega. compute; auto. compute; auto.
  split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int.unsigned_range x); omega. omega.
  apply Zle_lt_trans with (Int.modulus * m).
  apply Zmult_le_compat_r. generalize (Int.unsigned_range x); omega. omega.
  apply Zmult_lt_compat_l. compute; auto. omega.
  unfold Int.max_unsigned; omega.
  assert (32 < Int.max_unsigned) by (compute; auto). omega.
Qed.

(** * Correctness of the smart constructors for division and modulus *)

Section CMCONSTRS.

Variable ge: genv.
Variable sp: val.
Variable e: env.
Variable m: mem.

Lemma eval_divu_mul:
  forall le x y p M,
  divu_mul_params (Int.unsigned y) = Some(p, M) ->
  nth_error le O = Some (Vint x) ->
  eval_expr ge sp e m le (divu_mul p M) (Vint (Int.divu x y)).
Proof.
  intros. unfold divu_mul. exploit (divu_mul_shift x); eauto. intros [A B].
  assert (eval_expr ge sp e m le
           (Eop Omulhu (Eletvar 0 ::: Eop (Ointconst (Int.repr M)) Enil ::: Enil))
           (Vint (Int.mulhu x (Int.repr M)))).
  { EvalOp. econstructor. econstructor; eauto. econstructor. EvalOp. simpl; reflexivity. constructor.
    auto. }
  exploit eval_shruimm. eexact H1. instantiate (1 := Int.repr p).
  intros [v [P Q]]. simpl in Q.
  replace (Int.ltu (Int.repr p) Int.iwordsize) with true in Q.
  inv Q. rewrite B. auto.
  unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto.
  assert (32 < Int.max_unsigned) by (compute; auto). omega.
Qed.

Theorem eval_divuimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.divu x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (divuimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold divuimm; intros. generalize H0; intros DIV.
  destruct x; simpl in DIV; try discriminate.
  destruct (Int.eq n2 Int.zero) eqn:Z2; inv DIV.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- erewrite Int.divu_pow2 by eauto.
  replace (Vint (Int.shru i l)) with (Val.shru (Vint i) (Vint l)).
  apply eval_shruimm; auto.
  simpl. erewrite Int.is_power2_range; eauto.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_divu_base; eauto. EvalOp.
  + destruct (divu_mul_params (Int.unsigned n2)) as [[p M] | ] eqn:PARAMS.
    * exists (Vint (Int.divu i n2)); split; auto.
      econstructor; eauto. eapply eval_divu_mul; eauto.
    * eapply eval_divu_base; eauto. EvalOp.
Qed.

Theorem eval_divu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divu x y = Some z ->
  exists v, eval_expr ge sp e m le (divu a b) v /\ Val.lessdef z v.
Proof.
  unfold divu; intros until b. destruct (divu_match b); intros.
- inv H0. inv H5. simpl in H7. inv H7. eapply eval_divuimm; eauto.
- eapply eval_divu_base; eauto.
Qed.

Lemma eval_mod_from_div:
  forall le a n x y,
  eval_expr ge sp e m le a (Vint y) ->
  nth_error le O = Some (Vint x) ->
  eval_expr ge sp e m le (mod_from_div a n) (Vint (Int.sub x (Int.mul y n))).
Proof.
  unfold mod_from_div; intros.
  exploit eval_mulimm; eauto. instantiate (1 := n). intros [v [A B]].
  simpl in B. inv B. EvalOp.
Qed.

Theorem eval_moduimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.modu x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (moduimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold moduimm; intros. generalize H0; intros MOD.
  destruct x; simpl in MOD; try discriminate.
  destruct (Int.eq n2 Int.zero) eqn:Z2; inv MOD.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- erewrite Int.modu_and by eauto.
  change (Vint (Int.and i (Int.sub n2 Int.one)))
    with (Val.and (Vint i) (Vint (Int.sub n2 Int.one))).
  apply eval_andimm. auto.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_modu_base; eauto. EvalOp.
  + destruct (divu_mul_params (Int.unsigned n2)) as [[p M] | ] eqn:PARAMS.
    * econstructor; split.
      econstructor; eauto. eapply eval_mod_from_div.
      eapply eval_divu_mul; eauto. simpl; eauto. simpl; eauto.
      rewrite Int.modu_divu. auto.
      red; intros; subst n2; discriminate.
    * eapply eval_modu_base; eauto. EvalOp.
Qed.

Theorem eval_modu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.modu x y = Some z ->
  exists v, eval_expr ge sp e m le (modu a b) v /\ Val.lessdef z v.
Proof.
  unfold modu; intros until b. destruct (modu_match b); intros.
- inv H0. inv H5. simpl in H7. inv H7. eapply eval_moduimm; eauto.
- eapply eval_modu_base; eauto.
Qed.

Lemma eval_divs_mul:
  forall le x y p M,
  divs_mul_params (Int.signed y) = Some(p, M) ->
  nth_error le O = Some (Vint x) ->
  eval_expr ge sp e m le (divs_mul p M) (Vint (Int.divs x y)).
Proof.
  intros. unfold divs_mul.
  assert (V: eval_expr ge sp e m le (Eletvar O) (Vint x)).
  { constructor; auto. }
  assert (X: eval_expr ge sp e m le
           (Eop Omulhs (Eletvar 0 ::: Eop (Ointconst (Int.repr M)) Enil ::: Enil))
           (Vint (Int.mulhs x (Int.repr M)))).
  { EvalOp. econstructor. eauto. econstructor. EvalOp. simpl; reflexivity. constructor.
    auto. }
  exploit eval_shruimm. eexact V. instantiate (1 := Int.repr (Int.zwordsize - 1)).
  intros [v1 [Y LD]]. simpl in LD.
  change (Int.ltu (Int.repr 31) Int.iwordsize) with true in LD.
  simpl in LD. inv LD.
  assert (RANGE: 0 <= p < 32 -> Int.ltu (Int.repr p) Int.iwordsize = true).
  { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto.
    assert (32 < Int.max_unsigned) by (compute; auto). omega. }
  destruct (zlt M Int.half_modulus).
- exploit (divs_mul_shift_1 x); eauto. intros [A B].
  exploit eval_shrimm. eexact X. instantiate (1 := Int.repr p). intros [v1 [Z LD]].
  simpl in LD. rewrite RANGE in LD by auto. inv LD.
  exploit eval_add. eexact Z. eexact Y. intros [v1 [W LD]].
  simpl in LD. inv LD.
  rewrite B. exact W.
- exploit (divs_mul_shift_2 x); eauto. intros [A B].
  exploit eval_add. eexact X. eexact V. intros [v1 [Z LD]].
  simpl in LD. inv LD.
  exploit eval_shrimm. eexact Z. instantiate (1 := Int.repr p). intros [v1 [U LD]].
  simpl in LD. rewrite RANGE in LD by auto. inv LD.
  exploit eval_add. eexact U. eexact Y. intros [v1 [W LD]].
  simpl in LD. inv LD.
  rewrite B. exact W.
Qed.

Theorem eval_divsimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.divs x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (divsimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold divsimm; intros. generalize H0; intros DIV.
  destruct x; simpl in DIV; try discriminate.
  destruct (Int.eq n2 Int.zero
            || Int.eq i (Int.repr Int.min_signed) && Int.eq n2 Int.mone) eqn:Z2; inv DIV.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- destruct (Int.ltu l (Int.repr 31)) eqn:LT31.
  + eapply eval_shrximm; eauto. eapply Val.divs_pow2; eauto.
  + eapply eval_divs_base; eauto. EvalOp.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_divs_base; eauto. EvalOp.
  + destruct (divs_mul_params (Int.signed n2)) as [[p M] | ] eqn:PARAMS.
    * exists (Vint (Int.divs i n2)); split; auto.
      econstructor; eauto. eapply eval_divs_mul; eauto.
    * eapply eval_divs_base; eauto. EvalOp.
Qed.

Theorem eval_divs:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divs x y = Some z ->
  exists v, eval_expr ge sp e m le (divs a b) v /\ Val.lessdef z v.
Proof.
  unfold divs; intros until b. destruct (divs_match b); intros.
- inv H0. inv H5. simpl in H7. inv H7. eapply eval_divsimm; eauto.
- eapply eval_divs_base; eauto.
Qed.

Theorem eval_modsimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.mods x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (modsimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold modsimm; intros.
  exploit Val.mods_divs; eauto. intros [y [A B]].
  generalize A; intros DIV.
  destruct x; simpl in DIV; try discriminate.
  destruct (Int.eq n2 Int.zero
            || Int.eq i (Int.repr Int.min_signed) && Int.eq n2 Int.mone) eqn:Z2; inv DIV.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- destruct (Int.ltu l (Int.repr 31)) eqn:LT31.
  + exploit (eval_shrximm ge sp e m (Vint i :: le) (Eletvar O)).
    constructor. simpl; eauto. eapply Val.divs_pow2; eauto.
    intros [v1 [X LD]]. inv LD.
    econstructor; split. econstructor. eauto.
    apply eval_mod_from_div. eexact X. simpl; eauto.
    simpl. auto.
  + eapply eval_mods_base; eauto. EvalOp.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_mods_base; eauto. EvalOp.
  + destruct (divs_mul_params (Int.signed n2)) as [[p M] | ] eqn:PARAMS.
    * econstructor; split.
      econstructor. eauto. apply eval_mod_from_div with (x := i); auto.
      eapply eval_divs_mul with (x := i); eauto.
      simpl. auto.
    * eapply eval_mods_base; eauto. EvalOp.
Qed.

Theorem eval_mods:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.mods x y = Some z ->
  exists v, eval_expr ge sp e m le (mods a b) v /\ Val.lessdef z v.
Proof.
  unfold mods; intros until b. destruct (mods_match b); intros.
- inv H0. inv H5. simpl in H7. inv H7. eapply eval_modsimm; eauto.
- eapply eval_mods_base; eauto.
Qed.

(** * Floating-point division *)

Theorem eval_divf:
  forall le a b x y,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  exists v, eval_expr ge sp e m le (divf a b) v /\ Val.lessdef (Val.divf x y) v.
Proof.
  intros until y. unfold divf. destruct (divf_match b); intros.
- unfold divfimm. destruct (Float.exact_inverse n2) as [n2' | ] eqn:EINV.
  + inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
    EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
    simpl; eauto.
    destruct x; simpl; auto. erewrite Float.div_mul_inverse; eauto.
  + TrivialExists.
- TrivialExists.
Qed.

Theorem eval_divfs:
  forall le a b x y,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  exists v, eval_expr ge sp e m le (divfs a b) v /\ Val.lessdef (Val.divfs x y) v.
Proof.
  intros until y. unfold divfs. destruct (divfs_match b); intros.
- unfold divfsimm. destruct (Float32.exact_inverse n2) as [n2' | ] eqn:EINV.
  + inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
    EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
    simpl; eauto.
    destruct x; simpl; auto. erewrite Float32.div_mul_inverse; eauto.
  + TrivialExists.
- TrivialExists.
Qed.

End CMCONSTRS.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_collinearorder_1 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable defcollinear_2 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_3 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_4 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_5 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_6 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_7 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_8 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_betweennotequal_9 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_inequalitysymmetric_10 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_11 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable defmeet_12 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_13 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).
Variable axiom_betweennesssymmetry_14 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable postulate_Pasch_outer_15 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B C Q /\ ~(col_ B Q A))) -> (betS_ A X Q /\ betS_ B P X)))).

Theorem lemma_collinearbetween_16 : (forall A B C D E F H : Universe, ((col_ A E B /\ (col_ C F D /\ (A <> B /\ (C <> D /\ (A <> E /\ (F <> D /\ (~(meet_ A B C D) /\ (betS_ A H D /\ col_ E F H)))))))) -> betS_ E H F)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export reduction.

Reserved Notation "g '⊢' A '≡' B"  (at level 250, A at level 99). (*⊢ : \vdash , ≡ : \equiv *)
Inductive Equiv : env -> exp -> exp -> Prop :=
  | aE_Step (g : env) (e e1 e2 : exp):
      (g ⊢ e1 ⊳* e) ->
      (g ⊢ e2 ⊳* e) ->
      (g ⊢ e1 ≡ e2)
  | aE_Reflect : forall (g : env) (e1 e2 : exp) (x : var),
      assumes g x (eEqv e1 e2) ->
      (g ⊢ e1 ≡ e2)
  | aE_Subst : forall (g : env) (M M1 M2 : exp),
      (g ⊢ M1 ≡ M2) ->
      (g ⊢ bind M1 M ≡ bind M2 M)
  | aE_Reflex : forall (g : env) (M : exp),
      (g ⊢ M ≡ M)
  | aE_Symm : forall (g : env) (M M' : exp),
      (g ⊢ M' ≡ M) ->
      (g ⊢ M ≡ M')
  | aE_Trans : forall (g : env) (M1 M2 M' : exp),
      (g ⊢ M1 ≡ M') ->
      (g ⊢ M' ≡ M2) ->
      (g ⊢ M1 ≡ M2)
  | aE_Lam : forall (g : env) (A A' M M' : exp) (x : name),
      (g ⊢ A ≡ A') ->
      (g & x ~ Assum A ⊢ open x M ≡ open x M') ->
      (g ⊢ eAbs A M ≡ eAbs A' M')
  | aE_Eta1 : forall (g : env) (A M M1 M2 M' : exp) (x : name),
      (g ⊢ M1 ≡ eAbs A M) ->
      (g ⊢ M2 ≡ M') ->
      (g & x ~ Assum A ⊢ open x M ≡ eApp M' (eId (free x))) ->
      (g ⊢ M1 ≡ M2)
  | aE_Eta2 : forall (g : env) (A M M1 M2 M' : exp) (x : name),
      (g ⊢ M1 ≡ M') ->
      (g ⊢ M2 ≡ eAbs A M) ->
      (g & x ~ Assum A ⊢ open x M ≡ eApp M' (eId (free x))) ->
      (g ⊢ M1 ≡ M2)
  | aE_App : forall (g : env) (V1 V1' V2 V2' : exp),
      (g ⊢ V1 ≡ V1') ->
      (g ⊢ V2 ≡ V2') ->
      (g ⊢ eApp V1 V2 ≡ eApp V1' V2')
  | aE_Pi : forall (g : env) (A A' B B' : exp) (x : name),
      (g ⊢ A ≡ A') ->
      (g & x ~ Assum A ⊢ open x B ≡ open x B') ->
      (g ⊢ ePi A B ≡ ePi A' B')
  | aE_Pair : forall (g : env) (V1 V1' V2 V2' A A' : exp),
      (g ⊢ V1 ≡ V1') ->
      (g ⊢ V2 ≡ V2') ->
      (g ⊢ A ≡ A') ->
      (g ⊢ ePair V1 V2 A ≡ ePair V1' V2' A')
  | aE_Fst : forall (g : env) (V V' : exp),
      (g ⊢ V ≡ V') ->
      (g ⊢ eFst V ≡ eFst V')
  | aE_Snd : forall (g : env) (V V' : exp),
      (g ⊢ V ≡ V') ->
      (g ⊢ eSnd V ≡ eSnd V')
  | aE_Sig : forall (g : env) (A A' B B' : exp) (x : name),
      (g ⊢ A ≡ A') ->
      (g & x ~ Assum A ⊢ open x B ≡ open x B') ->
      (g ⊢ eSig A B ≡ eSig A' B')
  | aE_Let : forall (g : env) (N N' M M' A : exp) (x : name),
      (g ⊢ N ≡ N') ->
      (g & x ~ Def N A ⊢ open x M ≡ open x M') ->
      (g ⊢ eLet N M ≡ eLet N' M')
  | aE_If : forall (g : env) (V V' M1 M1' M2 M2' : exp) (p : name),
      (g ⊢ V ≡ V') ->
      (g & p ~ Assum (eEqv V eTru) ⊢ M1 ≡ M1') ->
      (g & p ~ Assum (eEqv V eFls) ⊢ M2 ≡ M2') ->
      (g ⊢ eIf V M1 M2 ≡ eIf V' M1' M2')
  | aE_If_EtaTru : forall (g : env) (V M1 M2 : exp) (p : var),
      assumes g p (eEqv V eTru) ->
      (g ⊢ eIf V M1 M2 ≡ M1)
  | aE_If_EtaFls : forall (g : env) (V M1 M2 : exp) (p : var),
      assumes g p (eEqv V eFls) ->
      (g ⊢ eIf V M1 M2 ≡ M2)
  | aE_If2 : forall (g : env) (V M : exp),
      (g ⊢ eIf V M M ≡ M)
where "g '⊢' A '≡' B"  := (Equiv g A B): ECCA_scope.
(*TODO: rewrite with notation for legibility*)
Bind Scope ECCA_scope with Equiv.
Hint Constructors Equiv.


Require Export MetricSpaces.

Local Unset Standard Proposition Elimination Names.

Section Completeness.

Variable X:Type.
Variable d:X->X->R.
Hypothesis d_metric: metric d.

Definition cauchy (x:nat->X) : Prop :=
  forall eps:R, eps > 0 -> exists N:nat, forall m n:nat,
    (m >= N)%nat -> (n >= N)%nat -> d (x m) (x n) < eps.

Lemma convergent_sequence_is_cauchy:
  forall (x:Net nat_DS (MetricTopology d d_metric))
    (x0:point_set (MetricTopology d d_metric)),
  net_limit x x0 -> cauchy x.
Proof.
pose proof (MetricTopology_metrizable X d d_metric).
red in H.
intros.
destruct (H x0).
red; intros.
pose (U := open_ball _ d x0 (eps/2)).
destruct (H0 U) as [N].
Opaque In. apply open_neighborhood_basis_elements. Transparent In.
constructor.
Require Import Fourier.
fourier.
constructor.
rewrite metric_zero; trivial.
fourier.
simpl in N.
exists N.
intros.
destruct (H2 m H3).
destruct (H2 n H4).
apply Rle_lt_trans with (d x0 (x m) + d x0 (x n)).
rewrite (metric_sym _ _ d_metric x0 (x m)); trivial.
apply triangle_inequality; trivial.
fourier.
Qed.

Lemma cauchy_sequence_with_cluster_point_converges:
  forall (x:Net nat_DS (MetricTopology d d_metric))
    (x0:point_set (MetricTopology d d_metric)),
  cauchy x -> net_cluster_point x x0 -> net_limit x x0.
Proof.
intros.
apply metric_space_net_limit with d.
apply MetricTopology_metrizable.
intros.
red; intros.
destruct (H (eps/2)) as [N].
fourier.
pose (U := open_ball X d x0 (eps/2)).
assert (open_neighborhood U x0 (X:=MetricTopology d d_metric)).
apply MetricTopology_metrizable.
constructor.
fourier.
destruct H3.
destruct (H0 U H3 H4 N) as [m [? []]].
simpl in H5.
exists N; intros n ?.
simpl in H7.
apply Rle_lt_trans with (d x0 (x m) + d (x m) (x n)).
apply triangle_inequality; trivial.
assert (d (x m) (x n) < eps/2) by (apply H2; trivial).
fourier.
Qed.

Definition complete : Prop :=
  forall x:nat->X, cauchy x ->
    exists x0:X, net_limit x x0 (I:=nat_DS)
      (X:=MetricTopology d d_metric).

End Completeness.

Arguments cauchy [X].
Arguments complete [X].

Section closed_subset_of_complete.

Variable X:Type.
Variable d:X->X->R.
Hypothesis d_metric:metric d.
Variable F:Ensemble X.

Let FT := { x:X | In F x }.
Let d_restriction := fun x y:FT => d (proj1_sig x) (proj1_sig y).

Lemma d_restriction_metric: metric d_restriction.
Proof.
Require Import Proj1SigInjective.
constructor; intros; try destruct x; try destruct y; try destruct z;
  try apply subset_eq_compatT; apply d_metric; trivial.
Qed.

Lemma closed_subset_of_complete_is_complete:
  complete d d_metric ->
  closed F (X:=MetricTopology d d_metric) ->
  complete d_restriction d_restriction_metric.
Proof.
intros.
red; intros.
pose (y := fun n:nat => proj1_sig (x n)).
destruct (H y) as [y0].
red; intros.
destruct (H1 eps H2) as [N].
exists N.
exact H3.
intros.
assert (In F y0).
rewrite <- (closure_fixes_closed _ H0); trivial.
apply @net_limit_in_closure with (I:=nat_DS) (x:=y); trivial.
red; intros.
exists i; split.
apply le_refl.
unfold y.
destruct (x i); trivial.
exists (exist _ y0 H3).
apply metric_space_net_limit with d_restriction.
apply MetricTopology_metrizable.
intros.
unfold d_restriction; simpl.
apply metric_space_net_limit_converse with
  (MetricTopology d d_metric); trivial.
apply MetricTopology_metrizable.
Qed.

Lemma complete_subset_is_closed:
  complete d_restriction d_restriction_metric ->
  closed F (X:=MetricTopology d d_metric).
Proof.
intros.
cut (Included (closure F (X:=MetricTopology d d_metric)) F).
intros.
assert (closure F (X:=MetricTopology d d_metric) = F).
apply Extensionality_Ensembles.
split; trivial; apply closure_inflationary.
rewrite <- H1; apply closure_closed.
red; intros.
assert (exists y:Net nat_DS (MetricTopology d d_metric),
  (forall n:nat, In F (y n)) /\ net_limit y x).
apply first_countable_sequence_closure; trivial.
apply metrizable_impl_first_countable.
exists d; trivial; apply MetricTopology_metrizable.
destruct H1 as [y []].
pose (y' := ((fun n:nat => exist _ (y n) (H1 n)) :
             Net nat_DS (MetricTopology d_restriction d_restriction_metric))).
assert (cauchy d y).
apply convergent_sequence_is_cauchy with d_metric x; trivial.
assert (cauchy d_restriction y').
red; intros.
destruct (H3 eps H4) as [N].
exists N; intros.
unfold d_restriction; unfold y'; simpl.
apply H5; trivial.
destruct (H _ H4) as [[x0]].
cut (net_limit y x0 (I:=nat_DS) (X:=MetricTopology d d_metric)).
intros.
assert (x = x0).
assert (uniqueness (net_limit y (I:=nat_DS)
                        (X:=MetricTopology d d_metric))).
apply Hausdorff_impl_net_limit_unique.
apply T3_sep_impl_Hausdorff.
apply normal_sep_impl_T3_sep.
apply metrizable_impl_normal_sep.
exists d; trivial.
apply MetricTopology_metrizable.
apply H7; trivial.
rewrite H7; trivial.

apply metric_space_net_limit with d.
apply MetricTopology_metrizable.
exact (metric_space_net_limit_converse
  (MetricTopology d_restriction d_restriction_metric)
  d_restriction (MetricTopology_metrizable _ d_restriction
                       d_restriction_metric)
  nat_DS y' (exist (fun x:X => In F x) x0 i) H5).
Qed.

End closed_subset_of_complete.


Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders MathClasses.theory.rings.
Require Export
  MathClasses.orders.semirings.

Section from_ring_order.
  Context `{Ring R} `{!PartialOrder Rle}
    (plus_spec : ∀ z, OrderPreserving (z +))
    (mult_spec : ∀ x y, PropHolds (0 ≤ x) → PropHolds (0 ≤ y) → PropHolds (0 ≤ x * y)).

  Lemma from_ring_order: SemiRingOrder (≤).
  Proof.
    repeat (split; try apply _).
     intros x y E. exists (- x + y).
     now rewrite associativity, plus_negate_r, plus_0_l.
    intros x y E.
    rewrite <-(plus_0_l x), <-(plus_0_l y), <-!(plus_negate_l z), <-!associativity.
    now apply (order_preserving _).
  Qed.
End from_ring_order.

Section from_strict_ring_order.
  Context `{Ring R} `{!StrictSetoidOrder Rle}
    (plus_spec : ∀ z, StrictlyOrderPreserving (z +))
    (mult_spec : ∀ x y, PropHolds (0 < x) → PropHolds (0 < y) → PropHolds (0 < x * y)).

  Lemma from_strict_ring_order: StrictSemiRingOrder (<).
  Proof.
    repeat (split; try apply _).
     intros x y E. exists (- x + y).
     now rewrite associativity, plus_negate_r, plus_0_l.
    intros x y E.
    rewrite <-(plus_0_l x), <-(plus_0_l y), <-!(plus_negate_l z), <-!associativity.
    now apply (strictly_order_preserving _).
  Qed.
End from_strict_ring_order.

Section from_pseudo_ring_order.
  Context `{Ring R} `{Apart R} `{!PseudoOrder Rlt}
    (plus_spec : ∀ z, StrictlyOrderPreserving (z +))
    (mult_ext : StrongSetoid_BinaryMorphism (.*.))
    (mult_spec : ∀ x y, PropHolds (0 < x) → PropHolds (0 < y) → PropHolds (0 < x * y)).

  Lemma from_pseudo_ring_order: PseudoSemiRingOrder (<).
  Proof.
    repeat (split; try apply _).
     intros x y E. exists (- x + y).
     now rewrite associativity, plus_negate_r, plus_0_l.
    intros x y E.
    rewrite <-(plus_0_l x), <-(plus_0_l y), <-!(plus_negate_l z), <-!associativity.
    now apply (strictly_order_preserving _).
  Qed.
End from_pseudo_ring_order.

Section from_full_pseudo_ring_order.
  Context `{Ring R} `{Apart R} `{!FullPseudoOrder Rle Rlt}
    (plus_spec : ∀ z, StrictlyOrderPreserving (z +))
    (mult_ext : StrongSetoid_BinaryMorphism (.*.))
    (mult_spec : ∀ x y, PropHolds (0 < x) → PropHolds (0 < y) → PropHolds (0 < x * y)).

  Lemma from_full_pseudo_ring_order: FullPseudoSemiRingOrder (≤) (<).
  Proof.
    split.
     now apply from_pseudo_ring_order.
    now apply le_iff_not_lt_flip.
  Qed.
End from_full_pseudo_ring_order.

Section ring_order.
  Context `{Ring R} `{!SemiRingOrder Rle}.
  Add Ring R : (stdlib_ring_theory R).

  Lemma flip_le_negate x y : -y ≤ -x ↔ x ≤ y.
  Proof.
    assert (∀ a b, a ≤ b → -b ≤ -a).
     intros a b E.
     setoid_replace (-b) with (-a + -b + a) by ring.
     setoid_replace (-a) with (-a + -b + b) at 2 by ring.
     now apply (order_preserving _).
    split; intros; auto.
    rewrite <-(negate_involutive x), <-(negate_involutive y); auto.
  Qed.

  Lemma flip_nonneg_negate x : 0 ≤ x ↔ -x ≤ 0.
  Proof.
    split; intros E.
     rewrite <-negate_0. now apply flip_le_negate.
    apply flip_le_negate. now rewrite negate_0.
  Qed.

  Lemma flip_nonpos_negate x : x ≤ 0 ↔ 0 ≤ -x.
  Proof.
    rewrite <-(negate_involutive x) at 1.
    split; intros; now apply flip_nonneg_negate.
  Qed.

  Lemma flip_le_minus_r (x y z : R) : z ≤ y - x ↔ z + x ≤ y.
  Proof.
    split; intros E.
     rewrite commutativity.
     setoid_replace y with (x + (y - x)) by ring.
     now apply (order_preserving _).
    rewrite commutativity.
    setoid_replace z with (-x + (z + x)) by ring.
    now apply (order_preserving _).
  Qed.

  Lemma flip_le_minus_l (x y z : R) : y - x ≤ z ↔ y ≤ z + x.
  Proof.
    rewrite <-(negate_involutive x) at 2.
    split; now apply flip_le_minus_r.
  Qed.

  Lemma flip_nonneg_minus (x y : R) : 0 ≤ y - x ↔ x ≤ y.
  Proof.
    setoid_replace x with (0 + x) at 2 by ring.
    now apply flip_le_minus_r.
  Qed.

  Lemma flip_nonpos_minus (x y : R) : y - x ≤ 0 ↔ y ≤ x.
  Proof.
    setoid_replace x with (0 + x) at 2 by ring.
    now apply flip_le_minus_l.
  Qed.

  Lemma nonneg_minus_compat (x y z : R) : 0 ≤ z → x ≤ y → x - z ≤ y.
  Proof.
    intros E1 E2.
    rewrite commutativity.
    setoid_replace y with (-z + (y + z)) by ring.
    apply (order_preserving (-(z) +)).
    transitivity y; trivial.
    setoid_replace y with (y + 0) at 1 by ring.
    now apply (order_preserving (y +)).
  Qed.

  Lemma nonneg_minus_compat_back (x y z : R) : 0 ≤ z → x ≤ y - z → x ≤ y.
  Proof.
    intros E1 E2.
    transitivity (y - z); trivial.
    now apply nonneg_minus_compat.
  Qed.

  Lemma between_nonneg (x : R) : 0 ≤ x → -x ≤ x.
  Proof.
    intros E.
    transitivity 0; trivial.
    now apply flip_nonneg_negate.
  Qed.
End ring_order.

Section strict_ring_order.
  Context `{Ring R} `{!StrictSemiRingOrder Rlt}.
  Add Ring Rs : (stdlib_ring_theory R).

  Lemma flip_lt_negate x y : -y < -x ↔ x < y.
  Proof.
    assert (∀ a b, a < b → -b < -a).
     intros a b E.
     setoid_replace (-b) with (-a + -b + a) by ring.
     setoid_replace (-a) with (-a + -b + b) at 2 by ring.
     now apply (strictly_order_preserving _).
    split; intros; auto.
    rewrite <-(negate_involutive x), <-(negate_involutive y); auto.
  Qed.

  Lemma flip_pos_negate x : 0 < x ↔ -x < 0.
  Proof.
    split; intros E.
     rewrite <- negate_0. now apply flip_lt_negate.
    apply flip_lt_negate. now rewrite negate_0.
  Qed.

  Lemma flip_neg_negate x : x < 0 ↔ 0 < -x.
  Proof.
    rewrite <-(negate_involutive x) at 1.
    split; intros; now apply flip_pos_negate.
  Qed.

  Lemma flip_lt_minus_r (x y z : R) : z < y - x ↔ z + x < y.
  Proof.
    split; intros E.
     rewrite commutativity.
     setoid_replace y with (x + (y - x)) by ring.
     now apply (strictly_order_preserving _).
    rewrite commutativity.
    setoid_replace z with (-x + (z + x)) by ring.
    now apply (strictly_order_preserving _).
  Qed.

  Lemma flip_lt_minus_l (x y z : R) : y - x < z ↔ y < z + x.
  Proof.
    rewrite <-(negate_involutive x) at 2.
    split; now apply flip_lt_minus_r.
  Qed.

  Lemma flip_pos_minus (x y : R) : 0 < y - x ↔ x < y.
  Proof.
    setoid_replace x with (0 + x) at 2 by ring.
    now apply flip_lt_minus_r.
  Qed.

  Lemma flip_neg_minus (x y : R) : y - x < 0 ↔ y < x.
  Proof.
    setoid_replace x with (0 + x) at 2 by ring.
    now apply flip_lt_minus_l.
  Qed.

  Lemma pos_minus_compat (x y z : R) : 0 < z → x < y → x - z < y.
  Proof.
    intros E1 E2.
    rewrite commutativity.
    setoid_replace y with (-z + (y + z)) by ring.
    apply (strictly_order_preserving (-(z) +)).
    transitivity y; trivial.
    setoid_replace y with (y + 0) at 1 by ring.
    now apply (strictly_order_preserving (y +)).
  Qed.

  Lemma between_pos (x : R) : 0 < x → -x < x.
  Proof.
    intros E.
    transitivity 0; trivial.
    now apply flip_pos_negate.
  Qed.
End strict_ring_order.

Section another_ring_order.
  Context `{Ring R1} `{!SemiRingOrder R1le} `{Ring R2} `{R2le : Le R2}.

  Lemma projected_ring_order (f : R2 → R1) `{!SemiRing_Morphism f} `{!Injective f} :
    (∀ x y, x ≤ y ↔ f x ≤ f y) → SemiRingOrder R2le.
  Proof.
    intros P. apply (projected_srorder f P).
    intros x y E. exists (-x + y). now rewrite associativity, plus_negate_r, plus_0_l.
  Qed.

  Context `{!SemiRingOrder R2le} {f : R1 → R2} `{!SemiRing_Morphism f}.

  Lemma reflecting_preserves_nonneg : (∀ x, 0 ≤ f x → 0 ≤ x) → OrderReflecting f.
  Proof.
    intros E. repeat (split; try apply _). intros x y F.
    apply flip_nonneg_minus, E.
    rewrite preserves_plus, preserves_negate.
    now apply flip_nonneg_minus, F.
  Qed.

  Lemma preserves_ge_negate1 `{!OrderPreserving f} x : -1 ≤ x → -1 ≤ f x.
  Proof. intros. rewrite <-(preserves_1 (f:=f)), <-preserves_negate. now apply (order_preserving f). Qed.

  Lemma preserves_le_negate1 `{!OrderPreserving f} x : x ≤ -1 → f x ≤ -1.
  Proof. intros. rewrite <-(preserves_1 (f:=f)), <-preserves_negate. now apply (order_preserving f). Qed.
End another_ring_order.

Section another_strict_ring_order.
  Context `{Ring R1} `{!StrictSemiRingOrder R1lt} `{Ring R2} `{R2lt : Lt R2}.

  Lemma projected_strict_ring_order (f : R2 → R1) `{!SemiRing_Morphism f} :
    (∀ x y, x < y ↔ f x < f y) → StrictSemiRingOrder R2lt.
  Proof.
    intros P. pose proof (projected_strict_setoid_order f P).
    apply from_strict_ring_order.
     repeat (split; try apply _). intros x y E.
     apply P. rewrite 2!preserves_plus.
     now apply (strictly_order_preserving _), P.
    intros x y E1 E2.
    apply P. rewrite preserves_mult, preserves_0.
    now apply pos_mult_compat; rewrite <-(preserves_0 (f:=f)); apply P.
  Qed.
End another_strict_ring_order.

Section another_pseudo_ring_order.
  Context `{Ring R1} `{Apart R1} `{!PseudoSemiRingOrder R1lt}
    `{Ring R2} `{Apart R2} `{R2lt : Lt R2}.

  Lemma projected_pseudo_ring_order (f : R2 → R1) `{!SemiRing_Morphism f} `{!StrongInjective f} :
    (∀ x y, x < y ↔ f x < f y) → PseudoSemiRingOrder R2lt.
  Proof.
    intros P. pose proof (projected_pseudo_order f P).
    pose proof (projected_strict_ring_order f P).
    apply from_pseudo_ring_order; try apply _.
    pose proof (pseudo_order_setoid : StrongSetoid R1).
    pose proof (pseudo_order_setoid : StrongSetoid R2).
    pose proof (strong_injective_mor f).
    repeat (split; try apply _).
    intros x₁ y₁ x₂ y₂ E.
    apply (strong_injective f) in E. rewrite 2!preserves_mult in E.
    destruct (strong_binary_extensionality (.*.) _ _ _ _ E); [left | right]; now apply (strong_extensionality f).
  Qed.
End another_pseudo_ring_order.

Section another_full_pseudo_ring_order.
  Context `{Ring R1} `{Apart R1} `{!FullPseudoSemiRingOrder R1le R1lt}
    `{Ring R2} `{Apart R2} `{R2le : Le R2} `{R2lt : Lt R2}.

  Lemma projected_full_pseudo_ring_order (f : R2 → R1) `{!SemiRing_Morphism f} `{!StrongInjective f} :
    (∀ x y, x ≤ y ↔ f x ≤ f y) → (∀ x y, x < y ↔ f x < f y) → FullPseudoSemiRingOrder R2le R2lt.
  Proof.
    intros P1 P2. pose proof (projected_full_pseudo_order f P1 P2).
    pose proof (projected_pseudo_ring_order f P2).
    split; try apply _. apply le_iff_not_lt_flip.
  Qed.
End another_full_pseudo_ring_order.


Require Export A_14_2.

Module A_e.

Lemma pow_lt_0 : ∀ (a : R) (n : nat), 0 < a -> 0 < a^^n.
Proof.
  intros a n H0. induction n as [| n IHn].
  - simpl. lra.
  - simpl. apply Rmult_lt_0_compat; auto.
Qed.

Lemma pow_lt : ∀ (a b : R) (n : nat), (0 < n)%nat -> 0 < a < b
  -> a^^n < b^^n.
Proof.
  intros a b n H0 H1. induction n as [| n IHn].
  - exfalso. apply Nat.lt_irrefl in H0. assumption.
  - apply lt_n_Sm_le in H0. apply le_lt_or_eq in H0.
    apply or_comm in H0. destruct H0 as [H0 | H0].
    + rewrite <- H0. simpl. lra.
    + apply IHn in H0 as H2. simpl. destruct H1 as [H1 H3].
      generalize (pow_lt_0 a n H1). intro H4.
      apply Rmult_gt_0_lt_compat; lra.
Qed.

Lemma Inequality' : ∀ (a b : R) (n : nat), 0 < a < b -> (0 < n)%nat
  -> b^^(S n) - a^^(S n) < (INR (S n)) * b^^n * (b - a).
Proof.
  intros a b n H0. induction n as [| n IHn].
  - intro H1. apply Nat.lt_irrefl in H1. exfalso. assumption.
  - intro H1. apply lt_n_Sm_le in H1. apply le_lt_or_eq in H1.
    apply or_comm in H1.
    destruct H1 as [H1 | H1].
    + rewrite <- H1 in *. simpl. rewrite Rmult_1_r in *.
      rewrite Rmult_1_r.
      assert (H2 : b * b - a * a = (b + a) * (b - a)). field.
      rewrite H2. apply Rmult_lt_compat_r; lra.
    + apply IHn in H1 as H2.
      assert (H3 : b^^(S (S n)) - a^^(S (S n))
        = b * (b^^(S n) - a^^(S n)) + a^^(S n) * (b - a)).
      simpl. field. rewrite H3.
      assert (H4 : b * (b^^(S n) - a^^(S n)) + a^^(S n) * (b - a)
        < b * (INR (S n) * b^^n * (b - a)) + a^^(S n) * (b - a)).
      { apply Rplus_lt_compat_r. apply Rmult_lt_compat_l; lra. }
      apply Rlt_trans with (r2 := b * (INR (S n) * pow b n * (b - a))
        + pow a (S n) * (b - a)); auto.
      rewrite <- Rmult_assoc. rewrite <- Rmult_assoc.
      rewrite <- Rmult_plus_distr_r.
      apply Rmult_lt_compat_r; try lra.
      assert (H5 : INR (S (S n)) * b^^(S n)
        = b * INR (S n) * b^^n + b^^(S n)).
      simpl. field.
      rewrite H5. apply Rplus_lt_compat_l. apply pow_lt; auto.
Qed.

Lemma Inequality : ∀ (a b : R) (n : nat), 0 < a < b -> (0 < n)%nat
  -> a^^(S n) > b^^n * ((INR (S n)) * a - (INR n) * b).
Proof.
  intros a b n H0 H1. generalize (Inequality' a b n H0 H1). intro H2.
  assert (H3 : pow a (S n) > pow b (S n) - INR (S n) * pow b n * (b - a)).
  lra. assert (H4 : pow b (S n) - INR (S n) * pow b n * (b - a)
    = pow b n * (INR (S n) * a - INR n * b)).
  { simpl pow. rewrite S_INR. field. }
  rewrite <- H4. assumption.
Qed.

Lemma odd_even : ∀ n : nat, ∃ m, (n = m + m \/ n = m + m + 1)%nat.
Proof.
  intro n. induction n as [|n IHn].
  - exists 0%nat. left. simpl. reflexivity.
  - destruct IHn as [m [IHn | IHn]].
    + exists m. right. rewrite IHn. rewrite Nat.add_1_r.
      reflexivity.
    + exists (S m). left. rewrite IHn. rewrite Nat.add_1_r.
      simpl. rewrite (Nat.add_comm m (S m)).
      simpl. reflexivity.
Qed.

Theorem limit_e : ∃ (e : R), limit_seq
  {` λ n v, v = (1 + 1 / (INR (S n)))^^(S n) `} e.
Proof.
  assert (H0 : IsSeq {` λ n v, v = pow (1 + 1 / (INR (S n))) (S n) `}).
  { split.
    - unfold Function. intros x y z I1 I2. apply -> AxiomII' in I1.
      lazy beta in I1. apply -> AxiomII' in I2. lazy beta in I2.
      rewrite I2. assumption.
    - apply AxiomI. intro n; split; intro I1.
      + apply AxiomII. reflexivity.
      + apply AxiomII. exists (pow (1 + 1 / (INR (S n))) (S n)).
        apply AxiomII'. reflexivity. }
  assert (H1 : ∀ (n : nat), {` λ n v, v
    = pow (1 + 1 / (INR (S n))) (S n) `} [n]
    = pow (1 + 1 / (INR (S n))) (S n)).
  { destruct H0 as [H0 I1]. intro n. apply f_x; auto.
    apply AxiomII'. reflexivity. }
  generalize Nat.lt_0_succ. intro H2.
  assert (H3 : IncreaseSeq {` λ n v, v
    = (1 + 1 / (INR (S n)))^^(S n) `}).
  { unfold IncreaseSeq. split; auto.
    intro n. rewrite H1. rewrite H1.
    assert (H3 : 0 < (1 + 1 / (INR (S (S n)))) < (1 + 1 / (INR (S n)))).
    { generalize (pos_INR n). intro I1. rewrite S_INR. rewrite S_INR.
      assert (I2 : 0 < (INR n + 1) < (INR n + 1 + 1)). lra.
      assert (I3 : 0 < (INR n + 1) * (INR n + 1 + 1)).
      { apply Rmult_gt_0_compat; lra. }
      assert (I4 : / (INR n + 1 + 1) < / (INR n + 1)).
      { apply Rinv_lt_contravar; lra. }
      assert (I5 : 0 < / (INR n + 1 + 1)).
      { apply Rinv_0_lt_compat; lra. }
      lra. }
    generalize (Inequality (1 + 1 / INR (S (S n)))
      (1 + 1 / INR (S n)) (S n) H3 (H2 n)). intro H4.
    assert (H5 : INR (S (S n)) * (1 + 1 / INR (S (S n))) -
      INR (S n) * (1 + 1 / INR (S n)) = 1).
    { rewrite S_INR. rewrite S_INR. field.
      generalize (pos_INR n). intro I1. split; lra. }
    rewrite H5 in H4. lra. }
  apply Theorem2_9. left. auto.
  unfold BoundedSeq. split; auto. exists 4.
  assert (H4 : ∀ n, pow (1 + 1 / (2 * INR (S n))) (S n + S n) < 2 * 2).
  { intro n. assert (H5 : 0 < 1 < 1 + 1 / (2 * INR (S n))).
    { split; try lra. rewrite S_INR. generalize (pos_INR n).
      intro H5. assert (H6 : 2 * (INR n + 1) > 0). lra.
      assert (H7 : 1 / (2 * (INR n + 1)) > 0).
      { apply Rdiv_lt_0_compat; lra. }
      lra. }
    generalize (Inequality 1 (1 + 1 / (2 * INR (S n))) (S n) H5 (H2 n)).
    intro H6. assert (H7 : ∀ n, pow 1 n = 1).
    { intro n0. induction n0 as [|n0 IHn].
      - simpl. reflexivity.
      - simpl. rewrite IHn. field. }
    rewrite H7 in H6.
    assert (H8 : INR (S (S n)) * 1 - INR (S n)
      * (1 + 1 / (2 * INR (S n))) = 1 / 2).
    { rewrite S_INR. field. rewrite S_INR.
      generalize (pos_INR n). lra. }
    rewrite H8 in H6.
    assert (H9 : (1 + 1 / (2 * INR (S n)))^^(S n) < 2). lra.
    assert (H10 : ∀ a (m k : nat), (pow a m) * (pow a k) = pow a (m + k)).
    { intros a m k. induction m as [|m IHm].
      - simpl. field.
      - simpl. rewrite Rmult_assoc. rewrite IHm. reflexivity. }
    assert (H11 : ∀ a m, a > 0 -> 0 < pow a m).
    { intros a m I1. induction m as [|m IHm].
      - simpl. lra.
      - simpl. apply Rmult_lt_0_compat; auto. }
    assert (H12 : 0 < 1 + 1 / (2 * INR (S n))).
    { rewrite S_INR. generalize (pos_INR n). intro I1.
      assert (I2 : 2 * (INR n + 1) > 0). lra.
      assert (I3 : 1 / (2 * (INR n + 1)) > 0).
      { apply Rdiv_lt_0_compat; lra. }
      lra. }
    assert (H13 : (pow (1 + 1 / (2 * INR (S n))) (S n))
      * (pow (1 + 1 / (2 * INR (S n))) (S n)) < 2 * 2).
    { apply Rmult_le_0_lt_compat; auto; left; apply H11; auto. }
    rewrite H10 in H13. auto. }
  intro n. rewrite H1.
  assert (H5 : ∀ n, pow (1 + 1 / INR (S n)) (S n) > 0).
  { intro n0. unfold IncreaseSeq in H3. induction n0 as [|n0 IHn].
    - simpl. lra.
    - destruct H3 as [H3 I1]. generalize (I1 n0). intro I2.
      rewrite H1 in I2. rewrite H1 in I2. lra. }
  rewrite Abs_gt; auto.
  assert (H6 : ∀ n, 2 * INR (S n) = INR (S n) + INR (S n)).
  { intro n0. field. }
  apply -> EqualIncrease in H3. destruct H3 as [H3 H7].
  assert (H8 : (n < n + S n)%nat).
  { apply Nat.lt_lt_add_l. apply Nat.lt_succ_diag_r. }
  apply H7 in H8 as H9. rewrite H1 in H9. rewrite H1 in H9.
  assert (H10 : (S (n + S n) = S n + S n)%nat).
  { simpl. reflexivity. }
  rewrite H10 in H9.
  assert (H11 : (INR (S n + S n) = 2 * (INR (S n))%nat)).
  { rewrite plus_INR. ring. }
  rewrite H11 in H9.
  generalize (H4 n). intro H12. lra.
Qed.

End A_e.

Export A_e.


Set Warnings "-notation-overridden".

Require Export Category.
Require Export Isomorphism.

Set Universe Polymorphism.

Reserved Notation "〈 f , g 〉" (at level 40, left associativity).

Class Product {C:Category} (X Y: Obj[C]) := {

  product :> Obj[C];

  pi1 : Hom[C] product X;
  pi2 : Hom[C] product Y;

  product_mapping {Z} : Hom[C] Z X -> Hom[C] Z Y -> Hom[C] Z product
    where "〈 f , g 〉" := (product_mapping f g);

  product_mapping_respects {Z} : Proper (equiv ==> equiv ==> equiv) (product_mapping (Z:=Z));

  product_ump {Z} (h: Hom[C] Z product) (f: Hom[C] Z X) (g: Hom[C] Z Y) :
    h ≈ 〈f,g〉 ↔ (pi1 ∘ h ≈ f) * (pi2 ∘ h ≈ g)
}.

Notation "〈 f , g 〉" := (product_mapping f g).

Notation "X × Y" := (@product _ X Y _)
  (at level 40, left associativity).

Notation "X ×[ C ] Y" := (@product C X Y _)
  (at level 40, left associativity, only parsing).

Lemma product_unique_up_to_iso
  {C:Category}
  {X Y: Obj[C]}
  (p q: Product X Y)
  : product (Product:= p) ≅ product (Product:= q).
Proof.
  simple refine (@Build_Isomorphism _ _ _ _ _ _).
  - apply (product_mapping (Product:=q) (pi1 (Product:=p)) (pi2 (Product:=p))).
  - apply (product_mapping (Product:=p) (pi1 (Product:=q)) (pi2 (Product:=q))).
  - unfold isomorphic.
    simpl.
    split.
    + Unset Printing Notations.
      Set Printing Implicit.
      Check product_ump.
      idtac.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Require Import List.
Require Import Lt.
Require Import Le.
From QuicksortComplexity Require Import util.
From QuicksortComplexity Require Import list_utils.
Require Import Omega.
From QuicksortComplexity Require Import arith_lems.

Fixpoint nats (b: nat) (w: nat) {struct w}: list nat :=
match w with
| 0 => nil
| S w' => b :: nats (S b) w'
end.

Lemma nats_length (w b: nat): length (nats b w) = w.
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.nats_length".
generalize w b; clear w b.
induction w...
simpl.
intros.
rewrite IHw...
Qed.

Lemma In_nats (w x b: nat): b <= x -> x < b + w -> In x (nats b w).
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.In_nats".
revert w x b.
induction w; intros.
elimtype False.
rewrite plus_0_r in H0.
apply (lt_not_le x b H0)...
simpl.
destruct (le_lt_eq_dec _ _ H); [right | left]...
apply IHw...
omega.
Qed.

Lemma In_nats_inv (w x b: nat): In x (nats b w) -> b <= x < b + w.
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.In_nats_inv".
revert w x b.
induction w; simpl; intros.
inversion H.
inversion H.
omega.
destruct (IHw x (S b) H0).
omega.
Qed.

Lemma NoDup_nats (w b: nat): NoDup (nats b w).
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.NoDup_nats".
revert w b.
induction w; simpl; intros.
apply NoDup_nil.
apply NoDup_cons...
intro.
destruct (In_nats_inv _ _ _ H).
apply (le_Sn_n _ H0).
Qed.

Lemma nats_plus y x z: nats x (y + z) = nats x y ++ nats (y + x) z.
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.nats_plus".
revert y x z.
induction y...
intros.
simpl.
rewrite IHy.
rewrite <- plus_n_Sm...
Qed.

Lemma nats_Sw b w: nats b (S w) = b :: nats (S b) w.
Proof. hammer_hook "nat_seqs" "nat_seqs.nats_Sw". auto. Qed.

Lemma nats_split (w b i: nat): i <= w -> nats b w = nats b i ++ nats (b + i) (w - i).
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.nats_split".
intros.
destruct (le_exists_plus H).
subst w.
replace (i + x - i) with x by omega.
rewrite nats_plus.
rewrite plus_comm.
reflexivity.
Qed.

Lemma nats_Sw' w b: nats b (S w) = nats b w ++ (w + b :: nil).
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.nats_Sw'".
revert w b.
induction w...
intros.
rewrite nats_Sw.
rewrite IHw.
simpl.
rewrite plus_n_Sm...
Qed.

Lemma split_pow2_range n:
nats 1 (pow 2 n) = 1 :: concat (map (fun x => nats (pow 2 x + 1) (pow 2 x)) (nats 0 n)).
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.split_pow2_range".
induction n...
simpl pow.
rewrite plus_0_r.
rewrite nats_plus.
rewrite IHn.
rewrite nats_Sw'.
rewrite map_app.
simpl.
rewrite concat_app.
rewrite plus_0_r.
simpl.
rewrite app_nil_r...
Qed.

Lemma nats_Sb w b: nats (S b) w = map S (nats b w).
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.nats_Sb".
revert w b.
induction w...
simpl.
intros.
rewrite IHw...
Qed.

Require Import Relations.
From QuicksortComplexity Require vec.

Lemma filtered_sort (T: Set) (R: relation T) (P: preorder T R) (p: T -> T -> bool) (pc: forall x y, p y x = true -> ~ R y x) (l: list T): vec.sorted R (vec.from_list l) ->
elemsR le (map (fun x => length (filter (p (fst x)) (snd x))) (splits l)) (nats 0 (length l)).
Proof with auto. hammer_hook "nat_seqs" "nat_seqs.filtered_sort".
induction l.
simpl...
intro.
pose proof (IHl (vec.sorted_tail H)). clear IHl.
simpl.
apply eR_cons.
rewrite (fst (conj_prod (list_utils.filter_none _ l)))...
intros.
unfold flip.
pose proof (pc x a).
destruct (p a x)...
elimtype False.
apply H2...
apply (vec.sorted_cons_inv' P H x).
rewrite vec.list_round_trip...
rewrite map_map.
simpl.
apply elemsR_le_S in H0.
rewrite nats_Sb.
transitivity (map S (map (fun x => length (filter (p (fst x)) (snd x))) (splits l)))...
rewrite map_map.
apply elemsR_map_map.
intros.
destruct (p (fst x))...
Qed.


Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Arith.Arith_base.

(***
 *** Domains (which are just pre-orders with a fancy name)
 ***)

Class DomainOrder (A:Type) : Type :=
  approx : relation A.

(* Notation for approx *)
Notation "x '<<<' y" := (approx x y) (at level 80, no associativity).

Class Domain (A:Type) {DomainOrder:DomainOrder A} : Prop :=
  {
    domain_preorder :> PreOrder approx
  }.

(* For setoid_rewrite using approx *)
Add Parametric Relation `{Domain} : A approx
  reflexivity proved by PreOrder_Reflexive
  transitivity proved by PreOrder_Transitive
as Domain_morphism.

(* The restriction of an approximation relation to an equivalence *)
Definition approxEq `{DomainOrder} : relation A :=
  fun a1 a2 => approx a1 a2 /\ approx a2 a1.

(* Notation for approxEq *)
Notation "m1 '==' m2" := (approxEq m1 m2) (at level 80, no associativity).

(* approxEq is always an equivalence *)
Instance approxEq_Equivalence `{Domain} : Equivalence approxEq.
  constructor.
  intro m; split; reflexivity.
  intros m1 m2 H1; destruct H1; split; assumption.
  intros m1 m2 m3 H1 H2; destruct H1; destruct H2; split; transitivity m2; assumption.
Qed.

(* For setoid_rewrite using approxEq *)
Add Parametric Relation `{Domain} : A approxEq
  reflexivity proved by Equivalence_Reflexive
  symmetry proved by Equivalence_Symmetric
  transitivity proved by Equivalence_Transitive
as approxEq_morphism.

(* For rewriting the arguments of approx using approxEq *)
Instance proper_approxEq_approx `{Domain} : Proper (approxEq ==> approxEq ==> iff) approx.
  intros x1 y1 eq1 x2 y2 eq2; destruct eq1; destruct eq2; split; intro.
  transitivity x1; [ assumption | ]; transitivity x2; assumption.
  transitivity y1; [ assumption | ]; transitivity y2; assumption.
Qed.

(***
 *** Some useful domains
 ***)

(* Domains for pairs *)
Instance Pair_DomainOrder A {_:DomainOrder A} B {_:DomainOrder B} :
  DomainOrder (A*B) :=
  fun p1 p2 => approx (fst p1) (fst p2) /\ approx (snd p1) (snd p2).

Instance Pair_Domain A `{Domain A} B `{Domain B} : Domain (prod A B).
  repeat constructor; try reflexivity; destruct H1; destruct H2.
  transitivity (fst y); assumption.
  transitivity (snd y); assumption.
Qed.

(***
 *** Complete Partial Orders
 ***
 *** Technically, these are omega-complete preorders, since cpo_sup only deals
 *** with countable chains and we drop antisymmetry.
 ***)

(* States that a is an upper bound of chain *)
Definition upper_bound {A} (R: relation A) (chain: nat -> A) a :=
  forall n, R (chain n) a.

(* States that a is no greater than any upper bound of chain *)
Definition below_upper_bounds {A} (R: relation A) (chain: nat -> A) a :=
  forall a', upper_bound R chain a' -> R a a'.

(* The supremum function, which works on any countable set of A's *)
Class CPOSupremum (A:Type) {DomainOrder:DomainOrder A} : Type :=
  cpo_sup : (nat -> A) -> A.

(* The definition of a directed countable set *)
Definition directed `{CPOSupremum} (chain: nat -> A) : Prop :=
  forall n1 n2, exists n',
    approx (chain n1) (chain n') /\ approx (chain n2) (chain n').

(* (Omega)-CPO = preorder with least upper bounds of directed countable sets *)
Class CPO (A:Type) {DomainOrder:DomainOrder A}
      {CPOSupremum:@CPOSupremum A DomainOrder} : Prop :=
  {
    cpo_preorder :> Domain A;
    cpo_sup_upper_bound :
      forall chain, directed chain -> upper_bound approx chain (cpo_sup chain);
    cpo_sup_least :
      forall chain,
        directed chain -> below_upper_bounds approx chain (cpo_sup chain)
  }.

(* Two supremums are equivalent iff the chains dominate each other *)
Lemma supremums_equivalent `{CPO} chain1 chain2 :
  directed chain1 -> directed chain2 ->
  (forall n1, exists n2, approx (chain1 n1) (chain2 n2)) ->
  (forall n2, exists n1, approx (chain2 n2) (chain1 n1)) ->
  approxEq (cpo_sup chain1) (cpo_sup chain2).
  intros; split; apply cpo_sup_least; try assumption; intro n.
  destruct (H2 n) as [ n' ]; transitivity (chain2 n'); [ assumption | ].
  apply cpo_sup_upper_bound; assumption.
  destruct (H3 n) as [ n' ]; transitivity (chain1 n'); [ assumption | ].
  apply cpo_sup_upper_bound; assumption.
Qed.

(***
 *** Scott-Continuous Functions
 ***)

(* Scott-continuity = monotonicity + preservation of cpo_sup

NOTE: We put monotonicity as part of the definition of Scott-continuity because
we don't include antisymmetry in our definition of CPO, and the proof that
Scott-continuity implies monotonicity requires a congruence closure step to
prove that (f a2) = (f (cpo_sup (fun n => match n with | 0 => a1 | S _ => a2)))
and this does not work when we only know that a2 is equivalent up to R to this
supremum, not that it is equal. *)
Definition scott_continuous `{CPO} (f : A -> A) : Prop :=
  Proper (approx ==> approx) f /\
  (forall chain,
     directed chain ->
     approxEq (f (cpo_sup chain)) (cpo_sup (fun n => f (chain n)))).

(***
 *** Pointed (omega-)CPOs
 ***)

(* The bottom of a PCPO *)
Class PCPOBottom (A:Type) {DomainOrder:DomainOrder A} : Type :=
  pcpo_bottom : A.

(* PCPO = CPO + a bottom *)
Class PCPO (A:Type) {DomainOrder:DomainOrder A}
      {CPOSupremum:CPOSupremum A (DomainOrder:=DomainOrder)}
      {PCPOBottom:PCPOBottom A (DomainOrder:=DomainOrder)} : Prop :=
  {
    pcpo_cpo :> CPO A (CPOSupremum:=CPOSupremum);
    pcpo_least_element : forall a, approx pcpo_bottom a
  }.

(***
 *** Every Scott-continuous function has a least fixed-point
 ***)

(* Fixed-points of f, modulo the symmetric closure of R *)
Definition fixed_point `{DomainOrder} (f: A -> A) a :=
  approxEq (f a) a.

(* Least fixed-points of f, modulo the symmetric closure of R *)
Definition least_fixed_point `{DomainOrder} (f: A -> A) a :=
  fixed_point f a /\
  forall a', fixed_point f a' -> approx a a'.

(* Iterate a function n times *)
Fixpoint iterate_f {A} n (f: A -> A) :=
  match n with
    | 0 => fun x => x
    | S n' => fun x => f (iterate_f n' f x)
  end.

(* (f^n _|_) `R` (f^(n+1) _|_) for monotone f *)
Lemma iterate_f_increases1 `{PCPO} n f :
  Proper (approx ==> approx) f ->
  approx (iterate_f n f pcpo_bottom) (iterate_f (S n) f pcpo_bottom).
  intro mono; induction n.
  apply pcpo_least_element.
  unfold iterate_f; fold (@iterate_f A).
  apply mono. assumption.
Qed.

(* Similar to above, but for arbitrary n1 <= n2 *)
Lemma iterate_f_increases `{PCPO} n1 n2 f :
  n1 <= n2 -> Proper (approx ==> approx) f ->
  approx (iterate_f n1 f pcpo_bottom) (iterate_f n2 f pcpo_bottom).
  intro l; induction l; intros.
  reflexivity.
  transitivity (iterate_f m f pcpo_bottom).
  apply IHl; assumption.
  apply iterate_f_increases1; assumption.
Qed.

(* Building the least fixed-point of a Scott-continuous function f *)
Definition leastFP `{DomainOrder} {_:CPOSupremum A} {_:PCPOBottom A} f : A :=
  cpo_sup (fun n => iterate_f n f pcpo_bottom).

(* Proof that leastFP gives a fixed-point *)
Lemma leastFP_correct `{PCPO} f :
  scott_continuous f -> least_fixed_point f (leastFP f).
  intro sc; destruct sc.

  (* Helper lemma 1 *)
  assert (directed (fun n : nat => iterate_f n f pcpo_bottom)).
  intros n1 n2; exists (max n1 n2).
  split; apply iterate_f_increases;
    first [ assumption | apply Nat.le_max_l | apply Nat.le_max_r ].

  (* Helper lemma 2 *)
  assert (directed (fun n : nat => f (iterate_f n f pcpo_bottom))).
  intros n1 n2; exists (max n1 n2).
  unfold iterate_f; fold (@iterate_f A (S n1) f pcpo_bottom);
  fold (@iterate_f A (S n2) f pcpo_bottom);
  fold (@iterate_f A (S (max n1 n2)) f pcpo_bottom).
  split; apply iterate_f_increases; try (apply le_n_S);
    first [ assumption | apply Nat.le_max_l | apply Nat.le_max_r ].

  split; unfold leastFP, fixed_point.

  (* Proof that leastFP is a fixed-point *)
  transitivity (cpo_sup (fun n => f (iterate_f n f pcpo_bottom))).
  apply H1; assumption.
  apply supremums_equivalent; try assumption; intro.
  exists (S n1); reflexivity.
  exists n2. apply iterate_f_increases1; assumption.

  (* Proof that leastFP is a least fixed-point *)
  intros fp is_fp.
  apply cpo_sup_least; try assumption.
  intro n; induction n.
  apply pcpo_least_element.
  transitivity (f fp).
  apply H0; assumption.
  destruct is_fp; assumption.
Qed.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(** * Solvability of finite multiset constraints FMsetC_SAT  *)

(*
  Problem:
    Finite Multiset Constraint Solvability (FMsetC_SAT)

  Finite multisets with one constant 0 and one unary constructor h.
  A finite multiset A is represented by a list of its elements.
  The element (h^n 0) is represented by the natural number n.

  Constraints are of shape:
    x ≐ [0]
    x ≐ y ⊍ z
    x ≐ h (y)

  Constraint semantics:
    φ(y ⊍ z) = φ(y) ++ φ(z)
    φ(h (y)) = map h (φ(y))

  FMsetC:
    Given a list of constraints,
    is there a valuation φ : nat -> list nat such that
    for each constraint c we have
      if c is x ≐ [0], then φ(x) ≡ [0]
      if c is x ≐ y ⊍ z, then φ(x) ≡ φ(y) ++ φ(z)
      if c is x ≐ h (y), then φ(x) ≡ map S (φ(y))
    where ≡ is equality up to permutation?

  References:
    [1] Paliath Narendran: Solving Linear Equations over Polynomial Semirings.
      LICS 1996: 466-472, doi: 10.1109/LICS.1996.561463
*)

Require Import PeanoNat List.
Import ListNotations.

(* list equality up to permutation *)
Definition mset_eq (A B: list nat) : Prop :=
  forall c, count_occ Nat.eq_dec A c = count_occ Nat.eq_dec B c.
Local Notation "A ≡ B" := (mset_eq A B) (at level 65).

(* constraints *)
Inductive msetc : Set :=
  | msetc_zero : nat -> msetc
  | msetc_sum : nat -> nat -> nat -> msetc
  | msetc_h : nat -> nat -> msetc.

(* constraint semantics *)
Definition msetc_sem (φ: nat -> list nat) (c: msetc) :=
  match c with
    | msetc_zero x => φ x ≡ [0]
    | msetc_sum x y z => φ x ≡ (φ y) ++ (φ z)
    | msetc_h x y => φ x ≡ map S (φ y)
  end.

(* given a list l of constraints,
  is there a valuation φ satisfying each constraint? *)
Definition FMsetC_SAT (l : list msetc) := exists φ, forall c, In c l -> msetc_sem φ c.


From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
Require Import ssreflect.

Open Scope Z.

(* Some definitions relating to the functional spec of this particular program.  *)
Definition list_cswap (b:Z) (p q : list Z) : list Z :=
  if (Z.eqb b 0) then
    p
  else q.

Local Lemma list_cswap_nth_true: forall i d p q,
  nth i (list_cswap 1 p q) d = nth i q d.
Proof. go. Qed.

Local Lemma list_cswap_nth_false: forall i d p q,
  nth i (list_cswap 0 p q) d = nth i p d.
Proof. go. Qed.

Local Lemma list_cswap_length_eq: forall b p q, length p = length q -> length p = length (list_cswap b p q).
Proof. intros; unfold list_cswap; destruct (Z.eqb b 0); go. Qed.

Local Lemma list_cswap_Zlength_eq: forall b p q, Zlength p = Zlength q -> Zlength p = Zlength (list_cswap b p q).
Proof. intros; unfold list_cswap; destruct (Z.eqb b 0); go. Qed.

Local Lemma list_cswap_bound_le : forall p pmin pmax q qmin qmax,
  Forall (fun x => pmin <= x <= pmax) p ->
  Forall (fun x => qmin <= x <= qmax) q -> forall b,
  Forall (fun x => Z.min pmin qmin <= x <= Z.max pmax qmax) (list_cswap b p q).
Proof.
move=> p pmin pmax q qmin qmax Hp Hq.
elim => [|?|?]; unfold list_cswap ; simpl;
eapply list.Forall_impl ; eauto;
intros x H; simpl in H;
destruct H as [Hmin Hmax]; split;
eapply Z.le_trans ; eauto;
try apply Z.le_min_l;try apply Z.le_min_r;try apply Z.le_max_l;try apply Z.le_max_r.
Qed.

Local Lemma list_cswap_bound_lt_le : forall p pmin pmax q qmin qmax,
  Forall (fun x => pmin < x < pmax) p ->
  Forall (fun x => qmin < x < qmax) q -> forall b,
  Forall (fun x => Z.min pmin qmin <= x <= Z.max pmax qmax) (list_cswap b p q).
Proof.
move=> p pmin pmax q qmin qmax Hp Hq.
elim => [|?|?]; unfold list_cswap ; simpl;
eapply list.Forall_impl ; eauto;
intros x H; simpl in H;
destruct H as [Hmin Hmax]; split;apply Z.lt_le_incl;
try solve[
eapply Z.le_lt_trans ; eauto;
try apply Z.le_min_l;try apply Z.le_min_r;try apply Z.le_max_l;try apply Z.le_max_r];
eapply Z.lt_le_trans ; eauto;
try apply Z.le_min_l;try apply Z.le_min_r;try apply Z.le_max_l;try apply Z.le_max_r.
Qed.

Local Lemma list_cswap_bound_lt : forall p pmin pmax q qmin qmax,
  Forall (fun x => pmin < x < pmax) p ->
  Forall (fun x => qmin < x < qmax) q -> forall b,
  Forall (fun x => Z.min pmin qmin < x < Z.max pmax qmax) (list_cswap b p q).
Proof.
move=> p pmin pmax q qmin qmax Hp Hq.
elim => [|?|?]; unfold list_cswap ; simpl;
eapply list.Forall_impl ; eauto;
intros x H; simpl in H;
destruct H as [Hmin Hmax]; split;
try solve[
eapply Z.le_lt_trans ; eauto;
try apply Z.le_min_l;try apply Z.le_min_r;try apply Z.le_max_l;try apply Z.le_max_r];
eapply Z.lt_le_trans ; eauto;
try apply Z.le_min_l;try apply Z.le_min_r;try apply Z.le_max_l;try apply Z.le_max_r.
Qed.

Close Scope Z.

Module Low.

Definition Sel25519 b p q := list_cswap b p q.

End Low.

Lemma Sel25519_length_eq: forall b p q, length p = length q -> length p = length (Low.Sel25519 b p q).
Proof. rewrite /Low.Sel25519 ; apply list_cswap_length_eq. Qed.

Lemma Sel25519_Zlength_eq: forall b p q, Zlength p = Zlength q -> Zlength p = Zlength (Low.Sel25519 b p q).
Proof. rewrite /Low.Sel25519 ; apply list_cswap_Zlength_eq. Qed.

Lemma Sel25519_length: forall b p q,
  length p = 16 ->
  length q = 16 ->
  length (Low.Sel25519 b p q) = 16.
Proof. intros; rewrite -Sel25519_length_eq; omega. Qed.

Open Scope Z.

Lemma ZofList_Sel25519: forall n b p q,
  ZofList n (Low.Sel25519 b p q) = if (Z.eqb b 0) then
    ZofList n p
  else ZofList n q.
Proof. intros. rewrite /Low.Sel25519 /list_cswap. destruct (b =? 0) ; reflexivity. Qed.

Lemma Sel25519_Zlength: forall b p q,
  Zlength p = 16 ->
  Zlength q = 16 ->
  Zlength (Low.Sel25519 b p q) = 16.
Proof. intros; rewrite -Sel25519_Zlength_eq; omega. Qed.

Lemma Sel25519_bound_le : forall p pmin pmax q qmin qmax,
  Forall (fun x => pmin <= x <= pmax) p ->
  Forall (fun x => qmin <= x <= qmax) q -> forall b,
  Forall (fun x => Z.min pmin qmin <= x <= Z.max pmax qmax) (Low.Sel25519 b p q).
Proof. rewrite /Low.Sel25519 ; apply list_cswap_bound_le. Qed.

Lemma Sel25519_bound_lt_trans_le : forall p pmin pmax q qmin qmax,
  Forall (fun x => pmin < x < pmax) p ->
  Forall (fun x => qmin < x < qmax) q -> forall b,
  Forall (fun x => Z.min pmin qmin <= x <= Z.max pmax qmax) (Low.Sel25519 b p q).
Proof. rewrite /Low.Sel25519 ; apply list_cswap_bound_lt_le. Qed.

Lemma Sel25519_bound_lt : forall p pmin pmax q qmin qmax,
  Forall (fun x => pmin < x < pmax) p ->
  Forall (fun x => qmin < x < qmax) q -> forall b,
  Forall (fun x => Z.min pmin qmin < x < Z.max pmax qmax) (Low.Sel25519 b p q).
Proof. rewrite /Low.Sel25519 ; apply list_cswap_bound_lt. Qed.

Lemma Sel25519_bound_lt_le_id : forall pmin pmax p q,
  Forall (fun x => pmin <= x < pmax) p ->
  Forall (fun x => pmin <= x < pmax) q -> forall b,
  Forall (fun x => pmin <= x < pmax) (Low.Sel25519 b p q).
Proof. rewrite /Low.Sel25519 ; intros; unfold list_cswap; destruct (Z.eqb b 0); go. Qed.

Lemma Sel25519_bound_lt_lt_id : forall pmin pmax p q,
  Forall (fun x => pmin < x < pmax) p ->
  Forall (fun x => pmin < x < pmax) q -> forall b,
  Forall (fun x => pmin < x < pmax) (Low.Sel25519 b p q).
Proof. rewrite /Low.Sel25519 ; intros; unfold list_cswap; destruct (Z.eqb b 0); go. Qed.

Lemma Sel25519_bound_le_le_id : forall pmin pmax p q,
  Forall (fun x => pmin <= x <= pmax) p ->
  Forall (fun x => pmin <= x <= pmax) q -> forall b,
  Forall (fun x => pmin <= x <= pmax) (Low.Sel25519 b p q).
Proof. rewrite /Low.Sel25519 ; intros; unfold list_cswap; destruct (Z.eqb b 0); go. Qed.

Lemma Sel25519_bound_le_lt_trans_le_id : forall pmin pmax p q,
  Forall (fun x => pmin <= x < pmax) p ->
  Forall (fun x => pmin <= x < pmax) q -> forall b,
  Forall (fun x => pmin <= x <= pmax) (Low.Sel25519 b p q).
Proof. rewrite /Low.Sel25519 ; intros; unfold list_cswap; destruct (Z.eqb b 0).
eapply list.Forall_impl ; eauto ; intros x Hx ; simpl in Hx ; omega.
eapply list.Forall_impl ; eauto ; intros x Hx ; simpl in Hx ; omega.
Qed.

Close Scope Z.


Set Warnings "-notation-overridden,-parsing".
Add LoadPath "/Users/jikl/demos/coq/software-foundation-exercise/logic_foundation" as LF.
From Coq Require Import Strings.String.
From LF Require Import Maps.
From PLF Require Import Types.
From PLF Require Import SmallStep.

Inductive ty : Type :=
| Top : ty
| Bool : ty
| Base : string -> ty
| Arrow : ty -> ty -> ty
| Unit : ty
| Prod : ty -> ty -> ty.

Inductive tm : Type :=
| var : string -> tm
| app : tm -> tm -> tm
| abs : string -> ty -> tm -> tm
| tru : tm
| fls : tm
| test : tm -> tm -> tm -> tm
| unit : tm
| pair : tm -> tm -> tm
| fst : tm -> tm
| snd : 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)
  | tru | fls | unit => t
  | test t1 t2 t3 =>
    test (subst x s t1) (subst x s t2) (subst x s t3)
  | 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)
  end.

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

Inductive value : tm -> Prop :=
| v_abs : forall x T t,
    value (abs x T t)
| v_true :
    value tru
| v_false :
    value fls
| v_unit :
    value unit
| v_pair : forall v1 v2,
    value v1 ->
    value v2 ->
    value (pair v1 v2).

Hint Constructors value : db.

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (app (abs x T 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_TestTrue : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFalse : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)
  | 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
where "t1 '-->' t2" := (step t1 t2).

Hint Constructors step : db.

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
| S_Refl : forall T,
    T <: T
| S_Trans : forall S U T,
    S <: U ->
    U <: T ->
    S <: T
| S_Top : forall S,
    S <: Top
| S_Arrow : forall S1 S2 T1 T2,
    T1 <: S1 ->
    S2 <: T2 ->
    (Arrow S1 S2) <: (Arrow T1 T2)
| S_Prod : forall S1 S2 T1 T2,
    S1 <: T1 ->
    S2 <: T2 ->
    Prod S1 S2 <: Prod T1 T2

where "T '<:' U" := (subtype T U).

Hint Constructors subtype : db.

Module Examples.

  Open Scope string_scope.
  Notation x := "x".
  Notation y := "y".
  Notation z := "z".
  Notation A := (Base "A").
  Notation B := (Base "B").
  Notation C := (Base "C").
  Notation String := (Base "String").
  Notation Float := (Base "Float").
  Notation Integer := (Base "Integer").

  Example subtyping_example_0 :
    (Arrow C Bool) <: (Arrow C Top).
  Proof. auto with db. Qed.

  (* Person := { name : String }
     Student := { name : String; gpa : Float }
     Employee := { name : String; ssn : Interger }
   *)

  Definition Person : ty := Prod (Prod A String) Top.

  Definition Student : ty := Prod (Prod A String) (Prod B Float).

  Definition Employee : ty := Prod (Prod A String) (Prod C Integer).

  Example sub_student_person :
    Student <: Person.
  Proof.
    unfold Student, Person.
    apply S_Prod.
    - apply S_Refl.
    - apply S_Top.
  Qed.

  Example sub_employee_person :
    Employee <: Person.
  Proof.
    unfold Employee, Person.
    apply S_Prod.
    - apply S_Refl.
    - apply S_Top.
  Qed.

  Example subtyping_example_1 :
    (Arrow Top Student) <: (Arrow (Arrow C C) Person).
  Proof.
    apply S_Arrow.
    - apply S_Top.
    - apply sub_student_person.
  Qed.

  Example subtyping_example_2 :
    (Arrow Top Person) <: (Arrow Person Top).
  Proof with eauto.
    apply S_Arrow.
    - apply S_Top.
    - apply S_Top.
  Qed.

End Examples.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).
Inductive has_type : context -> tm -> ty -> Prop :=
  (* Same as before *)
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- var x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      (x |-> T11 ; Gamma) |- t12 \in T12 ->
      Gamma |- abs x T11 t12 \in Arrow T11 T12
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in Arrow T1 T2 ->
      Gamma |- t2 \in T1 ->
      Gamma |- app t1 t2 \in T2
  | T_True : forall Gamma,
       Gamma |- tru \in Bool
  | T_False : forall Gamma,
       Gamma |- fls \in Bool
  | T_Test : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in Bool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- test t1 t2 t3 \in T
  | T_Unit : forall Gamma,
      Gamma |- unit \in Unit
  (* New rule of subsumption *)
  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      S <: T ->
      Gamma |- t \in T
  | T_Pair : forall t1 t2 T1 T2 Gamma,
      Gamma |- t1 \in T1 ->
      Gamma |- t2 \in T2 ->
      Gamma |- (pair t1 t2) \in Prod T1 T2
  | T_Fst : forall Gamma t T1 T2,
      Gamma |- t \in (Prod T1 T2) ->
      Gamma |- (fst t) \in T1
  | T_Snd : forall Gamma t T1 T2,
      Gamma |- t \in (Prod T1 T2) ->
      Gamma |- (snd t) \in T2

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type : db.

Hint Extern 2 (has_type _ (app _ _) _) =>
eapply T_App; auto : db.

Hint Extern 2 (_ = _) => compute; reflexivity: db.

Module Examples2.
  Import Examples.

  Example typing_example_0 :
    empty |- pair (abs z A (var z)) (abs z B (var z)) \in Prod (Arrow A A) (Arrow B B).
  Proof with eauto.
    auto with db.
  Qed.

  Example typing_example_1 :
    empty |- app (abs x (Prod Top (Arrow B B)) (snd (var x)))
                 (pair (abs z A (var z)) (abs z B (var z))) \in Arrow B B.
  Proof with eauto.
    eapply T_App.
    - eapply T_Abs. eapply T_Snd. apply T_Var. rewrite update_eq. auto with db.
    - apply T_Pair.
      + eapply T_Sub. apply T_Abs. apply T_Var. auto with db. apply S_Top.
      + apply T_Abs. apply T_Var. auto with db.
  Qed.

  Example typing_example_2 :
    empty |- app (abs z (Arrow (Arrow C C) (Prod Top (Arrow B B)))
                      (snd (app (var z) (abs x C (var x)))))
                 (abs z (Arrow C C) (pair (abs z A (var z)) (abs z B (var z)))) \in Arrow B B.
  Proof with eauto.
    eapply T_App...
    - apply T_Abs. eapply T_Snd. eapply T_App.
      + apply T_Var. auto with db.
      + apply T_Abs. apply T_Var. auto with db.
    - apply T_Abs. apply T_Pair.
      + eapply T_Sub.
        * apply T_Abs. apply T_Var. auto with db.
        * apply S_Top.
      + apply T_Abs. apply T_Var. auto with db.
  Qed.

End Examples2.

Lemma sub_inversion_Bool : forall U,
    U <: Bool ->
    U = Bool.
Proof with auto with db.
  intros U Hs.
  remember Bool as V eqn:EVBool.
  induction Hs; try solve [inversion EVBool].
  - reflexivity.
  - assert (U = T) as EUT.
    { apply IHHs2. apply EVBool. }
    rewrite <- EUT. apply IHHs1. subst...
Qed.

Lemma sub_inversion_arrow : forall U V1 V2,
    U <: Arrow V1 V2 ->
    exists U1 U2,
    U = Arrow U1 U2 /\ V1 <: U1 /\ U2 <: V2.
Proof.
  intros U V1 V2 Hs.
  remember (Arrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  induction Hs; intros V1 V2 H; try (inversion H).
  - exists V1, V2. auto with db.
  - assert (H1 : exists U1 U2 : ty,
               U = Arrow U1 U2 /\ V1 <: U1 /\ U2 <: V2).
    { apply IHHs2. apply H. }
    destruct H1 as [U1' [U2' [H1 [ H2 H3]] ]].
    assert (H4 : exists U1 U2 : ty,
               S = Arrow U1 U2 /\ U1' <: U1 /\ U2 <: U2').
    { apply IHHs1. apply H1. }
    destruct H4 as [U1 [U2 [H5 [H6 H7]]]].
    exists U1, U2.
    split.
    + apply H5.
    + split.
      * apply (S_Trans _ _ _ H2 H6).
      * apply (S_Trans _ _ _ H7 H3).
  - subst. exists S1, S2. auto with db.
Qed.

Lemma sub_inversion_prod : forall U V1 V2,
    U <: Prod V1 V2 ->
    exists U1 U2,
    U = Prod U1 U2 /\ U1 <: V1 /\ U2 <: V2.
Proof.
  intros U V1 V2 Hs.
  remember (Prod V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  induction Hs; intros V1 V2 H; try (inversion H).
  - exists V1, V2. auto with db.
  - assert (H1 : exists U1 U2 : ty,
               U = Prod U1 U2 /\ U1 <: V1 /\ U2 <: V2).
    { apply IHHs2. apply H. }
    destruct H1 as [U1' [U2' [H1 [ H2 H3]] ]].
    assert (H4 : exists U1 U2 : ty,
               S = Prod U1 U2 /\ U1 <: U1' /\ U2 <: U2').
    { apply IHHs1. apply H1. }
    destruct H4 as [U1 [U2 [H5 [H6 H7]]]].
    exists U1, U2.
    split.
    + apply H5.
    + split.
      * apply (S_Trans _ _ _ H6 H2).
      * apply (S_Trans _ _ _ H7 H3).
  - subst. exists S1, S2. auto with db.
Qed.

Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
  Gamma |- s \in Arrow T1 T2 ->
  value s ->
  exists x S1 s2, s = abs x S1 s2.
Proof.
  intros Gamma s T1 T2 H1.
  remember (Arrow T1 T2) as ATT.
  generalize dependent T2. generalize dependent T1.
  induction H1; intros T1' T2' H2 H3; try (inversion H2); try (inversion H3).
  - exists x, T11, t12. subst; reflexivity.
  - subst. clear H0. exists x, T0, t0. reflexivity.
  - subst. clear H0.
    assert (HTS : exists U1 U2, S = Arrow U1 U2 /\ T1' <: U1 /\ U2 <: T2').
    { apply sub_inversion_arrow. apply H. }
    destruct HTS as [U1 [U2 [H4 [H5 H6]]]].
    apply (IHhas_type _ _) in H4.
    { apply H4. }
    { apply v_true. }
  - subst. clear H0.
    assert (HTS : exists U1 U2, S = Arrow U1 U2 /\ T1' <: U1 /\ U2 <: T2').
    { apply sub_inversion_arrow. apply H. }
    destruct HTS as [U1 [U2 [H4 [H5 H6]]]].
    apply (IHhas_type _ _) in H4.
    { apply H4. }
    { apply v_false. }
  - subst. clear H0.
    assert (HTS : exists U1 U2, S = Arrow U1 U2 /\ T1' <: U1 /\ U2 <: T2').
    { apply sub_inversion_arrow. apply H. }
    destruct HTS as [U1 [U2 [H4 [H5 H6]]]].
    apply (IHhas_type _ _) in H4.
    { apply H4. }
    { apply v_unit. }
  - subst. clear H0.
    assert (HTS : exists U1 U2, S = Arrow U1 U2 /\ T1' <: U1 /\ U2 <: T2').
    { apply sub_inversion_arrow. apply H. }
    destruct HTS as [U1 [U2 [H6 [H7 H8]]]].
    apply (IHhas_type _ _) in H6.
    { apply H6. }
    { apply v_pair; assumption. }
Qed.

Lemma canonical_forms_of_Bool : forall Gamma s,
  Gamma |- s \in Bool ->
  value s ->
  s = tru \/ s = fls.
Proof with eauto with db.
  intros Gamma s H1.
  remember Bool as TB.
  induction H1; intro Hval; try (inversion Hval); try (inversion HeqTB); subst...
  - clear H2. apply (sub_inversion_Bool _) in H. auto.
  - clear H2. apply (sub_inversion_Bool _) in H. auto.
  - clear H4. apply (sub_inversion_Bool _) in H. auto.
Qed.

Lemma canonical_forms_of_prod_types : forall Gamma s T1 T2,
    Gamma |- s \in Prod T1 T2 ->
                   value s ->
                   exists s1 s2,
                     s = pair s1 s2.
Proof with eauto with db.
  intros Gamma s T1 T2 H1.
  remember (Prod T1 T2) as PTT.
  generalize dependent T2. generalize dependent T1.
  induction H1; intros T1' T2' H2 H3; try (inversion H2); try (inversion H3).
  - subst. clear H0.
    assert (HTS : exists U1 U2, S = Prod U1 U2 /\ U1 <: T1' /\ U2 <: T2').
    { apply sub_inversion_prod. apply H. }
    destruct HTS as [U1 [U2 [H4 [H5 H6]]]].
    apply (IHhas_type _ _) in H4.
    { apply H4. }
    { apply v_abs. }
  - subst. clear H0.
    assert (HTS : exists U1 U2, S = Prod U1 U2 /\ U1 <: T1' /\ U2 <: T2').
    { apply sub_inversion_prod. apply H. }
    destruct HTS as [U1 [U2 [H4 [H5 H6]]]].
    apply (IHhas_type _ _) in H4.
    { apply H4. }
    { apply v_true. }
  - subst. clear H0.
    assert (HTS : exists U1 U2, S = Prod U1 U2 /\ U1 <: T1' /\ U2 <: T2').
    { apply sub_inversion_prod. apply H. }
    destruct HTS as [U1 [U2 [H4 [H5 H6]]]].
    apply (IHhas_type _ _) in H4.
    { apply H4. }
    { apply v_false. }
  - subst. clear H0.
    assert (HTS : exists U1 U2, S = Prod U1 U2 /\ U1 <: T1' /\ U2 <: T2').
    { apply sub_inversion_prod. apply H. }
    destruct HTS as [U1 [U2 [H4 [H5 H6]]]].
    apply (IHhas_type _ _) in H4.
    { apply H4. }
    { apply v_unit. }
  - eauto with db.
  - eauto with db.
Qed.

Theorem progress : forall t T,
    empty |- t \in T ->
    value t \/ exists t', t --> t'.
Proof with eauto with db.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  induction Ht; intros HeqGamma; subst...
  - inversion H.
  - right.
    destruct IHHt1; subst...
    + destruct IHHt2; subst...
      * destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists ([x:=t2]t12)...
      * inversion H0 as [t2' Hstp]. exists (app t1 t2')...
    + inversion H as [t1' Hstp]. exists (app t1' t2)...
  - right.
    destruct IHHt1.
    + auto.
    + assert (t1 = tru \/ t1 = fls) by (eapply canonical_forms_of_Bool; eauto).
      inversion H0; subst...
    + inversion H. rename x into t1'. eauto with db.
  - destruct IHHt1; subst...
    + destruct IHHt2; subst...
      right. inversion H0 as [t2' Hstp]. exists (pair t1 t2')...
    + right. inversion H as [t1' Hstp]. exists (pair t1' t2)...
  - destruct IHHt; subst...
    + right. destruct (canonical_forms_of_prod_types empty t T1 T2)
        as [t1 [t2 Heqt]].
      * apply Ht.
      * apply H.
      * subst. inversion H. exists t1. apply ST_FstPair; assumption.
    + right. inversion H as [t' Hstp]. exists (fst t')...
  - destruct IHHt; subst...
    + right. destruct (canonical_forms_of_prod_types empty t T1 T2)
        as [t1 [t2 Heqt]].
      * apply Ht.
      * apply H.
      * subst. inversion H. exists t2. apply ST_SndPair; assumption.
    + right. inversion H as [t' Hstp]. exists (snd t')...
Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
    Gamma |- (abs x S1 t2) \in T ->
    exists S2,
      Arrow S1 S2 <: T
      /\ (x |-> S1; Gamma) |- t2 \in S2.
Proof with eauto with db.
  intros Gamma x S1 t2 T H.
  remember (abs x S1 t2) as t.
  induction H; inversion Heqt; subst; intros; try solve_by_invert.
  - exists T12...
  - destruct IHhas_type as [S2 [Hsub Hty]]...
Qed.

Lemma typing_inversion_var : forall Gamma x T,
    Gamma |- (var x) \in T ->
    exists S,
      Gamma x = Some S /\ S <: T.
Proof with eauto with db.
  intros Gamma x T H.
  remember (var x) as v.
  induction H; inversion Heqv; subst; intros; try solve_by_invert.
  - exists T...
  - destruct IHhas_type as [S1 [Hsub Hty]]...
Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
    Gamma |- (app t1 t2) \in T2 ->
    exists T1,
      Gamma |- t1 \in (Arrow T1 T2) /\
      Gamma |- t2 \in T1.
Proof with eauto with db.
  intros Gamma t1 t2 T2 H.
  remember (app t1 t2) as Tapp.
  induction H; inversion HeqTapp; subst; intros; try solve_by_invert.
  - exists T1...
  - destruct IHhas_type as [T1 [Habs Ht]]...
Qed.

Lemma typing_inversion_true : forall Gamma T,
    Gamma |- tru \in T ->
    Bool <: T.
Proof with eauto with db.
  intros Gamma T H.
  remember tru as tt.
  induction H; inversion Heqtt; subst...
Qed.

Lemma typing_inversion_false : forall Gamma T,
    Gamma |- fls \in T ->
    Bool <: T.
Proof with eauto with db.
  intros Gamma T H.
  remember fls as tf.
  induction H; inversion Heqtf; subst...
Qed.

Lemma typing_inversion_if : forall Gamma t1 t2 t3 T,
    Gamma |- (test t1 t2 t3) \in T ->
    Gamma |- t1 \in Bool
    /\ Gamma |- t2 \in T
    /\ Gamma |- t3 \in T.
Proof with eauto with db.
  intros Gamma t1 t2 t3 T H.
  remember (test t1 t2 t3) as ttest.
  induction H; inversion Heqttest; subst...
  destruct IHhas_type as [H2 [H3 H4]]...
Qed.

Lemma typing_inversion_unit : forall Gamma T,
    Gamma |- unit \in T ->
    Unit <: T.
Proof with eauto with db.
  intros Gamma T H.
  remember unit as tu.
  induction H; inversion Heqtu; subst...
Qed.

Lemma typing_inversion_pair : forall Gamma t1 t2 T,
    Gamma |- (pair t1 t2) \in T ->
    exists T1 T2,
    Gamma |- t1 \in T1 /\ Gamma |- t2 \in T2 /\ Prod T1 T2 <: T.
Proof with eauto with db.
  intros Gamma t1 t2 T H.
  remember (pair t1 t2) as tp.
  induction H; inversion Heqtp; subst...
  destruct IHhas_type as [T1 [T2 [H2 [H3 H4]]]]...
  exists T1, T2...
Qed.

Lemma typing_inversion_fst : forall Gamma t T1,
    Gamma |- fst t \in T1 ->
    exists T2,
    Gamma |- t \in Prod T1 T2.
Proof with eauto with db.
  intros Gamma t T1 H.
  remember (fst t) as ft.
  induction H; inversion Heqft; subst...
  destruct IHhas_type as [T2 H2]...
Qed.

Lemma typing_inversion_snd : forall Gamma t T2,
    Gamma |- snd t \in T2 ->
    exists T1,
    Gamma |- t \in Prod T1 T2.
Proof with eauto with db.
  intros Gamma t T1 H.
  remember (snd t) as st.
  induction H; inversion Heqst; subst...
  destruct IHhas_type as [T2 H2]...
Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  empty |- (abs x S1 s2) \in (Arrow T1 T2) ->
  T1 <: S1
  /\ (x |-> S1 ; empty) |- s2 \in T2.
Proof with eauto with db.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  inversion Hty as [S2 [Hsub Hty1]].
  apply sub_inversion_arrow in Hsub.
  inversion Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...
Qed.

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_test1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (test t1 t2 t3)
  | afi_test2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (test t1 t2 t3)
  | afi_test3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (test t1 t2 t3)
                      | afi_pairL : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (pair t1 t2)
  | afi_pairR : 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)
.
Hint Constructors appears_free_in : db.

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

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
Proof with eauto with db.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; subst; inversion Hafi; subst...
  destruct (IHHtyp H4) as [T Hctx]. exists T.
  unfold update, t_update in Hctx.
  rewrite <- eqb_string_false_iff in H2.
  rewrite H2 in Hctx...
Qed.

Lemma substitution_preserves_typing : forall Gamma x U v t S,
    (x |-> U; Gamma) |- t \in S ->
    empty |- v \in U ->
    Gamma |- [x:=v]t \in S.
Proof with eauto with db.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  induction t; intros; simpl.
  - rename s into y.
    destruct (typing_inversion_var _ _ _ Htypt) as
        [T [Hctx Hsub]].
    unfold update, t_update in Hctx.
    destruct (eqb_stringP x y) as [Hxy|Hxy]; eauto; subst...
    inversion Hctx; subst. clear Hctx.
    apply context_invariance with empty...
    intros x Hcontra.
    destruct (free_in_context _ _ S empty Hcontra) as
        [T' HT']...
    inversion HT'.
  - destruct (typing_inversion_app _ _ _ _ Htypt) as
        [T1 [Htypt1 Htypt2]].
    eapply T_App...
  - rename s into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    apply T_Sub with (Arrow T1 T2)... apply T_Abs...
    destruct (eqb_stringP x y) as [Hxy|Hxy].
    + 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 <- eqb_string_false_iff in Hxy. rewrite Hxy...
  - assert (Bool <: S)
      by apply (typing_inversion_true _ _ Htypt)...
  - assert (Bool <: S)
      by apply (typing_inversion_false _ _ Htypt)...
  - assert ((x |-> U; Gamma) |- t1 \in Bool
         /\ (x |-> U; Gamma) |- t2 \in S
         /\ (x |-> U; Gamma) |- t3 \in S)
      by apply (typing_inversion_if _ _ _ _ _ Htypt).
    inversion H as [H1 [H2 H3]].
    apply IHt1 in H1. apply IHt2 in H2. apply IHt3 in H3.
    auto with db.
  - assert (Unit <: S)
      by apply (typing_inversion_unit _ _ Htypt)...
  - destruct (typing_inversion_pair _ _ _ _ Htypt) as
        [T1 [T2 [H1 [H2 H3]]]].
    apply T_Sub with (Prod T1 T2)...
  - destruct (typing_inversion_fst _ _ _ Htypt) as
        [T2 H2]...
  - destruct (typing_inversion_snd _ _ _ Htypt) as
        [T1 H2]...
Qed.

Theorem preservation : forall t t' T,
    empty |- t \in T ->
    t --> t' ->
    empty |- t' \in T.
Proof with eauto with db.
  intros t t' T HT.
  remember empty as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT; intros t' HeqGamma HE; subst; inversion HE; subst...
  - apply (abs_arrow _ _ _ _ _) in HT1.
    destruct HT1 as [Hsub Htypt].
    eapply substitution_preserves_typing.
    + apply Htypt.
    + eapply T_Sub. apply HT2. apply Hsub.
  - apply (typing_inversion_pair _ _ ) in HT.
    destruct HT as [T3 [T4 [H2 [H3 H4]]]].
    apply (sub_inversion_prod _ _ _ ) in H4.
    destruct H4 as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
    inversion Heq; subst.
    eapply T_Sub. apply H2. apply Hsub1.
  - apply (typing_inversion_pair _ _ ) in HT.
    destruct HT as [T3 [T4 [H2 [H3 H4]]]].
    apply (sub_inversion_prod _ _ _ ) in H4.
    destruct H4 as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
    inversion Heq; subst.
    eapply T_Sub. apply H3. apply Hsub2.
Qed.


Inductive bool : Type :=
  | true : bool
  | false : bool.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

(* orbのテスト *)
Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true ) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true ) = true.
Proof. simpl. reflexivity. Qed.

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

Definition nandb (b1: bool) (b2: bool) : bool :=
  match (andb b1 b2) with
  | true => false
  | false => true
  end.

(* nandのテスト *)
Example test_nandb1: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match (andb (andb b1 b2) (andb b2 b3)) with
  | true => true
  | false => false
end.

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.
(* Haskell への エクスポート *)
Require Extraction.
Extraction Language Haskell.
Extraction "../extraction/Haskell/enum.hs" bool negb orb andb nandb andb3.
(**************************)

(* Ocaml への エクスポート *)
Require Extraction.
Extraction Language OCaml.
Extraction "../extraction/Ocaml/enum.ml" bool negb orb andb nandb andb3.
(**************************)

(* JSON への エクスポート *)ls

Require Extraction.
Extraction Language JSON.
Extraction "../extraction/JSON/enum.json" bool negb orb andb nandb andb3.
(**************************)


(* Software Foundations *)
(* Exercise: 4 stars, advanced forall_exists_challenge *)

Require Import Coq.Lists.List.
Import ListNotations.

Fixpoint forallb{X: Type}(p: X -> bool)(l: list X): bool :=
match l with
|[]   => true
|h::t => if (p h) then forallb p t else false
end.

Example forallb_test1: forallb Nat.odd [1;3;5;7;9] = true. Proof. reflexivity. Qed.
Example forallb_test2: forallb negb [false;false] = true. Proof. reflexivity. Qed.
Example forallb_test3: forallb Nat.even [0;2;4;5] = false. Proof. reflexivity. Qed.
Example forallb_test4: forallb (Nat.eqb 5) []= true. Proof. reflexivity. Qed.

Fixpoint existsb{X: Type}(p: X -> bool)(l: list X): bool :=
match l with
|[] => false
|h::t => if p h then true else existsb p t
end.

Example existsb_test1: existsb (Nat.eqb 5) [0;2;3;6] = false. Proof. reflexivity. Qed.
Example existsb_test2: existsb (andb true) [true;true;false] = true. Proof. reflexivity. Qed.
Example existsb_test3: existsb Nat.odd [1;0;0;0;0;3] = true. Proof. reflexivity. Qed.
Example existsb_test4: existsb Nat.even [] = false. Proof. reflexivity. Qed.

Definition existsb'{X: Type}(p: X -> bool)(l: list X): bool := negb (forallb (fun b => negb (p b)) l).

Theorem both_definitions_existsb_same: forall (X: Type)(p: X-> bool)(l: list X),
  existsb p l = existsb' p l.
Proof.
    intros. generalize dependent l. induction l as [|h t].
    compute. reflexivity.
    unfold existsb'. simpl. destruct (p h) eqn: phv.
    simpl. reflexivity.
    simpl. unfold existsb' in IHt. apply IHt.
Qed.