Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Pow2.
Require Import Crypto.Util.ZUtil.Log2.
Require Import Crypto.Util.ZUtil.Lnot.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Hints.ZArith.
Require Import Crypto.Util.ZUtil.ZSimplify.Simple.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.UniquePose.
Local Open Scope bool_scope. Local Open Scope Z_scope.

Module Z.
  Lemma ones_le x y : x <= y -> Z.ones x <= Z.ones y.
  Proof using Type.
    rewrite !Z.ones_equiv; auto with zarith.
  Qed.
#[global]
  Hint Resolve ones_le : zarith.

  Lemma ones_lt_pow2 x y : 0 <= x <= y -> Z.ones x < 2^y.
  Proof using Type.
    rewrite Z.ones_equiv, Z.lt_pred_le.
    auto with zarith.
  Qed.
#[global]
  Hint Resolve ones_lt_pow2 : zarith.

  Lemma log2_ones_full x : Z.log2 (Z.ones x) = Z.max 0 (Z.pred x).
  Proof using Type.
    rewrite Z.ones_equiv, Z.log2_pred_pow2_full; reflexivity.
  Qed.
#[global]
  Hint Rewrite log2_ones_full : zsimplify.

  Lemma log2_ones_lt x y : 0 < x <= y -> Z.log2 (Z.ones x) < y.
  Proof using Type.
    rewrite log2_ones_full; apply Z.max_case_strong; lia.
  Qed.
#[global]
  Hint Resolve log2_ones_lt : zarith.

  Lemma log2_ones_le x y : 0 <= x <= y -> Z.log2 (Z.ones x) <= y.
  Proof using Type.
    rewrite log2_ones_full; apply Z.max_case_strong; lia.
  Qed.
#[global]
  Hint Resolve log2_ones_le : zarith.

  Lemma log2_ones_lt_nonneg x y : 0 < y -> x <= y -> Z.log2 (Z.ones x) < y.
  Proof using Type.
    rewrite log2_ones_full; apply Z.max_case_strong; lia.
  Qed.
#[global]
  Hint Resolve log2_ones_lt_nonneg : zarith.

  Lemma ones_pred : forall i, 0 < i -> Z.ones (Z.pred i) = Z.shiftr (Z.ones i) 1.
  Proof using Type.
    induction i as [|p|p]; [ | | pose proof (Pos2Z.neg_is_neg p) ]; try lia.
    intros.
    unfold Z.ones.
    rewrite !Z.shiftl_1_l, Z.shiftr_div_pow2, <-!Z.sub_1_r, Z.pow_1_r, <-!Z.add_opp_r by lia.
    replace (2 ^ (Z.pos p)) with (2 ^ (Z.pos p - 1)* 2).
    rewrite Z.div_add_l by lia.
    reflexivity.
    change 2 with (2 ^ 1) at 2.
    rewrite <-Z.pow_add_r by (pose proof (Pos2Z.is_pos p); lia).
    f_equal. lia.
  Qed.
#[global]
  Hint Rewrite <- ones_pred using zutil_arith : push_Zshift.

  Lemma ones_succ : forall x, (0 <= x) ->
    Z.ones (Z.succ x) = 2 ^ x + Z.ones x.
  Proof using Type.
    unfold Z.ones; intros.
    rewrite !Z.shiftl_1_l.
    rewrite Z.add_pred_r.
    apply Z.succ_inj.
    rewrite !Z.succ_pred.
    rewrite Z.pow_succ_r; lia.
  Qed.

  Lemma ones_nonneg : forall i, (0 <= i) -> 0 <= Z.ones i.
  Proof using Type.
    apply natlike_ind.
    + unfold Z.ones. simpl; lia.
    + intros.
      rewrite Z.ones_succ by assumption.
      Z.zero_bounds.
  Qed.
#[global]
  Hint Resolve ones_nonneg : zarith.

  Lemma ones_bound m (Hm : 0 <= m) :
    0 <= Z.ones m < 2 ^ m.
  Proof using Type. split. apply ones_nonneg; lia. rewrite Z.ones_equiv; lia. Qed.

  Lemma ones_pos_pos : forall i, (0 < i) -> 0 < Z.ones i.
  Proof using Type.
    intros.
    unfold Z.ones.
    rewrite Z.shiftl_1_l.
    apply Z.lt_succ_lt_pred.
    apply Z.pow_gt_1; lia.
  Qed.
#[global]
  Hint Resolve ones_pos_pos : zarith.

  Lemma lnot_ones_equiv n : Z.lnot (Z.ones n) = -2^n.
  Proof using Type. rewrite Z.ones_equiv, Z.lnot_equiv, <- ?Z.sub_1_r; lia. Qed.

  Lemma land_ones_ones n m
    : Z.land (Z.ones n) (Z.ones m)
      = Z.ones (if ((n <? 0) || (m <? 0))
                then Z.max n m
                else Z.min n m).
  Proof using Type.
    repeat first [ reflexivity
                 | break_innermost_match_step
                 | progress rewrite ?Bool.orb_true_iff in *
                 | progress rewrite ?Bool.orb_false_iff in *
                 | progress rewrite ?Z.ltb_lt, ?Z.ltb_ge in *
                 | progress destruct_head'_and
                 | apply Z.min_case_strong
                 | apply Z.max_case_strong
                 | progress intros
                 | progress destruct_head'_or
                 | rewrite !Z.pow_r_Zneg
                 | rewrite !Z.land_m1_l
                 | rewrite !Z.land_m1_r
                 | progress change (Z.pred 0) with (-1)
                 | rewrite Z.mod_small by lia
                 | match goal with
                   | [ H : ?x < 0 |- _ ] => is_var x; destruct x; try lia
                   | [ H : ?x <= Z.neg _ |- _ ] => is_var x; destruct x; try lia
                   | [ |- context[Z.ones (Z.neg ?x)] ] => rewrite (Z.ones_equiv (Z.neg x))
                   | [ H : ?n <= ?m |- Z.land (Z.ones ?m) (Z.ones ?n) = _ ]
                     => rewrite (Z.land_comm (Z.ones m) (Z.ones n))
                   | [ H : ?n <= ?m |- Z.land (Z.ones ?n) (Z.ones ?m) = _ ]
                     => progress rewrite ?Z.land_ones, ?Z.ones_equiv, <- ?Z.sub_1_r by auto
                   | [ H : ?n <= ?m |- _ ]
                     => is_var n; is_var m; unique pose proof (Z.pow_le_mono_r 2 n m ltac:(lia) H)
                   | [ |- context[2^?x] ] => unique pose proof (Z.pow2_gt_0 x ltac:(lia))
                   end ].
  Qed.
#[global]
  Hint Rewrite land_ones_ones : zsimplify.

  Lemma lor_ones_ones n m
    : Z.lor (Z.ones n) (Z.ones m)
      = Z.ones (if ((n <? 0) || (m <? 0))
                then Z.min n m
                else Z.max n m).
  Proof using Type.
    destruct (Z_zerop n), (Z_zerop m); subst;
      repeat first [ reflexivity
                   | break_innermost_match_step
                   | progress rewrite ?Bool.orb_true_iff in *
                   | progress rewrite ?Bool.orb_false_iff in *
                   | progress rewrite ?Z.ltb_lt, ?Z.ltb_ge in *
                   | progress destruct_head'_and
                   | apply Z.min_case_strong
                   | apply Z.max_case_strong
                   | progress intros
                   | progress destruct_head'_or
                   | rewrite !Z.pow_r_Zneg
                   | rewrite !Z.lor_m1_l
                   | rewrite !Z.lor_m1_r
                   | progress change (Z.pred 0) with (-1)
                   | rewrite Z.mod_small by lia
                   | lia
                   | match goal with
                     | [ H : ?x < 0 |- _ ] => is_var x; destruct x; try lia
                     | [ H : ?x <= Z.neg _ |- _ ] => is_var x; destruct x; try lia
                     | [ |- context[Z.ones (Z.neg ?x)] ] => rewrite (Z.ones_equiv (Z.neg x))
                     | [ H : ?n <= ?m |- Z.lor (Z.ones ?m) (Z.ones ?n) = _ ]
                       => rewrite (Z.lor_comm (Z.ones m) (Z.ones n))
                     | [ H : ?n <= ?m |- Z.lor (Z.ones ?n) (Z.ones ?m) = _ ]
                       => progress rewrite ?Z.lor_ones_low; try apply Z.log2_ones_lt_nonneg; rewrite ?Z.ones_equiv, <- ?Z.sub_1_r
                     | [ H : ?n <= ?m |- _ ]
                       => is_var n; is_var m; unique pose proof (Z.pow_le_mono_r 2 n m ltac:(lia) H)
                     | [ |- context[2^?x] ] => unique pose proof (Z.pow2_gt_0 x ltac:(lia))
                     end ].
  Qed.
#[global]
  Hint Rewrite lor_ones_ones : zsimplify.

  Lemma lor_pow2_mod_pow2_r x e (He : 0 <= e) : Z.lor x (2^e-1) mod (2^e) = 2^e-1.
  Proof using Type.
    destruct (Z_zerop e).
    { subst; autorewrite with zsimplify_const; reflexivity. }
    assert (0 <= x mod 2^e < 2^e) by auto with zarith.
    assert (0 <= x mod 2^e <= 2^e-1) by lia.
    assert (Z.log2 (x mod 2^e) <= Z.log2 (2^e-1)) by (apply Z.log2_le_mono; lia).
    assert (Z.log2 (x mod 2^e) < e) by (rewrite Z.sub_1_r, Z.log2_pred_pow2 in * by lia; lia).
    rewrite <- Z.land_ones, Z.land_lor_distr_l by assumption.
    rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.land_ones_ones, Z.min_id, Z.max_id, Bool.if_const.
    rewrite Z.land_ones by assumption.
    rewrite Z.lor_ones_low; auto with zarith.
  Qed.
#[global]
  Hint Rewrite lor_pow2_mod_pow2_r using zutil_arith : zsimplify.
#[global]
  Hint Rewrite lor_pow2_mod_pow2_r using assumption : zsimplify_fast.

  Lemma lor_pow2_mod_pow2_l x e (He : 0 <= e) : Z.lor (2^e-1) x mod (2^e) = 2^e-1.
  Proof using Type. rewrite Z.lor_comm; apply lor_pow2_mod_pow2_r; assumption. Qed.
#[global]
  Hint Rewrite lor_pow2_mod_pow2_l using zutil_arith : zsimplify.
#[global]
  Hint Rewrite lor_pow2_mod_pow2_l using assumption : zsimplify_fast.

  Lemma lor_pow2_div_pow2_r x e (He : 0 <= e) : (Z.lor x (2^e-1)) / (2^e) = x / 2^e.
  Proof using Type.
    destruct (Z_zerop e).
    { subst; autorewrite with zsimplify_const; reflexivity. }
    assert (0 < 2^e) by auto with zarith.
    rewrite <- Z.shiftr_div_pow2, Z.shiftr_lor, !Z.shiftr_div_pow2 by lia.
    rewrite (Z.div_small (_-1) _), Z.lor_0_r by lia.
    reflexivity.
  Qed.
#[global]
  Hint Rewrite lor_pow2_div_pow2_r using zutil_arith : zsimplify.
#[global]
  Hint Rewrite lor_pow2_div_pow2_r using assumption : zsimplify_fast.

  Lemma lor_pow2_div_pow2_l x e (He : 0 <= e) : (Z.lor (2^e-1) x) / (2^e) = x / 2^e.
  Proof using Type. rewrite Z.lor_comm; apply lor_pow2_div_pow2_r; assumption. Qed.
#[global]
  Hint Rewrite lor_pow2_div_pow2_l using zutil_arith : zsimplify.
#[global]
  Hint Rewrite lor_pow2_div_pow2_l using assumption : zsimplify_fast.

  Lemma land_ones_low_alt a n : 0 <= a < 2^n -> Z.land a (Z.ones n) = a.
  Proof using Type.
    destruct (Z_zerop a); subst; [ intros; now rewrite Z.land_0_l | ].
    intros; apply Z.land_ones_low; try lia; apply Z.log2_lt_pow2; try lia.
  Qed.
#[global]
  Hint Rewrite land_ones_low_alt using zutil_arith : zsimplify.
#[global]
  Hint Rewrite land_ones_low_alt using (idtac + split); assumption : zsimplify_fast.

  Lemma land_ones_low_alt_ones a n : 0 <= a <= Z.ones n -> Z.land a (Z.ones n) = a.
  Proof using Type. rewrite Z.ones_equiv at 1; intro H; rewrite land_ones_low_alt; lia. Qed.
#[global]
  Hint Rewrite land_ones_low_alt_ones using zutil_arith : zsimplify.
#[global]
  Hint Rewrite land_ones_low_alt_ones using (idtac + split); assumption : zsimplify_fast.

  Lemma shiftr_ones_sub n m : 0 <= m <= n -> Z.shiftr (Z.ones n) m = Z.ones (n - m).
  Proof using Type. intro; now rewrite Z.shiftr_div_pow2, Z.ones_div_pow2 by lia. Qed.
#[global]
  Hint Rewrite shiftr_ones_sub using zutil_arith : zsimplify.
#[global]
  Hint Rewrite shiftr_ones_sub using (idtac + split); assumption : zsimplify_fast.

  Lemma shiftr_ones_same n : 0 <= n -> Z.shiftr (Z.ones n) n = 0.
  Proof using Type. intro; rewrite shiftr_ones_sub, Z.sub_diag by lia; reflexivity. Qed.
#[global]
  Hint Rewrite shiftr_ones_same using zutil_arith : zsimplify.
#[global]
  Hint Rewrite shiftr_ones_same using assumption : zsimplify_fast.
End Z.


Require Import Coq.omega.Omega.

(** 1. Simple things *)
Lemma N_S_bij: forall a b: nat, a = b <-> S a = S b.
Proof. split; omega. Defined.
Lemma N_nonzero__pos: forall a: nat, a <> 0 <-> a > 0.
Proof. split; omega. Defined.
Lemma N_lt__gt: forall a b: nat, a < b <-> b > a.
Proof. split; omega. Defined.
Lemma N_le__ge: forall a b: nat, a <= b <-> b >= a.
Proof. split; omega. Defined.
Lemma N_minus_zero: forall a: nat, a - 0 = a.
Proof. intros; omega. Defined.
Lemma N_minus_itself: forall a: nat, a - a = 0.
Proof. intros; omega. Defined.
Lemma N_gt_max: forall n a b: nat, n > Init.Nat.max a b -> n > a /\ n > b.
  induction n. intros. inversion H.
  destruct a; destruct b; try (intros; simpl; omega); simpl; try omega.
  assert (forall p q: nat, S p > S q <-> p > q) by (intros; omega).
  repeat rewrite H. apply IHn.
Defined.

(** 2. Trichotomy-like *)
Lemma N_eq_dec: forall a b: nat, a = b \/ a <> b.
Proof. intros; omega. Defined.
Lemma N_trichotomy_ne: forall a b: nat, a <> b <-> a < b \/ a > b.
Proof. intros; omega. Defined.
Lemma N_trichotomy: forall a b: nat, a < b \/ a = b \/ a > b.
Proof. intros; omega. Defined.
Lemma N_le__lt_eq: forall a b: nat, a <= b <-> a < b \/ a = b.
Proof. intros; omega. Defined.
Lemma N_lt__le_ne: forall a b: nat, a < b <-> a <= b /\ a <> b.
Proof. intros; omega. Defined.
Lemma N_nle__gt: forall a b: nat, ~ a <= b <-> a > b.
Proof. intros; omega. Defined.
Lemma N_nlt__ge: forall a b: nat, ~ a < b <-> a >= b.
Proof. intros; omega. Defined.
Lemma N_eq__le_ge: forall a b: nat, a = b <-> a <= b /\ a >= b.
Proof. intros; omega. Defined.

(** 3. Iff-conditions of inequalities *)
Lemma N_leb_true__le: forall a b: nat, (a <=? b) = true <-> a <= b.
Proof. apply Nat.leb_le. Defined.
Lemma N_ltb_true__lt: forall a b: nat, (a <? b) = true <-> a < b.
Proof. apply Nat.ltb_lt. Defined.
Lemma N_eqb_true__eq: forall a b: nat, (a =? b) = true <-> a = b.
Proof. apply Nat.eqb_eq. Defined.
Lemma N_leb_false__gt: forall a b: nat, (a <=? b) = false <-> a > b.
Proof.
  induction a; intro b; destruct b; simpl;
  split; intro; try easy; try omega.
  apply IHa in H; omega.
  rewrite IHa. omega.
Defined.
Lemma N_ltb_false__ge: forall a b: nat, (a <? b) = false <-> a >= b.
Proof.
  induction a; intro b; destruct b; simpl;
  split; intro; try easy; try omega.
  apply IHa in H; omega.
  unfold Nat.ltb; rewrite N_leb_false__gt; unfold gt, lt; omega.
Defined.
Lemma N_eqb_false__ne: forall a b: nat, (a =? b) = false <-> a <> b.
Proof. apply beq_nat_false_iff. Defined.
Lemma N_gt__pos_minus: forall a b: nat, a > b <-> a - b > 0.
Proof. intros; omega. Defined.
Lemma N_le__zero_minus: forall a b: nat, a <= b <-> a - b = 0.
Proof. intros; omega. Defined.

Ltac zero := simpl; repeat rewrite <- mult_n_O; repeat rewrite <- plus_n_O; repeat rewrite N_minus_zero; repeat rewrite N_minus_itself; try reflexivity.
Ltac zero_in H := simpl in H; repeat rewrite <- mult_n_O in H; repeat rewrite <- plus_n_O in H; repeat rewrite N_minus_zero in H; repeat rewrite N_minus_itself in H; try reflexivity.

Ltac one:= repeat rewrite mult_1_r.
Ltac one_in H:= repeat rewrite mult_1_r in H.

(** 4. Consistencies of inequalities *)
(* Use left operations *)
Lemma N_plus_minus: forall a b: nat, a + b - b = a.
Proof. intros; omega. Defined.
Lemma N_minus_plus: forall a b: nat, a >= b -> a - b + b = a.
Proof. intros; omega. Defined.
Lemma N_minus_distr: forall a b c: nat, a - b - c = a - (b + c).
Proof. intros; omega. Defined.
Lemma N_plus_minus_diff: forall a b c: nat, b >= c -> a + b - c = a + (b - c).
Proof. intros; omega. Defined.
Lemma N_minus_plus_distr: forall a b c: nat, a >= b -> b >= c -> a - b + c = a - (b - c).
Proof. intros. omega. Defined.
Lemma N_plus_minus_distr: forall a b c: nat, a + c >= b -> b >= c -> a + c - b = a - (b - c).
Proof. intros; omega. Defined.
Lemma N_cons_eq_plus: forall a b c: nat, b = c <-> a + b = a + c.
Proof. intros; omega. Defined.
Lemma N_cons_lt_plus: forall a b c: nat, b < c <-> a + b < a + c.
Proof. intros; omega. Defined.
Lemma N_cons_le_plus: forall a b c: nat, b <= c <-> a + b <= a + c.
Proof. intros; omega. Defined.
Lemma N_cons_eq_mult_pos: forall a b c: nat, a > 0 -> b = c <-> a * b = a * c.
Proof.
  destruct a. intros; easy. intros b c H. clear H.
  generalize dependent c. generalize dependent b. induction a.
  - intros. omega.
  - induction b. simpl. destruct c.
    + zero.
    + split; zero; intros; inversion H.
    + split. intros; rewrite H; reflexivity.
      destruct c. intros. rewrite <- mult_n_O in H. inversion H.
      assert (forall n: nat, S n = 1 + n) by reflexivity.
      rewrite (H b), (H c). repeat rewrite mult_plus_distr_l.
      repeat rewrite <- N_cons_eq_plus. apply IHb.
Defined.
Lemma N_cons_lt_mult_pos: forall a b c: nat, a > 0 -> b < c <-> a * b < a * c.
Proof.
  destruct a. intros; easy. intros b c H. clear H.
  generalize dependent c. generalize dependent b. induction a.
  - intros. omega.
  - induction b. simpl. destruct c.
    + zero.
    + split; zero; intros; apply gt_Sn_O.
    + split. intros. pose proof H as N.
      rewrite N_lt__le_ne in H. destruct H. clear H0.
      pose proof ((N_minus_plus c (S b)) H) as F. rewrite <- F.
      rewrite mult_plus_distr_l, plus_comm.
      remember (S (S a) * S b + S (S a) * (c - S b)) as f.
      assert (S (S a) * S b = S (S a) * S b + 0) by omega.
      rewrite H0; clear H0. rewrite Heqf; clear Heqf.
      rewrite <- N_cons_lt_plus. rewrite N_lt__gt, N_gt__pos_minus in N.
      remember (c - S b) as g. destruct g. easy. apply gt_Sn_O.
      destruct c. zero. intros. inversion H.
      assert (forall n: nat, S n = 1 + n) by reflexivity.
      rewrite (H b), (H c). repeat rewrite mult_plus_distr_l.
      repeat rewrite <- N_cons_lt_plus. apply IHb.
Defined.
Lemma N_cons_le_mult_pos: forall a b c: nat, a > 0 -> b <= c <-> a * b <= a * c.
Proof.
  destruct a. intros; easy. intros b c H.
  repeat rewrite N_le__lt_eq.
  rewrite (N_cons_lt_mult_pos (S a) b c).
  rewrite (N_cons_eq_mult_pos (S a) b c).
  reflexivity. apply H. apply H.
Defined.
Lemma N_rearrange: forall a b c d: nat, a < b -> c < d -> a * d + b * c < a * c + b * d.
Proof.
  induction b.
  - intros. inversion H.
  - simpl in IHb. simpl. intros. simpl.
    destruct b. inversion H. omega. inversion H2.
    assert (S (S b) - a > 0). { omega. }
    repeat rewrite (mult_comm (S b)).
    assert ((S (S b) - a) + a = S (S b)) by (apply N_minus_plus; omega).
    assert (forall n: nat, n + n * (S b) = n * S (S b)).
    { intros. assert (S (S b) = 1 + S b) by reflexivity. rewrite H3, mult_plus_distr_l. omega. }
    repeat rewrite H3. rewrite <- H2. repeat rewrite mult_plus_distr_l.
    rewrite (plus_comm _ (c * a)), (plus_comm _ (d * a)).
    repeat rewrite plus_assoc. rewrite (mult_comm d a), (mult_comm a c), (plus_comm (a * d) (c * a)),
    <- N_cons_lt_plus. repeat rewrite (mult_comm _ (S (S b) - a)). apply N_cons_lt_mult_pos.
    apply H1. apply H0.
Defined.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : Lst) : Lst
           := match rev_arg0 with
              | nil => nil
              | cons x y => append (rev y) (cons x nil)
              end.

Lemma lem : forall (x : Lst) (y : Nat), eq (rev (append x (cons y nil))) (cons y (rev x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : Lst) (y : Lst) (z : Nat), eq (rev (append x (append y (cons z nil)))) (cons z (rev (append x y))).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. simpl. apply lem.
Qed.


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

Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.

(** * Euclidean Division for integers (Floor convention)

    We use here the convention known as Floor, or Round-Toward-Bottom,
    where [a/b] is the closest integer below the exact fraction.
    It can be summarized by:

    [a = bq+r /\ 0 <= |r| < |b| /\ Sign(r) = Sign(b)]

    This is the convention followed historically by [Zdiv] in Coq, and
    corresponds to convention "F" in the following paper:

    R. Boute, "The Euclidean definition of the functions div and mod",
    ACM Transactions on Programming Languages and Systems,
    Vol. 14, No.2, pp. 127-144, April 1992.

    See files [ZDivTrunc] and [ZDivEucl] for others conventions.
*)

Module Type ZDivProp
 (Import A : ZAxiomsSig')
 (Import B : ZMulOrderProp A)
 (Import C : ZSgnAbsProp A B).

(** We benefit from what already exists for NZ *)
Module Import NZDivP := Nop <+ NZDivProp A A B.

(** Another formulation of the main equation *)

Lemma mod_eq :
 forall a b, b~=0 -> a mod b == a - b*(a/b).
Proof.
intros.
rewrite <- add_move_l.
symmetry. now apply div_mod.
Qed.

(** We have a general bound for absolute values *)

Lemma mod_bound_abs :
 forall a b, b~=0 -> abs (a mod b) < abs b.
Proof.
intros.
destruct (abs_spec b) as [(LE,EQ)|(LE,EQ)]; rewrite EQ.
destruct (mod_pos_bound a b). order. now rewrite abs_eq.
destruct (mod_neg_bound a b). order. rewrite abs_neq; trivial.
now rewrite <- opp_lt_mono.
Qed.

(** Uniqueness theorems *)

Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
  (0<=r1<b \/ b<r1<=0) -> (0<=r2<b \/ b<r2<=0) ->
  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof.
intros b q1 q2 r1 r2 Hr1 Hr2 EQ.
destruct Hr1; destruct Hr2; try (intuition; order).
apply div_mod_unique with b; trivial.
rewrite <- (opp_inj_wd r1 r2).
apply div_mod_unique with (-b); trivial.
rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
now rewrite 2 mul_opp_l, <- 2 opp_add_distr, opp_inj_wd.
Qed.

Theorem div_unique:
 forall a b q r, (0<=r<b \/ b<r<=0) -> a == b*q + r -> q == a/b.
Proof.
intros a b q r Hr EQ.
assert (Hb : b~=0) by (destruct Hr; intuition; order).
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound];
 intuition order.
now rewrite <- div_mod.
Qed.

Theorem div_unique_pos:
 forall a b q r, 0<=r<b -> a == b*q + r -> q == a/b.
Proof. intros; apply div_unique with r; auto. Qed.

Theorem div_unique_neg:
 forall a b q r, 0<=r<b -> a == b*q + r -> q == a/b.
Proof. intros; apply div_unique with r; auto. Qed.

Theorem mod_unique:
 forall a b q r, (0<=r<b \/ b<r<=0) -> a == b*q + r -> r == a mod b.
Proof.
intros a b q r Hr EQ.
assert (Hb : b~=0) by (destruct Hr; intuition; order).
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
destruct Hr; [left; apply mod_pos_bound|right; apply mod_neg_bound];
 intuition order.
now rewrite <- div_mod.
Qed.

Theorem mod_unique_pos:
 forall a b q r, 0<=r<b -> a == b*q + r -> r == a mod b.
Proof. intros; apply mod_unique with q; auto. Qed.

Theorem mod_unique_neg:
 forall a b q r, b<r<=0 -> a == b*q + r -> r == a mod b.
Proof. intros; apply mod_unique with q; auto. Qed.

(** Sign rules *)

Ltac pos_or_neg a :=
 let LT := fresh "LT" in
 let LE := fresh "LE" in
 destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT].

Fact mod_bound_or : forall a b, b~=0 -> 0<=a mod b<b \/ b<a mod b<=0.
Proof.
intros.
destruct (lt_ge_cases 0 b); [left|right].
 apply mod_pos_bound; trivial. apply mod_neg_bound; order.
Qed.

Fact opp_mod_bound_or : forall a b, b~=0 ->
 0 <= -(a mod b) < -b \/ -b < -(a mod b) <= 0.
Proof.
intros.
destruct (lt_ge_cases 0 b); [right|left].
rewrite <- opp_lt_mono, opp_nonpos_nonneg.
 destruct (mod_pos_bound a b); intuition; order.
rewrite <- opp_lt_mono, opp_nonneg_nonpos.
 destruct (mod_neg_bound a b); intuition; order.
Qed.

Lemma div_opp_opp : forall a b, b~=0 -> -a/-b == a/b.
Proof.
intros. symmetry. apply div_unique with (- (a mod b)).
now apply opp_mod_bound_or.
rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order.
Qed.

Lemma mod_opp_opp : forall a b, b~=0 -> (-a) mod (-b) == - (a mod b).
Proof.
intros. symmetry. apply mod_unique with (a/b).
now apply opp_mod_bound_or.
rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order.
Qed.

(** With the current conventions, the other sign rules are rather complex. *)

Lemma div_opp_l_z :
 forall a b, b~=0 -> a mod b == 0 -> (-a)/b == -(a/b).
Proof.
intros a b Hb H. symmetry. apply div_unique with 0.
destruct (lt_ge_cases 0 b); [left|right]; intuition; order.
rewrite <- opp_0, <- H.
rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order.
Qed.

Lemma div_opp_l_nz :
 forall a b, b~=0 -> a mod b ~= 0 -> (-a)/b == -(a/b)-1.
Proof.
intros a b Hb H. symmetry. apply div_unique with (b - a mod b).
destruct (lt_ge_cases 0 b); [left|right].
rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l.
destruct (mod_pos_bound a b); intuition; order.
rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l.
destruct (mod_neg_bound a b); intuition; order.
rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l.
rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order.
Qed.

Lemma mod_opp_l_z :
 forall a b, b~=0 -> a mod b == 0 -> (-a) mod b == 0.
Proof.
intros a b Hb H. symmetry. apply mod_unique with (-(a/b)).
destruct (lt_ge_cases 0 b); [left|right]; intuition; order.
rewrite <- opp_0, <- H.
rewrite mul_opp_r, <- opp_add_distr, <- div_mod; order.
Qed.

Lemma mod_opp_l_nz :
 forall a b, b~=0 -> a mod b ~= 0 -> (-a) mod b == b - a mod b.
Proof.
intros a b Hb H. symmetry. apply mod_unique with (-(a/b)-1).
destruct (lt_ge_cases 0 b); [left|right].
rewrite le_0_sub. rewrite <- (sub_0_r b) at 5. rewrite <- sub_lt_mono_l.
destruct (mod_pos_bound a b); intuition; order.
rewrite le_sub_0. rewrite <- (sub_0_r b) at 1. rewrite <- sub_lt_mono_l.
destruct (mod_neg_bound a b); intuition; order.
rewrite <- (add_opp_r b), mul_sub_distr_l, mul_1_r, sub_add_simpl_r_l.
rewrite mul_opp_r, <-opp_add_distr, <-div_mod; order.
Qed.

Lemma div_opp_r_z :
 forall a b, b~=0 -> a mod b == 0 -> a/(-b) == -(a/b).
Proof.
intros. rewrite <- (opp_involutive a) at 1.
rewrite div_opp_opp; auto using div_opp_l_z.
Qed.

Lemma div_opp_r_nz :
 forall a b, b~=0 -> a mod b ~= 0 -> a/(-b) == -(a/b)-1.
Proof.
intros. rewrite <- (opp_involutive a) at 1.
rewrite div_opp_opp; auto using div_opp_l_nz.
Qed.

Lemma mod_opp_r_z :
 forall a b, b~=0 -> a mod b == 0 -> a mod (-b) == 0.
Proof.
intros. rewrite <- (opp_involutive a) at 1.
now rewrite mod_opp_opp, mod_opp_l_z, opp_0.
Qed.

Lemma mod_opp_r_nz :
 forall a b, b~=0 -> a mod b ~= 0 -> a mod (-b) == (a mod b) - b.
Proof.
intros. rewrite <- (opp_involutive a) at 1.
rewrite mod_opp_opp, mod_opp_l_nz by trivial.
now rewrite opp_sub_distr, add_comm, add_opp_r.
Qed.

(** The sign of [a mod b] is the one of [b] (when it isn't null) *)

Lemma mod_sign_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 sgn (a mod b) == sgn b.
Proof.
intros a b Hb H. destruct (lt_ge_cases 0 b) as [Hb'|Hb'].
destruct (mod_pos_bound a b Hb'). rewrite 2 sgn_pos; order.
destruct (mod_neg_bound a b). order. rewrite 2 sgn_neg; order.
Qed.

Lemma mod_sign : forall a b, b~=0 -> sgn (a mod b) ~= -sgn b.
Proof.
intros a b Hb H.
destruct (eq_decidable (a mod b) 0) as [EQ|NEQ].
apply Hb, sgn_null_iff, opp_inj. now rewrite <- H, opp_0, EQ, sgn_0.
apply Hb, sgn_null_iff. apply eq_mul_0_l with 2; try order'. nzsimpl'.
apply add_move_0_l. rewrite <- H. symmetry. now apply mod_sign_nz.
Qed.

Lemma mod_sign_mul : forall a b, b~=0 -> 0 <= (a mod b) * b.
Proof.
intros. destruct (lt_ge_cases 0 b).
apply mul_nonneg_nonneg; destruct (mod_pos_bound a b); order.
apply mul_nonpos_nonpos; destruct (mod_neg_bound a b); order.
Qed.

(** A division by itself returns 1 *)

Lemma div_same : forall a, a~=0 -> a/a == 1.
Proof.
intros. pos_or_neg a. apply div_same; order.
rewrite <- div_opp_opp by trivial. now apply div_same.
Qed.

Lemma mod_same : forall a, a~=0 -> a mod a == 0.
Proof.
intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag.
Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
Proof. exact div_small. Qed.

(** Same situation, in term of modulo: *)

Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
Proof. exact mod_small. Qed.

(** * Basic values of divisions and modulo. *)

Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
Proof.
intros. pos_or_neg a. apply div_0_l; order.
rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l.
Qed.

Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
Proof.
intros; rewrite mod_eq, div_0_l; now nzsimpl.
Qed.

Lemma div_1_r: forall a, a/1 == a.
Proof.
intros. symmetry. apply div_unique with 0. left. split; order || apply lt_0_1.
now nzsimpl.
Qed.

Lemma mod_1_r: forall a, a mod 1 == 0.
Proof.
intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag.
intro EQ; symmetry in EQ; revert EQ; apply lt_neq; apply lt_0_1.
Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof. exact div_1_l. Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof. exact mod_1_l. Qed.

Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
Proof.
intros. symmetry. apply div_unique with 0.
destruct (lt_ge_cases 0 b); [left|right]; split; order.
nzsimpl; apply mul_comm.
Qed.

Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
Proof.
intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
Qed.

(** * Order results about mod and div *)

(** A modulo cannot grow beyond its starting point. *)

Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a.
Proof. exact mod_le. Qed.

Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b.
Proof. exact div_pos. Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof. exact div_str_pos. Qed.

Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a<b \/ b<a<=0).
Proof.
intros a b Hb.
split.
intros EQ.
rewrite (div_mod a b Hb), EQ; nzsimpl.
now apply mod_bound_or.
destruct 1. now apply div_small.
rewrite <- div_opp_opp by trivial. apply div_small; trivial.
rewrite <- opp_lt_mono, opp_nonneg_nonpos; tauto.
Qed.

Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<b \/ b<a<=0).
Proof.
intros.
rewrite <- div_small_iff, mod_eq by trivial.
rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l.
rewrite eq_sym_iff, eq_mul_0. tauto.
Qed.

(** As soon as the divisor is strictly greater than 1,
    the division is strictly decreasing. *)

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof. exact div_lt. Qed.

(** [le] is compatible with a positive division. *)

Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c.
Proof.
intros a b c Hc Hab.
rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
 [|rewrite EQ; order].
rewrite <- lt_succ_r.
rewrite (mul_lt_mono_pos_l c) by order.
nzsimpl.
rewrite (add_lt_mono_r _ _ (a mod c)).
rewrite <- div_mod by order.
apply lt_le_trans with b; trivial.
rewrite (div_mod b c) at 1 by order.
rewrite <- add_assoc, <- add_le_mono_l.
apply le_trans with (c+0).
nzsimpl; destruct (mod_pos_bound b c); order.
rewrite <- add_le_mono_l. destruct (mod_pos_bound a c); order.
Qed.

(** In this convention, [div] performs Rounding-Toward-Bottom.

    Since we cannot speak of rational values here, we express this
    fact by multiplying back by [b], and this leads to separates
    statements according to the sign of [b].

    First, [a/b] is below the exact fraction ...
*)

Lemma mul_div_le : forall a b, 0<b -> b*(a/b) <= a.
Proof.
intros.
rewrite (div_mod a b) at 2; try order.
rewrite <- (add_0_r (b*(a/b))) at 1.
rewrite <- add_le_mono_l.
now destruct (mod_pos_bound a b).
Qed.

Lemma mul_div_ge : forall a b, b<0 -> a <= b*(a/b).
Proof.
intros. rewrite <- div_opp_opp, opp_le_mono, <-mul_opp_l by order.
apply mul_div_le. now rewrite opp_pos_neg.
Qed.

(** ... and moreover it is the larger such integer, since [S(a/b)]
    is strictly above the exact fraction.
*)

Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)).
Proof.
intros.
nzsimpl.
rewrite (div_mod a b) at 1; try order.
rewrite <- add_lt_mono_l.
destruct (mod_pos_bound a b); order.
Qed.

Lemma mul_succ_div_lt: forall a b, b<0 -> b*(S (a/b)) < a.
Proof.
intros. rewrite <- div_opp_opp, opp_lt_mono, <-mul_opp_l by order.
apply mul_succ_div_gt. now rewrite opp_pos_neg.
Qed.

(** NB: The four previous properties could be used as
    specifications for [div]. *)

(** Inequality [mul_div_le] is exact iff the modulo is zero. *)

Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
Proof.
intros.
rewrite (div_mod a b) at 1; try order.
rewrite <- (add_0_r (b*(a/b))) at 2.
apply add_cancel_l.
Qed.

(** Some additionnal inequalities about div. *)

Theorem div_lt_upper_bound:
  forall a b q, 0<b -> a < b*q -> a/b < q.
Proof.
intros.
rewrite (mul_lt_mono_pos_l b) by trivial.
apply le_lt_trans with a; trivial.
now apply mul_div_le.
Qed.

Theorem div_le_upper_bound:
  forall a b q, 0<b -> a <= b*q -> a/b <= q.
Proof.
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

Theorem div_le_lower_bound:
  forall a b q, 0<b -> b*q <= a -> q <= a/b.
Proof.
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

(** A division respects opposite monotonicity for the divisor *)

Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q.
Proof. exact div_le_compat_l. Qed.

(** * Relations between usual operations and mod and div *)

Lemma mod_add : forall a b c, c~=0 ->
 (a + b * c) mod c == a mod c.
Proof.
intros.
symmetry.
apply mod_unique with (a/c+b); trivial.
now apply mod_bound_or.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add : forall a b c, c~=0 ->
 (a + b * c) / c == a / c + b.
Proof.
intros.
apply (mul_cancel_l _ _ c); try order.
apply (add_cancel_r _ _ ((a+b*c) mod c)).
rewrite <- div_mod, mod_add by order.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add_l: forall a b c, b~=0 ->
 (a * b + c) / b == a + c / b.
Proof.
 intros a b c. rewrite (add_comm _ c), (add_comm a).
 now apply div_add.
Qed.

(** Cancellations. *)

Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 ->
 (a*c)/(b*c) == a/b.
Proof.
intros.
symmetry.
apply div_unique with ((a mod b)*c).
(* ineqs *)
destruct (lt_ge_cases 0 c).
rewrite <-(mul_0_l c), <-2mul_lt_mono_pos_r, <-2mul_le_mono_pos_r by trivial.
now apply mod_bound_or.
rewrite <-(mul_0_l c), <-2mul_lt_mono_neg_r, <-2mul_le_mono_neg_r by order.
destruct (mod_bound_or a b); tauto.
(* equation *)
rewrite (div_mod a b) at 1 by order.
rewrite mul_add_distr_r.
rewrite add_cancel_r.
rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
Qed.

Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 ->
 (c*a)/(c*b) == a/b.
Proof.
intros. rewrite !(mul_comm c); now apply div_mul_cancel_r.
Qed.

Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 ->
  (c*a) mod (c*b) == c * (a mod b).
Proof.
intros.
rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
rewrite <- div_mod.
rewrite div_mul_cancel_l by trivial.
rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
apply div_mod; order.
rewrite <- neq_mul_0; auto.
Qed.

Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 ->
  (a*c) mod (b*c) == (a mod b) * c.
Proof.
 intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
Qed.

(** Operations modulo. *)

Theorem mod_mod: forall a n, n~=0 ->
 (a mod n) mod n == a mod n.
Proof.
intros. rewrite mod_small_iff by trivial.
now apply mod_bound_or.
Qed.

Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)*b) mod n == (a*b) mod n.
Proof.
 intros a b n Hn. symmetry.
 rewrite (div_mod a n) at 1 by order.
 rewrite add_comm, (mul_comm n), (mul_comm _ b).
 rewrite mul_add_distr_l, mul_assoc.
 intros. rewrite mod_add by trivial.
 now rewrite mul_comm.
Qed.

Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
 (a*(b mod n)) mod n == (a*b) mod n.
Proof.
 intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l.
Qed.

Theorem mul_mod: forall a b n, n~=0 ->
 (a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof.
 intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r.
Qed.

Lemma add_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)+b) mod n == (a+b) mod n.
Proof.
 intros a b n Hn. symmetry.
 rewrite (div_mod a n) at 1 by order.
 rewrite <- add_assoc, add_comm, mul_comm.
 intros. now rewrite mod_add.
Qed.

Lemma add_mod_idemp_r : forall a b n, n~=0 ->
 (a+(b mod n)) mod n == (a+b) mod n.
Proof.
 intros. rewrite !(add_comm a). now apply add_mod_idemp_l.
Qed.

Theorem add_mod: forall a b n, n~=0 ->
 (a+b) mod n == (a mod n + b mod n) mod n.
Proof.
 intros. now rewrite add_mod_idemp_l, add_mod_idemp_r.
Qed.

(** With the current convention, the following result isn't always
    true with a negative last divisor. For instance
    [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ], or
    [ 5/2/(-2) = -1 <> -2 = 5 / (2*-2) ]. *)

Lemma div_div : forall a b c, b~=0 -> 0<c ->
 (a/b)/c == a/(b*c).
Proof.
 intros a b c Hb Hc.
 apply div_unique with (b*((a/b) mod c) + a mod b).
 (* begin 0<= ... <b*c \/ ... *)
 apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb].
 right.
 destruct (mod_pos_bound (a/b) c), (mod_neg_bound a b); trivial.
 split.
 apply le_lt_trans with (b*((a/b) mod c) + b).
 now rewrite <- mul_succ_r, <- mul_le_mono_neg_l, le_succ_l.
 now rewrite <- add_lt_mono_l.
 apply add_nonpos_nonpos; trivial.
 apply mul_nonpos_nonneg; order.
 left.
 destruct (mod_pos_bound (a/b) c), (mod_pos_bound a b); trivial.
 split.
 apply add_nonneg_nonneg; trivial.
 apply mul_nonneg_nonneg; order.
 apply lt_le_trans with (b*((a/b) mod c) + b).
 now rewrite <- add_lt_mono_l.
 now rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l.
 (* end 0<= ... < b*c \/ ... *)
 rewrite (div_mod a b) at 1 by order.
 rewrite add_assoc, add_cancel_r.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
Qed.

(** Similarly, the following result doesn't always hold when [c<0].
    For instance [3 mod (-2*-2)) = 3] while
    [3 mod (-2) + (-2)*((3/-2) mod -2) = -1].
*)

Lemma rem_mul_r : forall a b c, b~=0 -> 0<c ->
 a mod (b*c) == a mod b + b*((a/b) mod c).
Proof.
 intros a b c Hb Hc.
 apply add_cancel_l with (b*c*(a/(b*c))).
 rewrite <- div_mod by (apply neq_mul_0; split; order).
 rewrite <- div_div by trivial.
 rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
 rewrite <- div_mod by order.
 apply div_mod; order.
Qed.

(** A last inequality: *)

Theorem div_mul_le:
 forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof. exact div_mul_le. Qed.

End ZDivProp.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path.
From mathcomp Require Import div fintype tuple finfun bigop.
Require Import Reals Fourier.
Require Import ssrR Reals_ext Ranalysis_ext logb.

(** * The "natural entropy function" *)

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

(** We first find the maximum of the "natural entropy function"
    (the same the binary entropy function except that we replace
    the logarithm in base 2 by its natural version). *)

Definition H2ln := fun p => - p * ln p - (1 - p) * ln (1 - p).

Lemma derivable_pt_ln_Rminus x : x < 1 -> derivable_pt ln (1 - x).
Proof.
move=> Hx.
exists (/ (1 - x)).
apply derivable_pt_lim_ln, subR_gt0.
assumption.
Defined.

Lemma pderivable_H2ln : pderivable H2ln (fun x => 0 < x <= 1/2).
Proof.
move=> x /= [Hx0 Hx1].
apply derivable_pt_minus.
apply derivable_pt_mult.
apply derivable_pt_Ropp.
apply derivable_pt_ln.
assumption.
apply derivable_pt_mult.
apply derivable_pt_Rminus.
apply derivable_pt_comp.
apply derivable_pt_Rminus.
apply derivable_pt_ln_Rminus.
fourier.
Defined.

(* NB: on peut pas utiliser derivable_pt_Ropp2? *)
Lemma pderivable_Ropp_H2ln : pderivable (fun x => - H2ln x) (fun x => 1/2 <= x < 1).
Proof.
rewrite /H2ln /pderivable => x [Hx0 Hx1].
apply derivable_pt_comp.
apply derivable_pt_minus.
apply derivable_pt_mult.
apply derivable_pt_Ropp.
apply derivable_pt_ln.
fourier.
apply derivable_pt_mult.
apply derivable_pt_Rminus.
apply derivable_pt_comp.
apply derivable_pt_Rminus.
apply derivable_pt_ln_Rminus.
assumption.
apply derivable_pt_Ropp.
Defined.

Lemma increasing_on_0_to_half : forall x y,
  0 < x <= 1/2 -> 0 < y <= 1/2 -> x <= y -> H2ln x <= H2ln y.
Proof.
apply derive_increasing_interv_left with (pr := pderivable_H2ln); first by fourier.
move=> t [Ht1 Ht2].
rewrite /H2ln /pderivable_H2ln derive_pt_minus 2!derive_pt_mult /=.
destruct (Rlt_le_dec 0 t) => /=; last first.
  suff : False by done.
  fourier.
rewrite derive_pt_comp /= mulRA.
apply (@leR_trans (- ln t + ln (1 - t))); last first.
  apply Req_le; field.
  split=> ?; fourier.
rewrite -ln_Rinv // -ln_mult; last 2 first.
  exact/invR_gt0.
  fourier.
rewrite -ln_1.
apply ln_increasing_le.
fourier.
apply (@leR_pmul2l t) => //.
rewrite mulRA mulRV; last exact/eqP/gtR_eqF.
rewrite mulR1 mul1R; fourier.
Qed.

Lemma decreasing_on_half_to_1 : forall x y : R,
  1/2 <= x < 1 -> 1/2 <= y < 1 -> x <= y -> H2ln y <= H2ln x.
Proof.
move=> x y Hx Hy xy.
rewrite -[X in _ <= X]oppRK leR_oppr.
move: x y Hx Hy xy.
apply derive_increasing_interv_right with (pr := pderivable_Ropp_H2ln); first by fourier.
move=> t [Ht1 Ht2].
rewrite /H2ln /pderivable_Ropp_H2ln derive_pt_comp derive_pt_minus 2!derive_pt_mult /=.
destruct (Rlt_le_dec 0 t) => /=; last first.
  suff : False by done.
  fourier.
rewrite derive_pt_comp /= mulRA.
apply (@leR_trans (ln t - ln (1 - t))); last first.
  apply Req_le; field.
  split => abs; fourier.
suff : ln ( 1 - t) <= ln t.
  move=> ?; fourier.
apply ln_increasing_le; fourier.
Qed.

Lemma H2ln_max (q : R) : 0 < q < 1 -> - q * ln q - (1 - q) * ln (1 - q) <= ln 2.
Proof.
move=> [Hq0 Hq1].
apply (@leR_trans (H2ln (1/2))); last first.
  apply Req_le.
  rewrite /H2ln (_ : 1 - 1/2 = 1/2); last by field.
  rewrite -mulRBl (_ : - _ - _ = - 1); last by field.
  rewrite div1R ln_Rinv; [by field | by fourier].
rewrite -/(H2ln q).
case: (Rlt_le_dec q (1/2)) => H1.
- apply increasing_on_0_to_half => //.
  split; fourier.
  split; fourier.
  fourier.
- case/Rle_lt_or_eq_dec : H1 => H1.
  + apply decreasing_on_half_to_1 => //.
    split; fourier.
    split; fourier.
    fourier.
  + rewrite -H1; by apply Req_le.
Qed.

(** * The Binary Entropy Function *)

Definition H2 p := - (p * log p) + - ((1 - p) * log (1 - p)).

Lemma bin_ent_0eq0 : H2 0 = 0.
Proof.
rewrite /H2 /log.
by rewrite !(Log_1, mulR0, mul0R, oppR0, mul1R, mulR1,
                       add0R, addR0, subR0).
Qed.

Lemma bin_ent_1eq0 : H2 1 = 0.
Proof.
rewrite /H2 /log.
by rewrite !(Log_1, mulR0, mul0R, oppR0, mul1R, mulR1,
                       add0R, addR0, subR0, subRR).
Qed.

(** The binary entropy function is bounded by 1: *)

Lemma H2_max : forall p, 0 < p < 1 -> H2 p <= 1.
Proof.
move=> p [Hp0 Hp1].
rewrite /H2.
apply (@leR_pmul2l (ln 2)) => //.
rewrite mulR1 mulRDr /log -!mulNR !(mulRC (ln 2)) -!mulRA.
rewrite (mulVR _ ln2_neq0) !mulR1 (mulNR (1 - p)); exact/H2ln_max.
Qed.

Lemma H2_max' (x : R): 0 <= x <= 1 -> H2 x <= 1.
Proof.
move=> [x_0 x_1].
case: x_0 => [?|<-]; last by rewrite bin_ent_0eq0.
case: x_1 => [?|->]; last by rewrite bin_ent_1eq0.
exact: H2_max.
Qed.


Fixpoint ltb (n m : nat) : bool :=
  match n with
  | O => match m with
      | O => false
      | S m' => true
      end
  | S n' =>
      match m with
      | O => false
      | S m' => ltb n' m'
      end
  end.

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.


Require Import List  Arith Omega.

Section mirror.

 Variable A : Type.

 Inductive remove_last (a:A) : list A -> list A -> Prop :=
   | remove_last_hd : remove_last a (a :: nil) nil
   | remove_last_tl :
       forall (b:A) (l m:list A),
         remove_last a l m -> remove_last a (b :: l) (b :: m).

 Inductive palindrome : list A -> Prop :=
   | empty_pal : palindrome nil
   | single_pal : forall a:A, palindrome (a :: nil)
   | cons_pal :
       forall (a:A) (l m:list A),
         palindrome l -> remove_last a m l -> palindrome (a :: m).

 #[local] Hint Constructors remove_last palindrome : core.

 Lemma ababa : forall a b:A, palindrome (a :: b :: a :: b :: a :: nil).
 Proof.
  eauto 7.
 Qed.

(* more about palindromes *)

Lemma remove_last_inv :
 forall (a:A) (l m:list A), remove_last a m l -> m = l ++ a :: nil.
Proof.
 intros a l m H; elim H; simpl; auto with datatypes.
 intros b l0 m0 H0 e; rewrite e; trivial.
Qed.

Lemma rev_app : forall l m:list A, rev (l ++ m) = rev m ++ rev l.
Proof.
 intros l m; elim l; simpl; auto with datatypes.
 intros a l0 H0; rewrite ass_app; rewrite H0; auto.
Qed.

Lemma palindrome_rev : forall l:list A, palindrome l -> rev l = l.
Proof.
 intros l H; elim H; simpl; auto with datatypes.
 intros a l0 m H0 H1 H2; generalize H1; inversion_clear H2.
 -  simpl; auto.
 -  rewrite (remove_last_inv _ _  _ H3); simpl; repeat (rewrite rev_app; simpl).
    intro eg; rewrite eg;  simpl; auto.
Qed.

(* A new induction principle for lists *)

(* preliminaries *)

Lemma length_app :
 forall l l':list A, length (l ++ l') = length l + length l'.
Proof.
  intro l; elim l; simpl; auto.
Qed.

Lemma fib_ind :
 forall P:nat -> Prop,
   P 0 ->
   P 1 ->
  (forall n:nat, P n -> P (S n) -> P (S (S n))) ->
  forall n:nat, P n.
Proof.
 intros P H0 H1 HSSn n.
 assert (H2 : P n /\ P (S n)).
 - induction n ;[tauto | ].
   destruct IHn;split;auto.
 -  destruct H2; auto.
Qed.

Section Proof_of_list_new_ind.
Variables (P : list A -> Prop).

Hypotheses (H0 : P nil)
           (H1 : forall a: A, P (a::nil))
           (H2 : forall (a b:A) (l:list A), P l -> P (a :: l ++ b :: nil)).

Lemma list_cut :
forall (l:list A) (x:A),
            exists b : A, exists l' : list A, x :: l = l' ++ b :: nil.
Proof.
intro l; elim l; simpl.
 intro x; exists x; exists (nil (A:=A)); auto.
 intros a1 l3 H x.
 case (H a1).
 intros x0 H7.
 case H7; intros b Hb.
 rewrite Hb.
 exists x0.
 exists (x :: b); auto.
Qed.

Lemma list_new_ind_length :
forall (n:nat) (l:list A), length l = n -> P l.
Proof.
intro n; pattern n; apply fib_ind.
  -  intro l; case l; [simpl; auto with datatypes |  discriminate].
  -  intro l; case l; simpl; [ discriminate | ].
     +  intros a l0; case l0; simpl; [auto | discriminate].
  -  intros n0 H3 H4 l; case l; simpl;[discriminate |].
     +  intros a l0 H5; generalize H5; case l0.
       *   simpl; discriminate 1.
       *   intros a0 l1 H6; destruct (list_cut l1 a0) as [x [l' Hx]];
           rewrite Hx; apply H2.
           apply H3.
           rewrite Hx in H6.
           rewrite length_app in H6.
           simpl in H6; omega.
Qed.

Lemma list_new_ind :
   forall l:list A, P l.
Proof.
 intro l; now apply list_new_ind_length with (length l).
Qed.

End Proof_of_list_new_ind.

Lemma app_left_reg : forall l l1 l2:list A, l ++ l1 = l ++ l2 -> l1 = l2.
Proof.
 intro l; elim l; simpl; auto.
 intros a l0 H0 l1 l2 H; injection H; auto.
Qed.

Lemma app_right_reg : forall l l1 l2:list A, l1 ++ l = l2 ++ l -> l1 = l2.
Proof.
 intros l l1 l2 e.
 assert (H: rev (l1 ++ l) = rev (l2 ++ l)).
 - now rewrite e.
 -  repeat rewrite rev_app in H.
    generalize (app_left_reg _ _ _ H).
    intro H1;  rewrite <- (rev_involutive  l1) ;
    rewrite <- (rev_involutive l2);
    rewrite H1; auto.
    Qed.

Theorem rev_pal : forall l:list A, rev l = l -> palindrome  l.
Proof.
 intro l; elim l using list_new_ind; auto.
 -  intros a b l0 H H0.
    apply cons_pal with l0.
   +  apply H;  simpl in H0;  rewrite rev_app in H0.
      simpl in H0; injection H0.
      intros H1 e; generalize H1; rewrite e.
      intro H2; generalize (app_right_reg _ _ _ H2); auto.
   +  simpl in H0; rewrite rev_app in H0; simpl in H0.
      injection H0; intros H1 H2; rewrite <- H2.
      generalize l0; intro l1; induction l1; simpl; auto.
Qed.

End mirror.


Check 0.
Check nat.
Check Set.
Check Type.
Check forall T : Set, T.
Check forall T : Type, T.

Definition id (T : Type) (x : T) : T := x.

Set Printing Universes.

Inductive exp : Type -> Type :=
| Const : forall T, T -> exp T
| Pair : forall T1 T2, exp T1 -> exp T2 -> exp (T1 * T2)
| Eq : forall T, exp T -> exp T -> exp bool.

Print exp.

Check (nat, (Type, Set)).

Inductive prod' : Type -> Type -> Type :=
| pair' : forall A B : Type, A -> B -> prod' A B.

Inductive foo (A : Type) : Type :=
  | Foo : A -> foo A.

Check foo nat.
Check foo Set.
Check foo Type.
Check foo True.

Inductive bar : Type := Bar : bar.

Check Bar.
Check bar.

Print sig.
Print ex.

Definition projS A (P : A -> Prop) (x : sig P) : A :=
  match x with
    | exist _ v _ => v
  end.

Definition churchnat := forall X : Prop, (X -> X) -> X -> X.

Definition two : churchnat :=
  fun (X : Prop) (f : X -> X) (x : X) => f (f x).
Definition three : churchnat :=
  fun (X : Prop) (f : X -> X) (x : X) => f (f (f x)).

Definition succ (n : churchnat) : churchnat :=
   fun (X : Prop) (f : X -> X) (x : X) => f (n X f x).

Example succ_2 : succ two = three.
Proof.
  reflexivity.
Qed.

Definition plus (n m : churchnat) : churchnat := n _ succ m.

Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.

Definition projE A (P : A -> Prop) (x : ex P) : A :=
  match x with
    | ex_intro _ v _ => v
  end.


(* author: Jean-Christophe Filliâtre *)

(**
  Correctness proof of Floyd's cycle-finding algorithm, also known as
  the "tortoise and the hare"-algorithm
  (see http://en.wikipedia.org/wiki/Floyd's_cycle-finding_algorithm)

  If $f:A\rightarrow A$ is a function over a finite set $A$,
  then the iterations of $f$ from $x_0\in A$ will ultimately cycle.
  The following code finds out an integer $m$ such that
  $f^m(x_0)=f^{2m}(x_0)$ :
<<
let rec race m x y = if x = y then m else race (m+1) (f x) (f (f y))
in race 1 (f x0) (f (f x0))
>>
  The difficulty is to prove $f$'s termination.
*)

Require Export Arith.
Require Export Omega.
Open Scope nat_scope.

(** Let [f] be a function over a set [A] *)

Parameter A : Set.
Parameter eq_A_dec : forall (x y:A), {x=y}+{~x=y}.
Parameter f : A -> A.
Parameter x0 : A.

(** We consider the sequence $x_i = f^i(x_0)$ *)

Fixpoint x (i:nat) { struct i } : A := match i with
  | O => x0
  | S j => f (x j)
  end.

(** We assume this sequence cycles after [lambda+mu] iterations, [mu]
    being the length of the cycle (we actually don't require [lambda] and
    [mu] to be minimal, because it is not needed for the remaining of the
    proof *)

Parameter lambda : nat.
Parameter mu : nat.
Axiom mu_positive : mu > 0.
Axiom lambda_mu : forall i j, x (lambda+i) = x (lambda+i+j*mu).

(** Hilbert's epsilon operator. *)

Parameter epsilon : (nat -> Prop) -> nat.
Axiom epsilon_spec : forall P, ex P -> P (epsilon P).

(** The distance between [x (2m)] and [x m] defined using [epsilon] *)

Definition sep_x2m_xm m i := x (2*m+i) = x m.

Definition min P i := P i /\ forall j, P j -> i <= j.

Definition dist_x2m_xm m := epsilon (min (sep_x2m_xm m)).

(** Existence of this distance whenever [lambda <= m] *)

Axiom ex_min_P : forall P, (forall x, {P x}+{~(P x)}) -> ex P -> ex (min P).

Axiom div : forall a, a > 0 -> forall b, exists k, k*a >= b.

Lemma ex_dist_x2m_xm : forall m, lambda <= m -> ex (min (sep_x2m_xm m)).
Proof.
  intros m hm; apply ex_min_P.
  intro i; unfold sep_x2m_xm.
  case (eq_A_dec (x (2 * m + i))  (x m)); auto.
  generalize (div mu mu_positive m); intros (k,hk).
  exists (k*mu - m); unfold sep_x2m_xm.
  replace (2 * m + (k * mu - m)) with (lambda + (m-lambda)+k*mu) by omega.
  rewrite <- lambda_mu.
  replace (lambda+(m-lambda)) with m by omega; auto.
Qed.

(** Variant to prove the termination of Floyd's algorithm:
    - either [x m] has not entered the loop yet and [lambda-m] is decreasing
    - or bot [x m] and [x (2m)] are inside the loop and the distance between
      [x (2m)] and [x m] is decreasing
    Thus we use a lexicographic order. *)

Definition variant m := (lambda - m, dist_x2m_xm m).

Definition lex x y := fst x < fst y \/ (fst x = fst y /\ snd x < snd y).

(** Correctness proof *)

Theorem rec_call_is_wf :
  forall m, x m <> x (2*m) -> lex (variant (S m)) (variant m).
Proof.
  unfold lex,variant; simpl.
  intros.
  assert (h: m < lambda \/ m >= lambda) by omega.
  destruct h.
  left; omega.
  right.
  split; auto with *.
  unfold dist_x2m_xm.
  assert (exd1: ex (min (sep_x2m_xm (S m)))).
  apply ex_dist_x2m_xm; auto with *.
  generalize (epsilon_spec (min (sep_x2m_xm (S m))) exd1).
  assert (exd0: ex (min (sep_x2m_xm m))).
  apply ex_dist_x2m_xm; auto with *.
  generalize (epsilon_spec (min (sep_x2m_xm m)) exd0).
  generalize (epsilon (min (sep_x2m_xm m))).
  generalize (epsilon (min (sep_x2m_xm (S m)))).
  intros d1 d0.
  unfold min,sep_x2m_xm.
  intros (h1,h2) (h3,h4).
  assert (x (S(2*m+d0)) = x (S m)).
  simpl; simpl in h1; congruence.
  assert (d0 > 0).
  assert (h: d0=0 \/ d0>0) by omega. destruct h; auto.
  subst d0; absurd (x (2*m)=x m); auto.
  replace (2*m+0) with (2*m) in h1; auto.
  assert (d1 <= d0-1).
  apply h4.
  replace (2 * (S m) + (d0 - 1)) with (S (2 * m + d0)) by omega.
  auto.
  omega.
Qed.

Definition R x y := lex (variant x) (variant y).
Axiom R_wf : well_founded R.

Definition find_cycle_rec :
  forall (m:nat) (xm x2m:A), m > 0 -> xm=x m -> x2m=x (2*m) ->
  { m:nat | m > 0 /\ x m = x (2*m) }.
Proof.
  induction m using (well_founded_induction R_wf).
  intros xm x2m h hm h2m.
  destruct (eq_A_dec xm x2m).
  exists m; subst xm x2m; auto.
  apply (H (S m)) with (f xm) (f (f x2m)); subst xm x2m; auto with *.
  unfold R; apply rec_call_is_wf; auto.
  replace (2*(S m)) with (S (S (2*m))) by omega; auto.
Defined.

Definition find_cycle : { m:nat | m > 0 /\ x m = x (2*m) }.
Proof.
  apply (find_cycle_rec (S O) (f x0) (f (f x0))); auto with *.
Defined.

(*
Recursive Extraction find_cycle.
*)


Require Import Arith.
Require Import Arith.Max.

Require Import set.
Require Import order.

(******************************************************************************)
(*                       subset : set -> set -> Prop                          *)
(******************************************************************************)
(*
  We have defined a type 'set' which is meant to represent a subclass of the
  set theoretic class of finite sets. However, we know that equality on 'set'
  is of no value and an appropriate equivalence relation needs to be defined.
  One key step on the path to defining equivalence between sets is to define
  the inclusion relation <= on sets. Set membership is another important
  relation on sets, but we shall find it more convenient to focus first on
  the inclusion relation as a primitive, and define 'x in y' as {x} <= y.

  The inclusion relation <= should satisfy the following properties:

  (i)   0 <= x                                , forall x
  (ii)  ¬({x} <= 0)                           , forall x
  (iii) {x} <= {y}  <-> (x <= y) /\ (y <= x)  , forall x,y
  (iv)  {x} <= yUz  <-> {x] <= y \/ {x} <= z  , forall x,y,z
  (v)   xUy <= z    <->  x <= z  /\  y <= z   , forall x,y,z

  Property (i) states that the empty set is a subset of all sets.
  Property (ii) states that no singleton set {x} is ever a subset of the
  empty set. Property (iii) states that a singleton set {x} is a subset
  of another singleton {y} if and only if x and y are 'equal' (we do not
  mean 'equal' as elements of 'set' of course), that is 'equivalent' (as
  we shall later define it) which means that x and y are both subsets of
  each other. Property (iv) states that a singleton set {x} is a subset of
  a union yUz if and only if x is an element of y or x is an element of z,
  which in turn means that {x} is a subset of y or {x} is a subset of z.
  Property (v) states that a union xUy is a subset of z, if and only if
  both x and y are subsets of z.

  All these properties are pretty natural, and we expect them to hold for
  a binary relation <=, if it is to be viewed as a suitable candidate for
  modelling the inclusion relation on 'set'. However, because properties
  (i)-(v) appear to be very similar to a definition by recursion of <=
  (viewed as a curried operator with boolean values <= : set -> set -> bool),
  it is tempting to believe that these are actually defining properties.
  In other words, it is tempting to believe that not only does there exists
  a relation on set which satisfies properties (i)-(v), but such relation
  is in fact unique. Proving existence and uniqueness of this relation is
  the purpose of what follows.

  Defining the Haskell type:

    data Set = O | S Set | U Set Set

  the relation <= can be viewed as a map: subset :: Set -> Set -> Bool
  which (following properties (i)-(v)) could be defined as follows:

  subset O _            = True                                  -- prop (i)
  subset (S x) O        = False                                 -- prop (ii)
  subset (S x) (S y)    = (subset x y) && (subset y x)          -- prop (iii)
  subset (S x) (U y z)  = (subset (S x) y) || (subset (S x) z)  -- prop (iv)
  subset (U x y) z      = (subset x z) && (subset y z)          -- prop (v)

  This looks like a recursive definition: first 'subset 0' is defined.
  Then 'subset (S x)' is defined and lastly 'subset (U x y)'. The definition
  of 'subset (U x y)' involves 'subset x' and 'subset y' which is legtimate
  for a structural recursion. Now the definition of 'subset (S x)' itself
  looks like a structural recursion: it is first defined on O, then on (S y)
  and finally on (U y z). The definition on (U y z) only involves evaluations
  of subset (S x) on y and z which is also very nice. However, something is
  not quite right when defining subset (S x) on (S y). A normal recursive
  definition of subset (S x) on (S y) should involve subset (S x) evaluated
  at y. Unfortunately, this is not what we have: our definition of subset (S x)
  on (S y) involves subset x y and subset y x.

  Hence we cannot claim that the above Haskell definition constitutes a
  mathematically acceptable recursive definition. We may have valid
  Haskell syntax and possibly prove that function evaluations would
  always terminate, but we cannot claim to have 'mathematically' proved
  the existence of a binary relation <= on set, which satisfies (i)-(v).

  In fact, attempting to replicate this definition in Coq will not yield
  valid code: "Error: Recursive definition of subset is ill-formed."

  Fixpoint subset (a:set): set -> Prop :=
    match a with
      | Empty       => (fun b => True)
      | Singleton x => (fun b =>
        match b with
          | Empty             => False
          | Singleton y       => subset x y /\ subset y x   (* problem here *)
          | Union y z         => subset a y \/ subset a z
        end)
      | Union x y   => (fun b => subset x b /\ subset y b)
    end.

  Rather than attempting to define a map subset : set -> set -> Prop directly,
  we shall define a sequence of maps Rn : set -> set -> Prop indexed by the
  natural numbers. This sequence will be defined by a standard recursion on N,
  making sure the map Rn for (n >= 1) is solely defined in terms of R(n-1).
  While we consider Rn to have values in 'Prop' when working with Coq, when
  translating the argument into standard ZF-based mathematics, we shall
  regard Rn: set -> set -> 2 = {0,1}. Defining R0 x y = 1, for n >=1 we set:

    Rn 0 _      = 1
    Rn {x} 0    = 0
    Rn {x} {y}  = R(n-1) x y /\ R(n-1) y x
    Rn {x} yUz  = R(n-1) {x} y \/ R(n-1) {x} z
    Rn xUy z    = R(n-1) x z /\ R(n-1) y z

*)

Fixpoint subset_n (n:nat) : set -> set -> Prop :=
  match n with
    | 0   => (fun _ _     => True)
    | S p => (fun a b     =>
      match a with
        | Empty           => True
        | Singleton x     =>
          match b with
            | Empty       => False
            | Singleton y => subset_n p x y /\ subset_n p y x
            | Union y z   => subset_n p (Singleton x) y \/
                             subset_n p (Singleton x) z
          end
        | Union x y       => subset_n p x b /\ subset_n p y b
      end)
  end.

(*

Once we have defined the sequence of mappings Rn: set -> set -> 2,
the key is to realize that given a b:set, the boolean sequence
(Rn a b) is eventually constant. Specifically, we have:

  order(a) + order(b) <= n -> Rn a b = R(n+1) a b

*)

Lemma subset_n_Sn : forall (n:nat) (a b:set),
  order a + order b <= n -> (subset_n n a b <-> subset_n (S n) a b).
Proof.
  (* induction on n *)
  intro n. elim n.
  (* n = 0 *)
  intros a b. intro H. cut(a = Empty). intro H'. rewrite H'. simpl. tauto.
  apply order_sum_eq_0_l with (b:=b). symmetry. apply le_n_0_eq. exact H.
  (* n -> n+1 *)(* induction on a *)
  clear n. intros n IH. intro a. elim a.
  (* a = Empty *)
  intro b. simpl. tauto.
  (* a = Singleton x *)(* induction on b *)
  clear a. intros x Hx. intro b. elim b.
  (* b = Empty *)
  intro H. simpl. tauto.
  (* b = Singleton y *)
  clear b. intros y Hy H.
  unfold subset_n at 1. fold subset_n.
  cut(subset_n (S (S n)) (Singleton x) (Singleton y) <->
     (subset_n (S n) x y)/\(subset_n (S n) y x)).
  intro H'. rewrite H'. rewrite <- IH, <- IH. tauto.
  apply order_sum_singleton. rewrite plus_comm. exact H.
  apply order_sum_singleton. exact H.
  simpl. reflexivity.
  (* b = Union y z *)
  clear b. intros y Hy z Hz H.
  unfold subset_n at 1. fold subset_n.
  cut(subset_n (S (S n)) (Singleton x) (Union y z) <->
     (subset_n (S n) (Singleton x) y)\/(subset_n (S n) (Singleton x) z)).
  intro H'. rewrite H'. rewrite <- IH, <- IH. tauto.
  apply order_sum_union_Rr with (y:=y). exact H.
  apply order_sum_union_Rl with (z:=z). exact H.
  simpl. reflexivity.
  (* a = Union x y *)
  clear a. intros x Hx y Hy b H.
  unfold subset_n at 1. fold subset_n.
  cut(subset_n (S (S n)) (Union x y) b <->
     (subset_n (S n) x b)/\(subset_n (S n) y b)).
  intro H'. rewrite H'. rewrite <- IH, <- IH. tauto.
  apply order_sum_union_Lr with (x:=x). exact H.
  apply order_sum_union_Ll with (y:=y). exact H.
  simpl. reflexivity.
  Qed.

(* This allows us to define R: set -> set -> 2 as by setting
R a b = Rn a b for n large enough, specifically n = order a + order b
*)
Definition subset (a b:set) : Prop :=
  let n:= order a + order b in subset_n n a b.

(*
We now check the obvious, namely that R a b = Rn a b for n large enough
*)

Lemma subset_subset_n : forall (n:nat) (a b:set),
  order a + order b <= n -> (subset a b <-> subset_n n a b).
Proof.
  (* induction on n *)
  intros n. elim n.
  (* n = 0 *)
  intros a b H. cut (a = Empty). cut (b = Empty). intros Hb Ha. rewrite Ha, Hb.
  unfold subset. simpl. tauto.
  apply order_sum_eq_0_r with (a:=a). symmetry. apply le_n_0_eq. exact H.
  apply order_sum_eq_0_l with (b:=b). symmetry. apply le_n_0_eq. exact H.
  (* n -> n+1 *)
  clear n. intros n IH a b H.
  (* either order a + order b < S n or = S n *)
  cut((order a + order b < S n)\/(order a + order b = S n)). intro H0. elim H0.
  (* order a + order b < S n *)
  intro H1. rewrite IH. apply subset_n_Sn.
  apply le_S_n. exact H1. apply le_S_n. exact H1.
  (* order a + order b = S n *)
  intro H1. unfold subset. rewrite H1. tauto.
  (* finally *)
  apply le_lt_or_eq. exact H.
Qed.

(*
At this stage we have defined a relation R: set -> set -> 2.
It remains to prove that R satisfies properties (i)-(v).

  (i)   0 <= x                                , forall x
  (ii)  ¬({x} <= 0)                           , forall x
  (iii) {x} <= {y}  <-> (x <= y) /\ (y <= x)  , forall x,y
  (iv)  {x} <= yUz  <-> {x] <= y \/ {x} <= z  , forall x,y,z
  (v)   xUy <= z    <->  x <= z  /\  y <= z   , forall x,y,z

  We start with (i)
*)
Proposition subset_0_all : forall (b:set), subset Empty b.
Proof.
  (* induction on b *)
  intro b. elim b.
  (* b = Empty *)
  unfold subset. simpl. apply I.
  (* b = Singleton x *)
  clear b. intros x H. unfold subset. simpl. apply I.
  (* b = Union x y *)
  clear b. intros x Hx y Hy. unfold subset. simpl. apply I.
Qed.

(*
property (ii)
*)

Proposition subset_single_0 : forall (x:set), ~subset (Singleton x) Empty.
Proof.
  (* not structural induction necessary *)
  intro x. unfold subset. simpl. tauto.
Qed.

(*
property (iii)
*)

Proposition subset_single_single : forall (x y:set),
  subset (Singleton x) (Singleton y) <-> (subset x y)/\(subset y x).
Proof.
  intros x y. unfold subset at 1. simpl.
  rewrite <- subset_subset_n, <- subset_subset_n. tauto.
  rewrite plus_comm. apply plus_le_compat_l. apply le_S. apply le_n.
  apply plus_le_compat_l. apply le_S. apply le_n.
Qed.

(*
property (iv)
*)

Proposition subset_single_union: forall (x y z:set),
  subset (Singleton x) (Union y z) <->
  (subset (Singleton x) y)\/(subset (Singleton x) z).
Proof.
  intros x y z. unfold subset at 1. simpl.
  rewrite <- subset_subset_n, <- subset_subset_n. tauto.
  simpl. rewrite <- plus_n_Sm. apply le_n_S.
  apply plus_le_compat_l. apply le_max_r.
  simpl. rewrite <- plus_n_Sm. apply le_n_S.
  apply plus_le_compat_l. apply le_max_l.
Qed.

(*
property (v)
*)

Proposition subset_union_all : forall (x y b:set),
  subset (Union x y) b <-> (subset x b)/\(subset y b).
Proof.
  intros x y b. unfold subset at 1. simpl.
  rewrite <- subset_subset_n, <- subset_subset_n. tauto.
  apply plus_le_compat_r. apply le_max_r. apply plus_le_compat_r. apply le_max_l.
Qed.

(*
Wrapping things up for the existence result: defining a few predicates
on relations of type set -> set -> 2. Each predicate refers to one
of the properties (i)-(v) which we have proved our inclusion
relation satisfies
*)

Definition subset_prop_1 (relation: set -> set -> Prop) : Prop :=
  forall (b:set), relation Empty b.

Definition subset_prop_2 (relation: set -> set -> Prop) : Prop :=
  forall (x:set), ~relation (Singleton x) Empty.

Definition subset_prop_3 (relation: set-> set -> Prop) : Prop :=
  forall (x y:set),
  relation (Singleton x) (Singleton y) <-> relation x y /\ relation y x.

Definition subset_prop_4 (relation: set -> set -> Prop) : Prop :=
  forall (x y z:set),
  relation (Singleton x) (Union y z) <->
  relation (Singleton x) y \/ relation (Singleton x) z.

Definition subset_prop_5 (relation: set -> set -> Prop) : Prop :=
  forall (x y b:set),
  relation (Union x y) b <-> relation x b /\ relation y b.

(*
There exists a binary relation on set which satisfies (i)-(v)
  (i)   0 <= x                                , forall x
  (ii)  ¬({x} <= 0)                           , forall x
  (iii) {x} <= {y}  <-> (x <= y) /\ (y <= x)  , forall x,y
  (iv)  {x} <= yUz  <-> {x] <= y \/ {x} <= z  , forall x,y,z
  (v)   xUy <= z    <->  x <= z  /\  y <= z   , forall x,y,z
*)

Lemma subset_exist :
  subset_prop_1 subset /\
  subset_prop_2 subset /\
  subset_prop_3 subset /\
  subset_prop_4 subset /\
  subset_prop_5 subset.
Proof.
  split. unfold subset_prop_1. apply subset_0_all.
  split. unfold subset_prop_2. apply subset_single_0.
  split. unfold subset_prop_3. apply subset_single_single.
  split. unfold subset_prop_4. apply subset_single_union.
  unfold subset_prop_5. apply subset_union_all.
Qed.

(*
Such relation is in fact unique.
*)

Lemma subset_unique : forall (relation : set -> set -> Prop),
  subset_prop_1 relation ->
  subset_prop_2 relation ->
  subset_prop_3 relation ->
  subset_prop_4 relation ->
  subset_prop_5 relation ->
  forall (a b:set), relation a b <-> subset a b.
Proof.
  intros relation H1 H2 H3 H4 H5 a b.
  (* proof by induction on order a + order b <= n *)
  cut(forall n:nat, order a + order b <= n -> (relation a b <-> subset a b)).
  intro H. apply H with (n:= order a + order b). apply le_n.
  intro n. generalize a b. clear a b. elim n.
  (* order a + order b <= 0 *)
  intros a b H. cut (a = Empty). intro H'. rewrite H'.
  split. intros. apply subset_0_all. intros. apply H1.
  apply order_sum_eq_0_l with (b:=b). symmetry. apply le_n_0_eq. exact H.
  (* true for <= n -> true for <= n+1 *)
  (* induction on a *)
  clear n. intros n IH a. elim a.
  (* a = Empty *)
  intros b H. split. intros. apply subset_0_all. intros. apply H1.
  (* a = Singleton x *)(* induction on b *)
  clear a. intros x H b. elim b.
  (* b = Empty *)
  intros. split.
  intros. apply False_ind. apply H2 with (x:=x). exact H6.
  intros. apply False_ind. apply subset_single_0 with (x:=x). exact H6.
  (* b = Singleton y *)
  clear b. intros y H' H''. unfold subset_prop_3 in H3.
  rewrite H3, subset_single_single, IH, IH. tauto.
  rewrite plus_comm. apply order_sum_singleton. exact H''.
  apply order_sum_singleton. exact H''.
  (* b = Union y z *)
  clear b. intros y Hy z Hz H'. unfold subset_prop_4 in H4.
  rewrite H4, subset_single_union, IH, IH. tauto.
  apply order_sum_union_Rr with (y:=y). exact H'.
  apply order_sum_union_Rl with (z:=z). exact H'.
  (* a = Union x y *)
  clear a. intros x Hx y Hy b H. unfold subset_prop_5 in H5.
  rewrite H5, subset_union_all, IH, IH. tauto.
  apply order_sum_union_Lr with (x:=x). exact H.
  apply order_sum_union_Ll with (y:=y). exact H.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Ralph Matthes [+]                              *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation IRIT -- CNRS   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega Extraction.
Require Import list_utils bt sorted.

Set Implicit Arguments.

(** The very standard Depth First Search algorithm on a binary
    tree with a specification: it returns the values on nodes where
    nodes are sorted in lexicographic order of their corresponding
    branches. *)

Section dft_std.

  Variable X : Type.

  Implicit Types (l : list bool) (ll: list (list bool)) (t : bt X).

  (* Depth first traversal, VERY standard algo *)

  Fixpoint dft_std t : list X :=
    match t with
      | leaf x => x::nil
      | node u x v => x::dft_std u++dft_std v
    end.

  Fact dft_std_length t : length (dft_std t) = m_bt t.
  Proof. induction t; simpl; repeat rewrite app_length; omega. Qed.

  (* The tree branches by Depth First Traversal *)

  Fixpoint dft_br t : list (list bool) :=
    nil::match t with
           | leaf _     => nil
           | node u _ v => map (cons false) (dft_br u) ++ map (cons true) (dft_br v)
         end.

  (* dft_br corresponds to dft_std *)

  Theorem dft_br_std t : Forall2 (bt_path_node t) (dft_br t) (dft_std t).
  Proof.
    induction t as [ | ? Hu ? ? Hv ]; simpl; repeat constructor.
    apply Forall2_app; apply Forall2_map_left; [ revert Hu | revert Hv ];
      apply Forall2_mono; constructor; auto.
  Qed.

  (* number of branches equals size of tree *)

  Fact dft_br_length t : length (dft_br t) = m_bt t.
  Proof. rewrite (Forall2_length (dft_br_std t)), dft_std_length; trivial. Qed.

  (* dft_br lists the branches of t *)

  Fact dft_br_spec l t : In l (dft_br t) <-> btb t l.
  Proof.
    split.
    + intros Hl; rewrite btb_spec.
      destruct Forall2_In_inv_left with (1 := dft_br_std t) (2 := Hl) as (x & ? & ?).
      exists x; auto.
    + induction 1 as [ [] | | ]; simpl; auto; right; apply in_or_app;
        [ left | right ]; apply in_map; auto.
   Qed.

  Corollary dft_br_spec_1 t : Forall (btb t) (dft_br t).
  Proof. rewrite Forall_forall; intro; apply dft_br_spec. Qed.

  (* the branches of t in dft_br t are sorted according to lb_lex *)

  Fact dft_br_sorted t : sorted lb_lex (dft_br t).
  Proof.
    induction t; simpl.
    + do 2 constructor.
    + constructor.
      * apply Forall_app; rewrite Forall_forall; intro;
          rewrite in_map_iff; intros (? & ? & ?); subst; constructor.
      * apply sorted_app.
        - intros ? ?; do 2 rewrite in_map_iff.
          intros (? & ? & ?) (? & ? & ?); subst; constructor.
        - apply sorted_map; auto; constructor; auto.
        - apply sorted_map; auto; constructor; auto.
  Qed.

End dft_std.

(*
Recursive Extraction dft_std.

Check dft_br_spec.
Check dft_br_sorted.
Check dft_br_std.
*)


(** TP5 : Lemme du diamant, pour prouver la confluence du lambda-calcul *)

(** Prédicats inductifs : relations **)

(* Le type [A -> A -> Prop] des formules paramétrées par deux éléments
de A sert à représenter les relations sur A. *)
Definition relation A := A -> A -> Prop.

(* Mais on peut aussi définir des relations de relations comme par
example l'inclusion entre les relations. *)
Definition incl A : relation (relation A) := fun R1 R2 =>
  forall x y, R1 x y -> R2 x y.

(* Definissez la relation maximale, la relation minimale (i.e. la
relation vide) ainsi que la relation identité. *)
Definition rel_full A : relation A := fun x y => True.
Definition rel_empty A : relation A := fun x y => False.
Definition rel_id A : relation A := fun x y => x = y.

(* Étant donnée une relation, définissez la relation réciproque. *)
Definition converse A (R : relation A) := fun x y => R y x.

(* On peut aussi définir des propriétés sur les relations comme par
exemple la transitivité : *)
Definition transitive A (R : relation A) : Prop  :=
  forall x y z, R x y -> R y z -> R x z.

(* Définissez la réflexivité et la symétrie: *)
Definition reflexive A (R : relation A) : Prop := forall n, R n n.
Definition symmetric A (R : relation A) : Prop := forall x y, R x y -> R y x.

(* Dans cette section nous allons fabriquer la cloture reflexive
transitive d'une relation. *)

Section Star.

(* On suppose qu'on dispose d'un type A et d'une relation sur A. *)
Variable A : Type.
Variable R : A -> A -> Prop.

(* On définit le prédicat inductif suivant : *)
Inductive star : A -> A -> Prop :=
  | star_refl : forall a, star a a
  | star_R : forall a b c, R a b -> star b c -> star a c.

Lemma R_star : incl A R star.
Proof.
  intros x y Rxy.
  apply (star_R x y y).
    assumption.
    constructor.
Qed.

Lemma star_trans : transitive A star.
Proof.
  intros x y z p. induction p.
    intros q. assumption.
    intros q. apply star_R with b.
      assumption.
      apply IHp. assumption.
Qed.

Definition plus x y := exists z, R x z /\ star z y.

Lemma R_plus : forall x y, R x y -> plus x y.
Proof.
  intros x y p. exists y. split.
    assumption.
    constructor.
Qed.

Lemma plus_trans :transitive A plus.
Proof.
  intros x y z p q.
  destruct p as [s [p1 p2]].
  destruct q as [t [q1 q2]].
  exists s. split.
    assumption.
    apply star_trans with t.
      apply star_trans with y.
        assumption.
        apply R_star. assumption.
      assumption.
Qed.

Check star_trans.
End Star.
Check star_trans.

(** Définition de la confluence **)

Variable A : Type.
Variable R : relation A.

Notation "a => b" := (R a b) (at level 42).
Notation "a =>* b" := (star _ R a b) (at level 42).
Notation "a =>+ b" := (plus _ R a b) (at level 42).

Definition confl_wrt (x : A) :=
  forall n1 n2:A, (x =>* n1 /\ x =>* n2) -> exists p:A, n1 =>* p /\ n2=>* p.

Definition confl := forall x, confl_wrt x.

(** Propriété et lemme du diamant *)

Definition dia_wrt (x : A) := ...

Definition dia := forall x, dia_wrt x.

Lemma dia_one_square: dia -> forall x y, x =>* y -> forall z, x => z ->
  exists k, z =>* k /\ y => k.
Proof.
...
Qed.

Lemma diaconfl : dia -> confl.
Proof.
...
Qed.


Require Export Induction.

Inductive natprod : Type :=
| pair : nat -> nat -> natprod.

Definition fst (p:natprod) := match p with
| pair x y => x
end.

Definition snd (p:natprod) := match p with
| pair x y => y
end.

Theorem surjective_pairing_n_m : forall n m : nat, pair n m = pair (fst (pair n m)) (snd (pair n m)).
reflexivity.
Show Proof.
Qed.

Theorem surjective_pairing : forall p : natprod, p = pair (fst p) (snd p).
destruct p.
reflexivity.
Show Proof.
Qed.

Inductive natlist : Type :=
| nil : natlist
| cons : nat->natlist->natlist
.

Fixpoint repeat (n count : nat) : natlist :=
match count with
| O => nil
| S c' => cons n (repeat n c')
end.

Fixpoint length (l : natlist) : nat :=
match l with
| nil => O
| cons n rest => S (length rest)
end.

Fixpoint append (l1 l2 : natlist) : natlist := match l1 with
| nil => l2
| cons n1 rest1 => cons n1 (append rest1 l2)
end.

Definition head (l:natlist) (d:nat) : nat := match l with
| nil => d
| cons n _ => n
end.

Definition tail (l:natlist) : natlist := match l with
| nil => nil
| cons _ t => t
end.

Theorem nil_app : forall l:natlist, (append nil l) = l.
reflexivity.
Qed.

Theorem tl_length_pred : forall l:natlist, pred (length l) = length (tail l).
destruct l;reflexivity.
Show Proof.
Qed.

Theorem append_associative : forall (l m n : natlist), (append (append l m) n) = (append l (append m n)).
induction l.
reflexivity.
simpl.
intros m n0.
rewrite (IHl m n0).
reflexivity.
Show Proof.
Qed.

Fixpoint rev (l:natlist) : natlist :=
match l with
| nil => nil
| cons n rest => (append rest (cons n nil))
end.

Theorem app_length : forall l1 l2 : natlist, length (append l1 l2) = (plus (length l1) (length l2)).
intro l.
induction l.
reflexivity.
simpl.
intro l2.
rewrite(IHl l2).
reflexivity.
Qed.

Theorem rev_length : forall l : natlist, length (rev l) = length l.
induction l.
reflexivity.
simpl.
rewrite -> app_length.
rewrite -> plus_commute.
reflexivity.
Qed.

Inductive natoption : Type :=
| Some : nat -> natoption
| None : natoption
.

Fixpoint nth (l:natlist) (n:nat) : natoption := match l with
| nil => None
| cons e rest => if beq_nat n O then Some e else nth rest (pred n)
end.

Definition elim (o:natoption) (d:nat) := match o with
| None => d
| Some n => n
end.

Inductive id : Type :=
| Id : nat -> id.

Definition beq_id (i j : id) :=
match i, j with
| Id ni, Id nj => beq_nat ni nj
end.

Inductive partial_map : Type :=
| empty : partial_map
| record : id -> nat -> partial_map -> partial_map.

Definition update (d:partial_map) (x:id) (value:nat) : partial_map := record x value d.

Fixpoint find (x:id) (d:partial_map) : natoption := match d with
| empty => None
| record y v d' => if beq_id x y then Some v else find x d'
end.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  mult lf1 (Succ y).


Require Export Reals.
Require Export QArith.
Require Export Qreals.

Open Scope R_scope.
Lemma inverses_of_nats_approach_0:
  forall eps:R, eps > 0 -> exists n:nat, (n > 0)%nat /\
                                         / (INR n) < eps.
Proof.
intros.
assert (exists n:Z, (n>0)%Z /\ / (IZR n) < eps).
exists (up (/ eps)); split.
assert (IZR (up (/ eps)) > 0).
apply Rgt_trans with (/ eps).
apply archimed.
auto with *.
assert ((0 < up (/ eps))%Z).
apply lt_IZR.
simpl.
assumption.
auto with *.
pattern eps at 2.
rewrite <- Rinv_involutive.
apply Rinv_lt_contravar.
apply Rmult_lt_0_compat; auto with *.
apply Rlt_trans with (/ eps); auto with *.
apply archimed.
apply archimed.
auto with *.

destruct H0 as [[ | p | p]].
destruct H0.
contradict H0; auto with *.

destruct H0.
exists (nat_of_P p).
split; auto with *.

destruct H0.
contradict H0.
red; intro.
inversion H0.
Qed.

Lemma Z_interpolation: forall x y:R, y > x+1 ->
  exists n:Z, x < IZR n < y.
Proof.
intros.
exists (up x).
split.
apply archimed.
apply Rle_lt_trans with (x+1).
pose proof (archimed x).
destruct H0.
assert (x + (IZR (up x) - x) <= x + 1).
auto with real.
ring_simplify in H2.
assumption.
assumption.
Qed.

Lemma rational_interpolation: forall (x y:R) (n:positive),
  x<y -> IZR (' n) > 1/(y-x) ->
  exists m:Z, x < Q2R (m # n) < y.
Proof.
intros.
assert (0 < / IZR (' n)).
cut (0 < IZR (' n)); auto with real.
replace 0 with (IZR 0) by trivial.
cut ((0 < ' n)%Z); auto with *.
apply IZR_lt.
unfold Zlt.
trivial.

destruct (Z_interpolation (IZR (' n) * x)
  (IZR (' n) * y)) as [m].
apply Rgt_minus in H.
assert (IZR (' n) * (y - x) > 1).
replace 1 with ((1 / (y-x)) * (y-x)); try field.
apply Rmult_gt_compat_r; trivial.
auto with real.
apply Rgt_minus in H2.
apply Rminus_gt.
match goal with H2: ?a > 0 |- ?b > 0 => replace b with a end.
trivial.
ring.

exists m.
unfold Q2R.
simpl.
replace (INR (nat_of_P n)) with (IZR (' n)) by auto with real.
replace x with ((IZR (' n) * x) / IZR (' n)).
replace y with ((IZR (' n) * y) / IZR (' n)).

destruct H2.
split.
apply Rmult_lt_compat_r; trivial.
apply Rmult_lt_compat_r; trivial.
field.
auto with *.
field.
auto with *.
Qed.

Lemma rationals_dense_in_reals: forall x y:R, x<y ->
  exists q:Q, x < Q2R q < y.
Proof.
intros.
pose (d := up (/ (y - x))).
assert ((0 < d)%Z).
apply lt_IZR.
simpl.
apply Rlt_trans with (/ (y - x)).
apply Rgt_minus in H.
auto with *.
apply archimed.
assert (/ (y - x) < IZR d) by apply archimed.
destruct d as [|d|]; try discriminate H0.

destruct (rational_interpolation x y d) as [n]; trivial.
replace (1 / (y-x)) with (/(y-x)).
trivial.
field.
apply Rgt_minus in H.
auto with real.

exists (n # d); trivial.
Qed.


Section Negation.
  Variables P Q R S T: Prop.

  (* unfold not: expansion de la négation dans le but *)
  (* unfold not in X: expansion de la négation dans l'hypothèse X *)
  (* exfalso: transforme le but courant en False; c'est l'équivalent
     de la règle d'élimination de la contradiction *)
  (*unfold -> transformer ~p en p -> bottom*)
  (*exfalso -> transforme une lettre en bottom*)
  (* Executez cette preuve en essayant de comprendre le sens de chacune des nouvelles tactiques utilisées. *)
  Lemma absurde_exemple: P -> ~P -> S.
  Proof.
    intros p np.
    unfold not in np.
    exfalso.
    apply np.
    assumption.
  Qed.

  Lemma triple_neg_e : ~~~P -> ~P.
  Proof.
     intro H.
     intro H0.
     apply H.
     intro H1.
     apply H1; assumption.
   Restart.  (* Annule la preuve en cours, et en commence un autre *)
   unfold not.
   auto.
   (* auto est une tactique qui est capable de beaucoup, mais qu'on
      s'interdira d'utiliser dans nos preuves *)
   Qed.

  (* Début des exercices *)

  (* QUESTION: Remplacer les Admitted par des scripts de preuve *)
  Lemma absurde: (P -> Q) -> (P -> ~Q) -> (P -> S).
  Proof.
    intros.
    exfalso.
    unfold not in H0.
    apply H0.
    assumption.
    apply H.
    assumption.
  Qed.

  Lemma triple_abs: ~P -> ~~~P.
  Proof.
    intro.
    unfold not.
    intros.
    apply H0.
    intro.
    apply H.
    assumption.
  Qed.

  Lemma absurd' : (~P -> P) -> ~~P.
  Proof.
    intros.
    unfold not.
    intros.
    apply H0.
    apply H.
    unfold not.
    apply H0.
  Qed.

  Definition Peirce  := ((P -> Q) -> P) -> P.

  (* On va prouver non-non-Peirce *)
  Lemma Peirce_2 : ~~ Peirce.
  unfold not.
  intro.
  apply H.
  unfold Peirce in H.
  unfold Peirce.
  intro.
  apply H0.
  intro.
  exfalso.
  apply H.
  intro.
  assumption.
  Qed.

  (* Une série de séquents à prouver; à chaque fois, il faut
  l'énoncer, en introduisant les hypothèses au moyen d'une
  sous-section. *)

  (* P->Q, R->~Q, P->R |- P->S *)

  (* ~P->~Q |- ~~Q->~~P *)

  (* P->~P |- ~P *)

  (* ~~P |- ~P->~Q *)

  (* P->~Q, R->Q |- P->~R *)

  (* ~(P->Q) |- ~Q *)

  (* Séquents proposés en test par le passé *)

  Section Test01.

    Hypothesis H: P->Q.

    Lemma Ex01: ~(~Q->~P) -> R.
    intro.
    exfalso.
    unfold not in H0.
    apply H0.
    intros.
    apply H1.
    apply H.
    assumption.
    Qed.
  End Test01.

  Section Test02.
    Hypothesis H: ~(P->R).

    Lemma Ex02: Q->(P->Q->R)->P.
    intros.
    unfold not in H.
    exfalso.
    apply H.
    intro.
    apply H1.
    assumption.
    assumption.
    Qed.
  End Test02.

  Section Test03.
    Hypothesis H: ~(Q->R).

    Lemma Ex03: (P->Q->R)->(P->Q).
    intros.
    unfold not in H.
    exfalso.
    apply H.
    intro.
    apply H0.
    assumption.
    assumption.
    Qed.
  End Test03.

  Section Test04.
    Hypothesis H: ~~P.

    Lemma Ex04: Q->(P->Q->False)->P.
    unfold not in H.
    intros.
    exfalso.
    apply H.
    intro.
    apply H1.
    assumption.
    assumption.
    Qed.
  End Test04.

End Negation.


Require Export Poly.

Check (2 + 2 = 4).

Check (ble_nat 3 2 = false).

Check (2 + 2 = 5).

Theorem plus_2_2_is_4:
  2 + 2 = 4.
Proof. reflexivity. Qed.

Definition plus_fact :
  Prop := 2 + 2 = 4.
Check plus_fact.

Theorem plus_fact_is_true:
  plus_fact.
Proof. reflexivity. Qed.

Definition even (n:nat) : Prop :=
  evenb n = true.

Check even.
Check (even 4).
Check (even 3).

Definition even_n__even_SSn (n:nat) : Prop :=
  (even n) -> (even (S (S n))).

Definition between (n m o: nat) : Prop :=
  andb (ble_nat n o) (ble_nat o m) = true.

Definition teen : nat -> Prop := between 13 19.
Check teen.

Definition true_for_zero (P:nat -> Prop) : Prop := P 0.

Definition true_for_n__true_for_Sn (P:nat -> Prop) (n:nat) : Prop :=
  P n -> P (S n).

Definition preserved_by_S (P:nat -> Prop) : Prop :=
  forall n', P n' -> P (S n').

Definition true_for_all_numbers (P:nat -> Prop) : Prop :=
  forall n, P n.

Definition our_nat_induction (P:nat -> Prop) : Prop :=
  (true_for_zero P) ->
  (preserved_by_S P) ->
  (true_for_all_numbers P).

Check our_nat_induction.

Inductive good_day: day -> Prop :=
| gd_sat : good_day saturday
| gd_sun : good_day sunday.

Theorem gds : good_day sunday.
Proof.
  apply gd_sun.
Qed.

Inductive day_before: day -> day -> Prop :=
| db_tue : day_before tuesday monday
| db_wed : day_before wednesday tuesday
| db_thu : day_before thursday wednesday
| db_fri : day_before friday thursday
| db_sat : day_before saturday friday
| db_sun : day_before sunday saturday
| db_mon : day_before monday sunday.

Inductive fine_day_for_singing : day -> Prop :=
| fdfs_any : forall d:day, fine_day_for_singing d.

Theorem fdfs_wed : fine_day_for_singing wednesday.
Proof.
  apply fdfs_any.
Qed.

Inductive ok_day: day -> Prop :=
|okd_gd :
   forall d,
     good_day d -> ok_day d
|okd_before:
   forall d1 d2,
     ok_day d2 -> day_before d2 d1 -> ok_day d1.

Definition okdw : ok_day wednesday :=
  okd_before wednesday thursday
             (okd_before thursday friday
                         (okd_before friday saturday
                                     (okd_gd saturday gd_sat)
                                     db_sat)
                         db_fri)
             db_thu.

Theorem okdw': ok_day wednesday.
Proof.
  apply okd_before with (d2:=thursday).
  apply okd_before with (d2:=friday).
  apply okd_before with (d2:=saturday).
  apply okd_gd. apply gd_sat.
  apply db_sat.
  apply db_fri.
  apply db_thu.
Qed.

Definition okd_before2 := forall d1 d2 d3,
  ok_day d3 ->
  day_before d2 d1 ->
  day_before d3 d2 ->
  ok_day d1.

Theorem okd_before2_vaild : okd_before2.
Proof.
  unfold okd_before2.
  intros.
  generalize dependent H0.
  apply okd_before.
  generalize dependent H1.
  apply okd_before.
  apply H.
Qed.

Definition okd_before2_valid' : okd_before2 :=
  fun (d1 d2 d3 : day) =>
  fun (H : ok_day d3) =>
  fun (H0 : day_before d2 d1) =>
  fun (H1 : day_before d3 d2) =>
  okd_before d1 d2 (okd_before d2 d3 H H1) H0.

Print okd_before2_vaild.

Check nat_ind.

Theorem mult_0_r':
  forall n:nat, n * 0 = 0.
Proof.
  apply nat_ind.
  Case "0". reflexivity.
  Case "S". simpl. intros n IHn. apply IHn.
Qed.

Theorem plus_one_r':
  forall n:nat, n + 1 = S n.
Proof.
  apply nat_ind.
  Case "0".
  simpl. reflexivity.
  Case "S".
  simpl. intros n IHn. apply eq_remove_S. apply IHn.
Qed.

Inductive yesno: Type :=
| yes: yesno
| no: yesno.

Check yesno_ind.

Inductive rgb : Type :=
  | red : rgb
  | green : rgb
  | blue : rgb.
Check rgb_ind.

Inductive natlist: Type :=
| nnil : natlist
| ncons : nat -> natlist -> natlist.

Check natlist_ind.

Inductive natlist1 : Type :=
| nnil1 : natlist1
| ncons1 : natlist1 -> nat -> natlist1.

Check natlist1_ind.

Inductive ExSet : Type :=
| con1 : forall b:bool, ExSet
| con2 : nat -> ExSet -> ExSet.

Check ExSet_ind.

Inductive tree (X:Type) : Type :=
| leaf : X -> tree X
| node : tree X -> tree X -> tree X.

Check tree_ind.

Inductive mytype (X:Type) : Type :=
| constr1: X -> mytype X
| constr2: nat -> mytype X
| constr3: mytype X -> nat -> mytype X.

Check mytype_ind.

Inductive foo (X Y:Type) : Type :=
| bar: X -> foo X Y
| baz: Y -> foo X Y
| quux: (nat -> foo X Y) -> foo X Y.

Check foo_ind.

Inductive foo' (X:Type) : Type :=
| C1 : list X -> foo' X -> foo' X
| C2 : foo' X.

Check foo'_ind.

Definition P_m0r (n:nat) : Prop :=
  n * 0 = 0.

Definition P_m0r': nat -> Prop :=
  fun n => n * 0 = 0.

Theorem mult_0_r'' :
  forall n:nat, P_m0r n.
Proof.
  apply nat_ind.
  Case "n = 0". reflexivity.
  Case "n = S n".
  unfold P_m0r. simpl. intros n' IHn'.
  apply IHn'.
Qed.

Inductive ev : nat -> Prop :=
| ev_0: ev 0
| ev_SS: forall n:nat, ev n -> ev (S (S n)).

Theorem four_ev':
  ev 4.
Proof.
  apply ev_SS.
  apply ev_SS.
  apply ev_0.
Qed.

Print four_ev'.

Definition four_ev: ev 4 := ev_SS 2 (ev_SS 0 ev_0).

Theorem ev_plus4':
  forall n, ev n -> ev (4 + n).
Proof.
  apply ev_ind.
 (* Case "n=0". *)
  simpl. apply four_ev.
  (* Case "n = S n". *)
  simpl.
  intros.
  apply ev_SS.
  apply H0.
Qed.

Print ev_plus4'.

Definition ev_plus4 : forall n, ev n -> ev (4 + n) :=
  ev_ind (fun n : nat => ev (4 + n)) four_ev
         (fun (n : nat) (_ : ev n) (H0 : ev (S (S (S (S n))))) =>
            ev_SS (S (S (S (S n)))) H0).

Theorem double_even: forall n, ev (double n).
Proof.
  intros.
  induction n.
  simpl. apply ev_0.
  simpl. apply ev_SS. apply IHn.
Qed.

Print double_even.

Theorem ev_minus2:
  forall n, ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  destruct E as [| n' E'].
  Case "E = ev_0". simpl. apply ev_0.
  Case "E = ev_SS n' E'". simpl. apply E'. Qed.

Theorem ev_minus2_n:
  forall n, ev n -> ev (pred (pred n)).
  intros n E.
  destruct n as [| n'].
  Case "E = n". simpl. apply E.
  Case "E = S n". simpl.
  Restart.
  intros n E.
  destruct E as [| n' E'].
  Case "E = ev_0". simpl. apply ev_0.
  Case "E = ev_SS n' E'". simpl. apply E'. Qed.

Theorem ev_even:
  forall n, ev n -> even n.
Proof.
  intros n E. induction E as [| n' E'].
  Case "E = ev_0".
  unfold even. reflexivity.
  Case "E = ev_SS n' E'".
  unfold even. apply IHE'.
Qed.

Theorem ev_even_n:
  forall n, ev n -> even n.
Proof.
  intros n E. induction n as [| n' ].
  unfold even. simpl. reflexivity.
  unfold even.
Admitted.

Theorem ev_sum:
  forall n m, ev n -> ev m -> ev (n+m).
  intros n m En Em.
  induction En as [|n' En'].
  simpl. apply Em.
  simpl. apply ev_SS. apply IHEn'.
Qed.

Theorem SSev_ev_firsttry:
  forall n, ev (S (S n)) -> ev n.
Proof.
  intros n E.
  destruct E as [| n' E'].
Admitted.

Theorem SSev_even:
  forall n, ev (S (S n)) -> ev n.
  intros n E.
  inversion E as [| n' E'].
  apply E'.
Qed.

Theorem SSSSev_even:
  forall n, ev (S (S (S (S n)))) -> ev n.
  intros n E.
  inversion E as [| n' E'].
  apply SSev_even.
  apply E'.
Qed.

Theorem even5_nonsense :
  ev 5 -> 2 + 2 = 9.
Proof.
  intros.
  inversion H as [| n' H'].
  inversion H'.
  inversion H2.
Qed.

Theorem ev_minus2':
  forall n, ev n -> ev (pred (pred n)).
Proof.
  intros n E. inversion E as [| n' E'].
  Case "E = ev_0". simpl. apply ev_0.
  Case "E = ev_SS n' E'". simpl. apply E'.
Qed.

Theorem ev_ev_even:
  forall n m, ev (n+m) -> ev n -> ev m.
Proof.
  intros n m Hn Hm.
  induction Hm.
  apply Hn.
  apply IHHm.
  apply SSev_even.
  apply Hn.
Qed.

Theorem ev_plus_plus:
  forall n m p, ev (n + m) -> ev (n + p) -> ev (m + p).
Proof.
  intros n m p H.
  apply ev_ev_even.
  rewrite plus_swap. rewrite <- plus_assoc.
  rewrite plus_swap. rewrite plus_assoc.
  apply ev_sum. apply H.
  SearchAbout (_ + _).
  rewrite <- double_plus. apply double_even.
Qed.

Inductive MyProp : nat -> Prop :=
| MyProp1: MyProp 4
| MyProp2: forall n:nat, MyProp n -> MyProp (4 + n)
| MyProp3: forall n:nat, MyProp (2 + n) -> MyProp n.

Theorem MyProp_ten : MyProp 10.
Proof.
  apply MyProp3.
  simpl. assert(12=4+8) as H12.
  Case "Proof of assertion.". reflexivity.
  rewrite H12.
  apply MyProp2.
  assert(8=4+4) as H8.
  Case "Proof of assertion.". reflexivity.
  rewrite H8.
  apply MyProp2.
  apply MyProp1.
Qed.

Theorem MyProp_0: MyProp 0.
Proof.
  apply MyProp3. simpl.
  apply MyProp3. simpl.
  apply MyProp1.
Qed.

Theorem MyProp_plustwo :
  forall n:nat, MyProp n -> MyProp (S (S n)).
Proof.
  intros.
  rewrite <- plus_one_r'.
  rewrite <- plus_one_r'.
  rewrite <- plus_assoc.
  simpl.
  rewrite <- plus_comm.
  apply MyProp3.
  rewrite plus_assoc.
  rewrite <- plus_comm.
  simpl.
  rewrite <- plus_comm.
  apply MyProp2.
  apply H.
Qed.

Theorem MyProp_ev :
  forall n:nat, ev n -> MyProp n.
Proof.
  intros n E.
  induction E as [|n' E'].
  Case "E = ev_0".
  apply MyProp_0.
  Case "E = ev_SS n' E'".
  apply MyProp_plustwo.
  apply IHE'.
Qed.

(*
非形式的な証明.
定理: 任意の自然数nにおいて,ev nならばMyProp nが成り立つ
証明:
   n = 0のとき,MyProp 0は補題MyProp_0で成立
   n = S (S n')のとき,MyProp n'が成立すると仮定すると,
   MyProp  S (S n')は,MyProp_plustwoが成立するので,帰納法により定理は成立する.
 *)

Theorem ev_MyProp:
  forall n:nat, MyProp n -> ev n.
Proof.
  intros n P.
  induction P.
  Case "n = 4".
  apply four_ev.
  Case "n = 4 + n'".
  apply ev_plus4.
  apply IHP.
  Case "n = 2 + n'".
  simpl in IHP.
  apply SSev_even.
  apply IHP.
Qed.

Theorem plus_assoc' :
  forall n m p: nat, n+(m+p)=(n+m)+p.
Proof.
  intros n m p.
  induction n as [|n'].
  Case "n=0".
  simpl. reflexivity.
  Case "n=S n'".
  simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_comm' :
  forall n m : nat, n + m = m + n.
Proof.
  induction n as [|n'].
  Case "n=0".
  intro m. rewrite plus_0_r. simpl. reflexivity.
  Case "n=S n'".
  intro m. simpl.
  rewrite -> IHn'. rewrite <- plus_n_Sm. reflexivity.
Qed.

Theorem plus_comm'' :
  forall n m: nat, n + m = m + n.
  induction m as [| m'].
  Case "m = 0".
  simpl. rewrite -> plus_0_r. reflexivity.
  Case "m = S m".
  simpl. rewrite <- IHm'. rewrite <- plus_n_Sm. reflexivity.
Qed.

Check ev_ind.

Theorem ev_even':
  forall n:nat,ev n -> even n.
Proof.
  apply ev_ind.
  Case "ev_0". unfold even. reflexivity.
  Case "ev_SS". intros n' E' IHE'. unfold even. apply IHE'.
Qed.

Check list_ind.
Check MyProp_ind.

Theorem ev_MyProp':
  forall n:nat, MyProp n -> ev n.
Proof.
  apply MyProp_ind.
  Case "n = 4".
  apply four_ev.
  Case "n = 4 + n'".
  intros.
  apply ev_plus4.
  apply H0.
  Case "n = 2 + n".
  intros.
  simpl in H0.
  apply SSev_even.
  apply H0.
Qed.

Print ev_plus4'.

Print MyProp_ev.

Definition MyProp_ev' :
  forall n:nat, ev n -> MyProp n :=
  fun (n : nat) (E : ev n) =>
    ev_ind (fun n : nat => MyProp n) MyProp_0
           (fun (n' : nat) (_ : ev n') (H : MyProp n') => MyProp_plustwo n' H) n E.

Print ev_MyProp.
Print MyProp_ind.

Definition ev_MyProp'' :
  forall n : nat, MyProp n -> ev n :=
  fun (n : nat) (P : MyProp n) =>
    MyProp_ind (fun m : nat => ev m) four_ev
               (fun (m : nat) (_ : MyProp m) (H : ev m) => ev_plus4 m H)
               (fun (m : nat) (_ : MyProp (2 + m)) (H : ev (2 + m)) => SSev_even m H) n P.

Module Test.
Inductive foo (X : Set) (Y : Set) : Set :=
     | foo1 : X -> foo X Y
     | foo2 : Y -> foo X Y
     | foo3 : foo X Y -> foo X Y.
Check foo_ind.
End Test.

Inductive pal {X :Type}: list X -> Prop :=
| c0 : pal []
| c1 : forall n:X, pal [n]
| c2 : forall (n:X) (l:list X), pal l -> pal (n :: (snoc l n)).

Theorem pal_ref :
  forall {X:Type} (l:list X), pal (l ++ rev l).
  intros.
  induction l.
  Case "l = []".
  simpl.
  apply c0.
  Case "l = x::l'".
  simpl.
  rewrite <- snoc_with_append.
  apply c2.
  apply IHl.
Qed.

Lemma rev_involutive:
  forall {X:Type} (l:list X), rev (rev l) = l.
Proof.
  intros.
  induction l as [| n l'].
  Case "l=[]".
  simpl.
  reflexivity.
  Case "l=[n::l]".
  assert (H1:forall {X:Type} (n: X) (l:list X), rev (snoc l n) = n::rev l).
  intros.
  induction l as [|n0' l0'].
  SCase "l0=[]".
  simpl.
  reflexivity.
  SCase "l0=n0::l0'".
  simpl.
  rewrite -> IHl0'.
  simpl.
  reflexivity.
  simpl.
  rewrite->H1.
  rewrite->IHl'.
  reflexivity.
Qed.

Theorem pal_id_rev:
  forall {X:Type} (l:list X), pal l -> l = rev l.
Proof.
  intros.
  induction H.
  Case "l = []".
  simpl.
  reflexivity.
  Case "l = [n]".
  simpl.
  reflexivity.
  Case "l = [n::l::n]".
  rewrite IHpal.
  simpl.
  rewrite rev_snoc.
  simpl.
  rewrite -> rev_involutive.
  rewrite <- IHpal.
  reflexivity.
Qed.

Inductive subseq : list nat -> list nat -> Prop :=
| subseq_c1 : forall l, subseq [] l
| subseq_c2 : forall sl l n m, subseq (n::sl) l -> subseq (n::sl) (m::l)
| subseq_c3 : forall sl l n, subseq sl l -> subseq (n::sl) (n::l).

Check subseq.
Check (subseq [1,2,3] [1,2,3]).
Check subseq_c3.

Example subseq_ex1:
  subseq [] [1,2,3].
Proof.
  apply subseq_c1.
Qed.

Example subseq_ex2:
  subseq [1] [1,2,3].
Proof.
  apply subseq_c3.
  apply subseq_c1.
Qed.

Example subseq_ex3:
  subseq [1,2,3] [1,2,3].
Proof.
  apply subseq_c3.
  apply subseq_c3.
  apply subseq_c3.
  apply subseq_c1.
Qed.

Example subseq_ex4:
  subseq [1,2,3] [1,2,7,3].
Proof.
  apply subseq_c3.
  apply subseq_c3.
  apply subseq_c2.
  apply subseq_c3.
  apply subseq_c1.
Qed.

Example subseq_ex5:
  subseq [1,2,3] [5,6,1,9,9,2,7,3,8].
Proof.
  apply subseq_c2.
  apply subseq_c2.
  apply subseq_c3.
  apply subseq_c2.
  apply subseq_c2.
  apply subseq_c3.
  apply subseq_c2.
  apply subseq_c3.
  apply subseq_c1.
Qed.

Theorem subseq_involutive:
  forall s1 s2:list nat,  s1 s2 -> subseq s1 s2.
Proof.

Module Foo_Ind_principle.
  Inductive foo (X: Set) (Y: Set) : Set :=
  | foo1 : X -> foo X Y
  | foo2 : Y -> foo X Y
  | foo3 : foo X Y -> foo X Y.
  Check foo_ind.
End Foo_Ind_principle.

Module R.

  Inductive R : nat -> list nat -> Prop :=
  | c1 : R 0 []
  | c2 : forall n l, R n l -> R (S n) (n :: l)
  | c3 : forall n l, R (S n) l -> R n l.

  Check R.
  Check (R 1 [1,2,1,0]).
  Check (R 2 [1,0]).
  Check (R 6 [3,2,1,0]).

  Theorem r_1_list_1_2_1_0:
    R 1 [1,2,1,0].
  Proof.
    apply c3.
    apply c2.
    apply c3.
    apply c3.
    apply c2.
    apply c2.
    apply c2.
    apply c1.
  Qed.

  Theorem r_2_list_1_0:
    R 2 [1,0].
  Proof.
    apply c2.
    apply c2.
    apply c1.
  Qed.
End R.


(*
   CPS その1、リストの長さ (len_cps)
   2010_10_29
   *)

Require Export List.
Require Export Arith.

(**************)
(* Len        *)
(**************)

(* 再帰関数 *)
Fixpoint len (lst : list nat) :=
   match lst with
     | nil => 0
     | hd :: tl => S (len tl)
   end.
Eval cbv in len (1::2::3::4::nil).

(* CPS版 *)
Fixpoint len_cps (lst : list nat) (cont : nat -> nat) :=
   match lst with
     | nil => cont 0
     | hd :: tl => len_cps tl (fun x => cont (S x))
   end.
Eval cbv in len_cps (1::2::3::4::nil) (fun n:nat => n).

Lemma len_Sn :
  forall n l, len (n::l) = S (len l).
Proof.
  reflexivity.
Qed.

Eval cbv in len_cps (1::2::3::4::nil) (fun (r:nat) => r).  (* 4 *)
Eval cbv in len_cps (2::3::4::nil) (fun (r:nat) => S r).   (* 4 *)

Lemma len_cps_Sn :
  forall n l f,
    len_cps (n::l) f =
    len_cps l (fun (r:nat) => f (S r)).
Proof.
  intros.
  simpl.
  (* ここでGoalの左辺が右辺とおなじになるように、定理を用意するのだ。*)
  reflexivity.
Qed.

Lemma eq_len_len_cps_aux :
  forall (l : list nat) (a : nat),
    (forall f, f (len l) = (len_cps l f)) /\
    (forall g, g (len (a::l)) = len_cps (a::l) g).
Proof.
  intros.
  induction l.
  auto.

  destruct IHl.
  split.
  apply H0.

  intros.
  rewrite len_cps_Sn.
  rewrite len_Sn.
  simpl.
  rewrite <- H.
  reflexivity.
Qed.
Check eq_len_len_cps_aux.

Theorem eq_len_len_cps :
  forall (l : list nat) (n : nat) (f : nat -> nat), f (len l) = (len_cps l f).
Proof.
  intros.
  destruct (eq_len_len_cps_aux l n).
  apply H.
Qed.

(* END *)