Set Warnings "-notation-overridden,-parsing".
Require Export indprop.
Require Import Coq.omega.Omega.

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

Print le.

Check le : nat -> nat -> Prop.
Check le : relation nat.

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive next_nat (n : nat) : nat -> Prop :=
           nn : next_nat n (S n).

Check next_nat : relation nat.
Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.
Qed.

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
unfold not.
unfold partial_function.
intros.
assert (0 = 1) as Nonsense.
 {
    apply H with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n.
 }
  inversion Nonsense.
Qed.

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.
Theorem le_reflexive :
  reflexive le.
Proof.
unfold reflexive.
intros.
apply le_n.
Qed.

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).
Theorem le_trans :
  transitive le.
Proof.
unfold transitive.
intros.
induction H0.
assumption.
apply le_S.
apply IHle.
assumption.
Qed.

Theorem lt_trans:
  transitive lt.
Proof.
unfold transitive.
unfold lt.
intros.
apply le_S in H.
apply le_trans with
(a := (S a)) (b := (S b)) (c := c).
assumption. assumption.
Qed.

Theorem lt_trans' :
  transitive lt.
Proof.
unfold lt. unfold transitive.
intros n m o Hnm Hmo.
induction Hmo as [| m' Hm'o].
Admitted.

Theorem le_Sn_le : forall n m,
S n <= m -> n <= m.
Proof.
intros.
apply le_trans with (S n).
- apply le_S. apply le_n.
- assumption.
Qed.

Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
intros.
inversion H.
- apply le_n.
- apply le_Sn_le in H2.
assumption.
Qed.

Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
induction n.
- intros H.
inversion H.
- unfold not in IHn.
intros H. apply le_S_n in H.
apply IHn in H.
assumption.
Qed.

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
unfold not.
unfold symmetric.
intros.
assert (1<=0) as A.
- apply H. apply le_S. apply le_n.
- inversion A.
Qed.

Definition antisymmetric
{X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

Lemma Sn_eq_n : forall n m,
 n =  m -> S n = S m.
Proof.
Admitted.

Theorem le_antisymmetric :
  antisymmetric le.
Proof.
intros a b.
generalize dependent a.
induction b.
- intros. inversion H.
reflexivity.
- intros a. intros H H1.
destruct a.
+ inversion H1.
+ apply le_S_n in H1.
apply le_S_n in H.
apply Sn_eq_n.
apply IHb.
assumption. assumption.
Qed.

Lemma le_lt: forall n m,
n <= m -> n < S m.
Proof.
Admitted.

Lemma lt_le : forall n m,
n < S m -> n <= m.
Proof.
Admitted.

Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
intros n m p Hnm Hmp1.
  unfold lt in Hnm.
  assert (S n <= S p).
  apply le_trans with m.
  assumption.
  assumption.
  apply le_S_n.
  assumption.
Qed.

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).
(** order is patial order **)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
split.
- unfold reflexive. intros. apply le_n.
- split.
  +  unfold antisymmetric. intros.
     apply le_antisymmetric.
     assumption. assumption.
  +  apply le_trans.
Qed.

Inductive clos_refl_trans
{A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
split.
- intros. induction H.
 + apply rt_refl.
 + apply rt_trans with m.
   apply IHle. apply rt_step. apply nn.
- intros. induction H.
 + inversion H. apply le_S. apply le_n.
 + apply le_n.
 + apply le_trans with y.
   assumption. assumption.
Qed.

Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A) :
      R x y -> clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.

Lemma rsc_R : forall (X:Type)
(R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
intros.
apply rt1n_trans with y.
assumption.
apply rt1n_refl.
Qed.

Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof.
intros X R x y z.
replace (clos_refl_trans_1n R y z -> clos_refl_trans_1n R x z)
with (R x y).
intros.
Admitted.

Theorem rtc_rsc_coincide :
        forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof.
Admitted.


Require Import Omega.
Require Import Coq.ZArith.ZArith.
Require Import Coq.NArith.NArith.
Require Import Coq.Bool.Bool.
Local Open Scope Z_scope.

(** ** An omega that works for [N]

This is mostly to work around https://github.com/coq/coq/issues/6602.

*)

Ltac Nomega := rewrite ?N.pred_sub in *; zify; omega.

(** ** Utility lemmas about [Z], [N] and bits.

Some of these certainly could live in the standard library.

*)

(** *** The [nonneg] tactic *)

(**
We very often have to resolve non-negativity constraints, so we build
a tactic library for that.
*)

Lemma pos_nonneg: forall p, (0 <= N.pos p)%N.
Proof.
  compute; congruence.
Qed.

Lemma pos_pos: forall p, (0 < N.pos p)%N.
Proof.
  compute; congruence.
Qed.

Lemma succ_nonneg: forall n, 0 <= n -> 0 <= Z.succ n.
Proof. intros. omega. Qed.

Lemma ones_nonneg: forall n, 0 <= n -> 0 <= Z.ones n.
Proof.
  intros.
  unfold Z.ones.
  rewrite -> Z.shiftl_mul_pow2 by assumption.
  rewrite Z.mul_1_l.
  rewrite <- Z.lt_le_pred.
  apply Z.pow_pos_nonneg; auto.
  omega.
Qed.

Lemma log2_ones: forall n, 0 < n -> Z.log2 (Z.ones n) = Z.pred n.
  intros.
  unfold Z.ones.
  rewrite -> Z.shiftl_mul_pow2 by omega.
  rewrite Z.mul_1_l.
  apply Z.log2_pred_pow2.
  assumption.
Qed.

Create HintDb nonneg.
Hint Immediate N2Z.is_nonneg : nonneg.
Hint Immediate pos_nonneg : nonneg.
Hint Resolve N.le_0_l : nonneg.
Hint Resolve Z.log2_nonneg : nonneg.
Hint Resolve ones_nonneg : nonneg.
Hint Resolve succ_nonneg : nonneg.
Hint Resolve <- Z.shiftl_nonneg : nonneg.
Hint Resolve <- Z.shiftr_nonneg : nonneg.
Hint Resolve <- Z.land_nonneg : nonneg.
Hint Resolve Z.pow_nonneg : nonneg.
Hint Extern 1 (0 <= Z.succ (Z.pred (Z.of_N _))) => rewrite Z.succ_pred : nonneg.
Hint Resolve <- Z.lxor_nonneg : nonneg.
Hint Extern 0 => omega : nonneg.

Ltac nonneg := solve [auto with nonneg].

Lemma N_gt_0_neq:
  forall n, (n <> 0 <-> 0 < n)%N.
Proof.
  intros.
  destruct n; intuition.
  * inversion H.
  * apply pos_pos.
  * inversion H0.
Qed.

(** *** Lemmas about [N] and [Z], especially related to bits *)

Lemma N_lt_pow2_testbits:
  forall n p, (n < 2^p)%N <-> (forall j, (p <= j)%N -> N.testbit n j = false).
Proof.
  intros.
  etransitivity.
  * symmetry. apply N.div_small_iff.
    apply N.pow_nonzero; congruence.
  * rewrite <- N.shiftr_div_pow2.
    rewrite <- N.bits_inj_iff.
    split; intros H j.
    + intro.
      specialize (H (j - p)%N).
      rewrite N.shiftr_spec, N.bits_0 in * by nonneg.
      rewrite N.sub_add in H by assumption.
      assumption.
    + rewrite N.shiftr_spec, N.bits_0 by nonneg.
      apply H.
      change (0 + p <= j + p)%N.
      apply N.add_le_mono_r.
      nonneg.
Qed.

(* exists for Z, but not for N? *)
Lemma N_pow_pos_nonneg: forall a b : N, (0 < a -> 0 < a ^ b)%N.
Proof.
  intros.
  apply N.peano_ind with (n := b); intros.
  * simpl. reflexivity.
  * rewrite N.pow_succ_r; [|apply N.le_0_l].
    eapply N.lt_le_trans. apply H0.
    replace (a ^ n)%N  with (1 * a^n)%N at 1 by (apply N.mul_1_l).
    apply N.mul_le_mono_pos_r; auto.
    rewrite <- N.le_succ_l in H.
    apply H.
Qed.

Lemma ones_spec:
  forall n m : Z, 0 <= n -> Z.testbit (Z.ones n) m = (0 <=? m) && (m <? n).
Proof.
  intros.
  destruct (Z.leb_spec 0 m), (Z.ltb_spec m n);
    simpl; try apply not_true_is_false;
    rewrite Z.ones_spec_iff; omega.
Qed.

Lemma lor_ones_ones: forall b1 b2, 0 <= b1 -> 0 <= b2 ->
  Z.lor (Z.ones b1) (Z.ones b2) = Z.ones (Z.max b1 b2).
Proof.
  intros.
  apply Z.bits_inj'. intros z?.
  rewrite -> Z.lor_spec.
  repeat rewrite -> ones_spec by (try rewrite Z.max_le_iff; auto).
  destruct (Z.leb_spec 0 z), (Z.ltb_spec z b1), (Z.ltb_spec z b2), (Z.ltb_spec z (Z.max b1 b2)),  (Zmax_spec b1 b2); intuition; simpl; try omega.
Qed.

Lemma to_N_log2: forall i, Z.to_N (Z.log2 i) = N.log2 (Z.to_N i).
Proof.
  intros.
  destruct i; try reflexivity.
  destruct p; try reflexivity.
Qed.

Lemma of_N_log2: forall n, Z.of_N (N.log2 n) = Z.log2 (Z.of_N n).
Proof.
  intros.
  destruct n; try reflexivity.
  destruct p; try reflexivity.
Qed.

(* This is a stronger version than what’s in the standard library *)
Lemma log2_le_lin': forall a : N, (* (0 <= a)%N -> *) (N.log2 a <= a)%N.
Proof. intros.
  destruct a.
  reflexivity.
  apply N.log2_le_lin.
  nonneg.
Qed.

Lemma N_land_pow2_testbit:
  forall n i, negb (N.land (2 ^ i) n =? 0)%N = N.testbit n i.
Proof.
  intros.
  destruct (N.testbit n i) eqn:Htb.
  * rewrite negb_true_iff.
    rewrite N.eqb_neq.
    contradict Htb.
    assert (N.testbit (N.land (2^i)%N n) i = false)
     by (rewrite Htb; apply N.bits_0).
    rewrite N.land_spec in H. rewrite N.pow2_bits_true in H.
    simpl in H. congruence.
  * rewrite negb_false_iff.
    rewrite N.eqb_eq.
    apply N.bits_inj.
    intro j.
    rewrite N.land_spec.
    rewrite N.pow2_bits_eqb.
    destruct (N.eqb_spec i j); subst; intuition.
Qed.

Lemma land_pow2_eq:
  forall i b, 0 <= b -> (Z.land i (2 ^ b) =? 0) = (negb (Z.testbit i b)).
Proof.
  intros ?? Hnonneg.
  destruct (Z.testbit i b) eqn:Htb; simpl.
  * rewrite Z.eqb_neq.
    contradict Htb.
    assert (Z.testbit (Z.land i (2^b)) b = false)
     by (rewrite Htb; apply Z.bits_0).
    rewrite Z.land_spec in H. rewrite Z.pow2_bits_true in H.
    rewrite andb_true_r in H.
    simpl in H. congruence.
    nonneg.
  * rewrite Z.eqb_eq.
    apply Z.bits_inj'.
    intros j ?.
    rewrite  Z.bits_0.
    rewrite Z.land_spec.
    rewrite Z.pow2_bits_eqb.
    destruct (Z.eqb_spec b j).
    + subst. rewrite Htb. reflexivity.
    + rewrite andb_false_r.  reflexivity.
    + nonneg.
Qed.

Lemma N_land_pow2_eq:
  forall i b, (N.land i (2 ^ b) =? 0)%N = negb (N.testbit i b).
Proof.
  intros ??.
  destruct (N.testbit i b) eqn:Htb; simpl.
  * rewrite N.eqb_neq.
    contradict Htb.
    assert (N.testbit (N.land i (2^b)) b = false)
     by (rewrite Htb; apply N.bits_0).
    rewrite N.land_spec in H. rewrite N.pow2_bits_true in H.
    rewrite andb_true_r in H.
    simpl in H. congruence.
  * rewrite N.eqb_eq.
    apply N.bits_inj.
    intros j.
    rewrite N.bits_0.
    rewrite N.land_spec.
    rewrite N.pow2_bits_eqb.
    destruct (N.eqb_spec b j).
    + subst. rewrite Htb. reflexivity.
    + rewrite andb_false_r.  reflexivity.
Qed.

Lemma shiftr_eq_ldiff :
forall n m b,
    0 <= b ->
    Z.ldiff n (Z.ones b) = Z.ldiff m (Z.ones b) ->
    Z.shiftr n b = Z.shiftr m b.
Proof.
  intros.
    * apply Z.bits_inj'.
      intros i ?.
      rewrite -> !Z.shiftr_spec by assumption.
      apply Z.bits_inj_iff in H0.
      specialize (H0 (i + b)).
      rewrite -> !Z.ldiff_spec in H0.
      rewrite -> !Z.ones_spec_high in H0.
      simpl in *.
      rewrite -> ! andb_true_r in H0.
      assumption.
      omega.
Qed.

Lemma Z_shiftl_inj:
  forall x y n,
    0 <= n ->
    Z.shiftl x n = Z.shiftl y n <-> x = y.
Proof.
  intros; split; intro.
  * apply Z.bits_inj'.
    intros i ?.
    apply Z.bits_inj_iff in H0.
    specialize (H0 (i + n)).
    do 2 rewrite -> Z.shiftl_spec in H0 by omega.
    replace (i + n - n) with i in H0 by omega.
    assumption.
  * apply Z.bits_inj'.
    intros i ?.
    apply Z.bits_inj_iff in H0.
    specialize (H0 (i - n)).
    do 2 rewrite -> Z.shiftl_spec by omega.
    assumption.
Qed.

Lemma N_shiftl_inj:
  forall x y n,
    N.shiftl x n = N.shiftl y n <-> x = y.
Proof.
  intros; split; intro.
  * apply N.bits_inj.
    intros i.
    apply N.bits_inj_iff in H.
    specialize (H (i + n)%N).
    do 2 rewrite -> N.shiftl_spec_alt in H by omega.
    assumption.
  * subst. reflexivity.
Qed.

Lemma land_shiftl_ones:
  forall i n, 0 <= n -> Z.land (Z.shiftl i n) (Z.ones n) = 0.
Proof.
  intros.
  apply Z.bits_inj'.
  intros j ?.
  rewrite Z.land_spec.
  rewrite -> Z.shiftl_spec by nonneg.
  rewrite Z.bits_0. rewrite andb_false_iff.
  destruct (Z.ltb_spec j n).
  * left. apply Z.testbit_neg_r. omega.
  * right. apply Z.ones_spec_high. omega.
Qed.

Lemma N_land_shiftl_ones:
  forall i n, N.land (N.shiftl i n) (N.ones n) = 0%N.
Proof.
  intros.
  apply N.bits_inj.
  intros j.
  rewrite N.land_spec.
  rewrite N.bits_0. rewrite andb_false_iff.
  destruct (N.ltb_spec j n).
  * left. rewrite -> N.shiftl_spec_low by assumption. reflexivity.
  * right. apply N.ones_spec_high. assumption.
Qed.

Lemma N_shiftl_spec_eq:
  forall n i j,
  N.testbit (N.shiftl n i) j =
    (if j <? i then false else N.testbit n (j - i))%N.
Proof.
  intros.
  destruct (N.ltb_spec j i).
  * apply N.shiftl_spec_low; assumption.
  * apply N.shiftl_spec_high'; assumption.
Qed.

Lemma Z_shiftl_add:
  forall x y i,
  (0 <= i) ->
  Z.shiftl (x + y) i = Z.shiftl x i + Z.shiftl y i.
Proof.
  intros.
  rewrite !Z.shiftl_mul_pow2 by assumption.
  rewrite Z.mul_add_distr_r.
  reflexivity.
Qed.

Lemma N_shiftl_add:
  forall x y i,
  N.shiftl (x + y)%N i = (N.shiftl x i + N.shiftl y i)%N.
Proof.
  intros.
  rewrite !N.shiftl_mul_pow2 by assumption.
  rewrite N.mul_add_distr_r.
  reflexivity.
Qed.

Lemma testbit_1:
  forall i, Z.testbit 1 i = (i =? 0).
Proof.
  intros.
  replace 1 with (2^0) by reflexivity.
  rewrite -> Z.pow2_bits_eqb by reflexivity.
  apply Z.eqb_sym.
Qed.

Lemma N_testbit_1:
  forall i, N.testbit 1 i = (i =? 0)%N.
Proof.
  intros.
  replace 1%N with (2^0)%N by reflexivity.
  rewrite -> N.pow2_bits_eqb by reflexivity.
  apply N.eqb_sym.
Qed.

(* This lemma shows that the way the code gets the upper bits above a one-bit-mask
  is correct *)
Lemma mask_to_upper_bits:
forall b,
  0 <= b ->
  (Z.lxor (Z.lnot (Z.pred (2 ^ b))) (2 ^ b)) =
  Z.lnot (Z.ones (Z.succ b)).
Proof.
  intros.
  rewrite <- Z.ones_equiv.
  rewrite <- Z.lnot_lxor_l.
  apply Z.bits_inj_iff'. intros j?.
  rewrite -> Z.lnot_spec by nonneg.
  rewrite -> Z.lnot_spec by nonneg.
  rewrite -> Z.lxor_spec.
  rewrite -> ones_spec by nonneg.
  rewrite -> ones_spec by nonneg.
  rewrite -> Z.pow2_bits_eqb by nonneg.
  destruct (Z.leb_spec 0 j), (Z.ltb_spec j b), (Z.ltb_spec j (Z.succ b)), (Z.eqb_spec b j);
    simpl; try congruence; omega.
Qed.

Lemma of_N_shiftl:
  forall n i, Z.of_N (N.shiftl n i) = Z.shiftl (Z.of_N n) (Z.of_N i).
Proof.
  intros.
  apply Z.bits_inj_iff'; intros j?.
  replace j with (Z.of_N (Z.to_N j))
    by (rewrite -> Z2N.id by assumption; reflexivity).
  rewrite N2Z.inj_testbit.
  destruct (N.leb_spec i (Z.to_N j)).
  * rewrite -> N.shiftl_spec_high' by assumption.
    rewrite -> Z.shiftl_spec by nonneg.
    rewrite <- N2Z.inj_sub by assumption.
    rewrite N2Z.inj_testbit.
    reflexivity.
  * rewrite -> N.shiftl_spec_low by assumption.
    rewrite -> Z.shiftl_spec_low by Nomega.
    reflexivity.
Qed.

Lemma Z_eq_shiftr_land_ones:
  forall i1 i2 b,
  (i1 =? i2) = (Z.shiftr i1 b =? Z.shiftr i2 b) && (Z.land i1 (Z.ones b) =? Z.land i2 (Z.ones b)).
Proof.
  intros.
  match goal with [ |- ?b1 = ?b2 ] => destruct b1 eqn:?, b2 eqn:? end; try congruence.
  * contradict Heqb1.
    rewrite not_false_iff_true.
    rewrite andb_true_iff.
    repeat rewrite -> Z.eqb_eq in *; subst.
    auto.
  * contradict Heqb0.
    rewrite not_false_iff_true.
    rewrite -> andb_true_iff in Heqb1.
    destruct Heqb1.
    repeat rewrite -> Z.eqb_eq in *; subst.
    apply Z.bits_inj_iff'. intros j ?.
    destruct (Z.ltb_spec j b).
    + apply Z.bits_inj_iff in H0.
      specialize (H0 j).
      repeat rewrite -> Z.land_spec in H0.
      rewrite -> Z.ones_spec_low in H0.
      do 2 rewrite andb_true_r in H0.
      assumption.
      omega.
    + apply Z.bits_inj_iff in H.
      specialize (H (j - b)).
      do 2 rewrite -> Z.shiftr_spec in H by omega.
      replace (j - b + b) with j in H by omega.
      assumption.
Qed.

Lemma N_eq_shiftr_land_ones:
  forall i1 i2 b,
  (i1 =? i2)%N = (N.shiftr i1 b =? N.shiftr i2 b)%N && (N.land i1 (N.ones b) =? N.land i2 (N.ones b))%N.
Proof.
  intros.
  match goal with [ |- ?b1 = ?b2 ] => destruct b1 eqn:?, b2 eqn:? end; try congruence.
  * contradict Heqb1.
    rewrite not_false_iff_true.
    rewrite andb_true_iff.
    repeat rewrite -> N.eqb_eq in *; subst.
    auto.
  * contradict Heqb0.
    rewrite not_false_iff_true.
    rewrite -> andb_true_iff in Heqb1.
    destruct Heqb1.
    repeat rewrite -> N.eqb_eq in *; subst.
    apply N.bits_inj_iff. intros j.
    destruct (N.ltb_spec j b).
    + apply N.bits_inj_iff in H0.
      specialize (H0 j).
      repeat rewrite -> N.land_spec in H0.
      rewrite -> N.ones_spec_low in H0 by assumption.
      do 2 rewrite andb_true_r in H0.
      assumption.
    + apply N.bits_inj_iff in H.
      specialize (H (j - b)%N).
      do 2 rewrite -> N.shiftr_spec in H by Nomega.
      replace (j - b + b)%N with j in H by Nomega.
      assumption.
Qed.

Lemma Pos_1_testbit_succ:
  forall p i,
  Pos.testbit p~1 (N.succ i) = Pos.testbit p i.
Proof.
  induction i.
  * reflexivity.
  * simpl. rewrite Pos.pred_N_succ. reflexivity.
Qed.

Lemma Pos_0_testbit_succ:
  forall p i,
  Pos.testbit p~0 (N.succ i) = Pos.testbit p i.
Proof.
  induction i.
  * reflexivity.
  * simpl. rewrite Pos.pred_N_succ. reflexivity.
Qed.

Lemma N_bits_impl_le:
  forall a b,
  (forall i, N.testbit a i = true -> N.testbit b i = true) ->
  (a <= b)%N.
Proof.
  intros.
  induction a; try apply N.le_0_l.
  destruct b.
  * exfalso.
    refine (Pbit_faithful_0 p _).
    intro j.
    specialize (H (N.of_nat j)).
    rewrite N.bits_0 in H.
    simpl in H; rewrite Ptestbit_Pbit in H.
    destruct (Pos.testbit_nat p j) eqn:?; intuition.
  * simpl in *.
    change (Pos.le p p0).
    revert p0 H.
    induction p; intros p0 H.
    - destruct p0 eqn:?.
      + change (p <= p1)%positive.
        apply IHp. intro i.
        specialize (H (N.succ i)).
        rewrite !Pos_1_testbit_succ in H.
        assumption.
      + exfalso.
        specialize (H 0%N).
        simpl in H. intuition congruence.
      + exfalso.
        refine (Pbit_faithful_0 p _).
        intro j.
        specialize (H (N.succ (N.of_nat j))).
        rewrite <- Nat2N.inj_succ in H at 2.
        rewrite Pos_1_testbit_succ, Ptestbit_Pbit in H.
        destruct (Pos.testbit_nat p j) eqn:?; intuition.
    - destruct p0 eqn:?.
      + transitivity (p1~0)%positive.
        ** change (p <= p1)%positive.
          apply IHp. intro i.
          specialize (H (N.succ i)).
          rewrite Pos_0_testbit_succ, Pos_1_testbit_succ in H.
          assumption.
        ** zify. omega.
      + change (p <= p1)%positive.
        apply IHp. intro i.
        specialize (H (N.succ i)).
        rewrite !Pos_0_testbit_succ in H.
        assumption.
      + exfalso.
        refine (Pbit_faithful_0 p _).
        intro j.
        specialize (H (N.succ (N.of_nat j))).
        rewrite <- Nat2N.inj_succ in H at 2.
        rewrite Pos_0_testbit_succ, Ptestbit_Pbit in H.
        destruct (Pos.testbit_nat p j) eqn:?; intuition.
     - apply Pos.le_1_l.
Qed.

Lemma clearbit_le:
  forall a i,
  (N.clearbit a i <= a)%N.
Proof.
  intros.
  apply N_bits_impl_le; intros j H.
  rewrite N.clearbit_eqb in H.
  rewrite andb_true_iff in *.
  intuition.
Qed.

Lemma clearbit_lt:
  forall a i,
  N.testbit a i = true ->
  (N.clearbit a i < a)%N.
Proof.
  intros.
  apply N.le_neq; split.
  * apply clearbit_le.
  * intro.
    apply N.bits_inj_iff in H0. specialize (H0 i).
    rewrite N.clearbit_eqb in H0.
    rewrite N.eqb_refl in H0.
    simpl negb in H0.
    rewrite andb_false_r in H0.
    congruence.
Qed.

Lemma ldiff_le:
  forall a b,
  (N.ldiff a b <= a)%N.
Proof.
  intros.
  apply N_bits_impl_le; intros i H.
  rewrite N.ldiff_spec in *.
  rewrite andb_true_iff in *.
  intuition.
Qed.

Lemma ldiff_lt:
  forall a b i,
  N.testbit a i = true ->
  N.testbit b i = true ->
  (N.ldiff a b < a)%N.
Proof.
  intros.
  apply N.le_neq; split.
  * apply ldiff_le.
  * intro.
    apply N.bits_inj_iff in H1. specialize (H1 i).
    rewrite N.ldiff_spec in H1.
    rewrite H, H0 in H1.
    inversion H1.
Qed.

Lemma ldiff_pow2_lt:
  forall a i,
  N.testbit a i = true ->
  (N.ldiff a (2^i) < a)%N.
Proof.
  intros.
  apply ldiff_lt with (i := i); auto.
  apply N.pow2_bits_true.
Qed.

Lemma clearbit_log2_mod:
  forall bm,
  (0 < bm)%N ->
  N.clearbit bm (N.log2 bm)%N = (bm mod (2 ^ N.log2 bm))%N.
Proof.
  intros.
  apply N.bits_inj. intro i.
  rewrite N.clearbit_eqb.
  destruct (N.eqb_spec (N.log2 bm) i); simpl negb; [|destruct (N.ltb_spec i (N.log2 bm))].
  * rewrite N.mod_pow2_bits_high by Nomega.
    simpl negb.
    apply andb_false_r.
  * rewrite N.mod_pow2_bits_low by assumption.
    apply andb_true_r.
  * rewrite N.mod_pow2_bits_high by assumption.
    rewrite N.bits_above_log2 by Nomega.
    apply andb_true_r.
Qed.

Lemma clearbit_pow2_0:
  forall n, (N.clearbit (2 ^ n) n = 0)%N.
Proof.
  intros.
  rewrite N.clearbit_spec'.
  apply N.ldiff_diag.
Qed.

Lemma clearbit_clearbit_comm:
  forall a i j, N.clearbit (N.clearbit a i) j =  N.clearbit (N.clearbit a j) i.
Proof.
  intros.
  rewrite !N.clearbit_spec'.
  rewrite !N.ldiff_ldiff_l.
  rewrite N.lor_comm at 1.
  reflexivity.
Qed.

(** ** Most significant differing bit

Only properly defined if both arguments are non-negative.
*)

Definition msDiffBit : N -> N -> N :=
  fun n m => (N.log2 (N.lxor n m) + 1)%N.

Lemma msDiffBit_sym: forall p1 p2,
  msDiffBit p1 p2 = msDiffBit p2 p1.
Proof.
  intros.
  unfold msDiffBit.
  rewrite N.lxor_comm.
  reflexivity.
Qed.

Section msDiffBit.
  Variable p1 p2 : N.
  Variable (Hne : p1 <> p2).

  Local Lemma lxor_pos: (0 < N.lxor p1 p2)%N.
  Proof.
    assert (0 <= N.lxor p1 p2)%N by nonneg.
    enough (N.lxor p1 p2 <> 0)%N by Nomega.
    rewrite N.lxor_eq_0_iff.
    assumption.
  Qed.

  Lemma msDiffBit_Different:
        N.testbit p1 (msDiffBit p1 p2 - 1)
     <> N.testbit p2 (msDiffBit p1 p2 - 1).
  Proof.
    match goal with [ |- N.testbit ?x ?b <> N.testbit ?y ?b] =>
      enough (xorb (N.testbit x b) (N.testbit y b) = true)
      by (destruct (N.testbit x b), (N.testbit y b); simpl in *; congruence) end.
    rewrite <- N.lxor_spec.
    unfold msDiffBit.
    rewrite N.add_sub.
    apply N.bit_log2.
    rewrite N.lxor_eq_0_iff.
    assumption.
  Qed.

  Lemma msDiffBit_Same:
    forall j, (msDiffBit p1 p2 <= j)%N ->
    N.testbit p1 j = N.testbit p2 j.
  Proof.
    intros.
    match goal with [ |- N.testbit ?x ?b = N.testbit ?y ?b] =>
      enough (xorb (N.testbit x b) (N.testbit y b) = false)
      by (destruct (N.testbit x b), (N.testbit y b); simpl in *; congruence) end.
    rewrite <- N.lxor_spec.
    unfold msDiffBit in H.
    apply N.bits_above_log2.
    Nomega.
  Qed.

  Lemma msDiffBit_shiftr_same:
        N.shiftr p1 (msDiffBit p1 p2)
     =  N.shiftr p2 (msDiffBit p1 p2).
  Proof.
    apply N.bits_inj_iff. intros j.
    rewrite -> !N.shiftr_spec by nonneg.
    apply msDiffBit_Same.
    Nomega.
  Qed.
End msDiffBit.

Lemma msDiffBit_less:
  forall z1 z2 b,
    z1 <> z2 ->
    N.shiftr z1 b = N.shiftr z2 b ->
    (msDiffBit z1 z2 <= b)%N.
Proof.
  intros.
  unfold msDiffBit.
  enough (N.log2 (N.lxor z1 z2) < b)%N
    by (apply N2Z.inj_le; Nomega).
  rewrite <- N.lxor_eq_0_iff in H0.
  rewrite <- N.shiftr_lxor in H0.
  apply N.shiftr_eq_0_iff in H0.
  rewrite -> N.lxor_eq_0_iff in H0.
  intuition.
Qed.


(* Exercise coq_tree_03 *)

(* Let us start with the definitions from the previous
   exercises *)

Inductive nat_tree : Set :=
  | leaf : nat_tree
  | node : nat_tree -> nat -> nat_tree -> nat_tree.

Fixpoint mirror (T : nat_tree) : nat_tree :=
  match T with
  | leaf => leaf
  | node l n r => node (mirror r) n (mirror l)
  end.

(* Now let us prove that taking mirror image of a tree
   twice returs the original tree. *)

Lemma mirror_double : forall T, mirror (mirror T) = T.
Proof.
intros.
induction T.
* simpl; reflexivity.
* simpl.
  rewrite IHT1.
  rewrite IHT2.
  reflexivity.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Program.Tactics.
Require Import Coq.Program.Wf.
Require Import Omega.

Import ListNotations.

Inductive sorted : list nat -> Prop :=
| SortedEmpty : sorted [ ]
| SortedSingleton : forall n, sorted [n]
| SortedInd : forall n m l,
    n <= m -> sorted (m :: l) -> sorted (n :: m :: l).

Module HeapSort.

  Inductive bintree : Type :=
  | Leaf : nat -> bintree
  | Left : nat -> bintree -> bintree
  | Right : nat -> bintree -> bintree
  | Fork : nat -> bintree -> bintree -> bintree.

  Fixpoint height (t:bintree) : nat :=
    match t with
    | Leaf _ => 0
    | Left _ c1 => S (height c1)
    | Right _ c2 => S (height c2)
    | Fork _ c1 c2 => S (Nat.max (height c1) (height c2))
    end.

  Fixpoint vertices (t:bintree) : nat :=
    match t with
    | Leaf _ => 1
    | Left _ c1 => S (vertices c1)
    | Right _ c2 => S (vertices c2)
    | Fork _ c1 c2 => (vertices c1) + (vertices c2) + 1
    end.

  Definition root (t:bintree) : nat :=
    match t with
    | Leaf n => n
    | Left n _ => n
    | Right n _ => n
    | Fork n _ _ => n
    end.

  Inductive perfect : bintree -> Prop :=
  | PerfectSingleton : forall n,
      perfect (Leaf n)
  | PerfectInd : forall n t1 t2,
      perfect t1 ->
      perfect t2 ->
      height t1 = height t2 ->
      perfect (Fork n t1 t2).

  Lemma sum_pos : forall a b,
      a > 0 -> a + b > 0.
  Proof.
    intros a b. omega.
  Qed.

  Lemma product_pos : forall a b,
      a > 0 -> b > 0 -> a * b > 0.
  Proof.
    intros a b Ha. induction b as [| b' IHb' ].
    - intros Hb. inversion Hb.
    - intros Hb. replace (a * S b') with (a + a * b').
      apply sum_pos. assumption.
      (* a * S b' = a + a * b' *) rewrite <- mult_n_Sm. omega.
  Qed.

  Lemma pow_pos : forall a n,
      a > 0 -> a ^ n > 0.
  Proof.
    intros a n H. induction n as [| n' IHn' ].
    - simpl. omega.
    - simpl. remember (a ^ n') as k. apply product_pos.
      assumption. assumption.
  Qed.

  Proposition vertices_of_perfect_bintree : forall t,
      perfect t ->
      vertices t = (Nat.pow 2 (height t + 1)) - 1.
  Proof.
    intros t E. induction E.
    - (* PerfectSingleton *)
      reflexivity.
    - (* PerfectInd *)
      simpl. replace (height t2) with (height t1).
      rewrite max_l. replace (vertices t2) with (vertices t1).
      rewrite IHE1.
      assert (Lem: 2 ^ (height t1 + 1) > 0).
      { apply pow_pos. omega. }
      remember (2 ^ (height t1 + 1)) as k. omega.
      (* vertices t1 = vertices t2 *)
      rewrite IHE1. rewrite IHE2. rewrite H. reflexivity.
      (* height t1 <= height t2 *) omega.
  Qed.

  Fixpoint perfb (t:bintree) : bool :=
    match t with
    | Leaf _ => true
    | Left _ _ => false
    | Right _ _ => false
    | Fork _ t1 t2 =>
      (height t1 =? height t2) && perfb t1 && perfb t2
    end.

  Proposition perfb_true_iff : forall t,
      perfect t <-> perfb t = true.
  Proof.
    intros t. split.
    - (* -> *)
      intros E. induction E.
      + (* t = Leaf n *)
        reflexivity.
      + (* t = Inner n t1 t2 *)
        simpl. rewrite H. rewrite IHE1. rewrite IHE2.
        replace (height t2 =? height t2) with true. reflexivity.
        (* goal: height t2 =? height t2 *) apply beq_nat_refl.
    - (* <- *)
      induction t as [n | n t1 | n t2 | n t1 IHt1 t2 IHt2].
      + intros. apply PerfectSingleton.
      + (* contradiction *) intros contra. inversion contra.
      + (* contradiciton *) intros contra. inversion contra.
      + intros H. simpl in H.
        apply andb_prop in H. destruct H as [H Ht2].
        apply andb_prop in H. destruct H as [Hheight Ht1].
        apply PerfectInd.
        * apply IHt1. apply Ht1.
        * apply IHt2. apply Ht2.
        * apply beq_nat_true_iff. apply Hheight.
  Qed.

  Inductive complete : bintree -> Prop :=
  | CompleteSingleton : forall n,
      complete (Leaf n)
  | CompleteLeft : forall n m,
      complete (Left n (Leaf m))
  | CompleteA : forall n t1 t2,
      height t1 = height t2 + 1 ->
      complete t1 ->
      perfect t2 ->
      complete (Fork n t1 t2)
  | CompleteB : forall n t1 t2,
      height t1 = height t2 ->
      perfect t1 ->
      complete t2 ->
      complete (Fork n t1 t2).

  Proposition perfect_imp_complete : forall t,
      perfect t -> complete t.
  Proof.
    intros t E. induction E.
    - (* PerfectSingleton *)
      apply CompleteSingleton.
    - (* PerfectInd *)
      apply CompleteB; assumption.
  Qed.

  Inductive sat_heap_prop : bintree -> Prop :=
  | SatHPSingle : forall n,
      sat_heap_prop (Leaf n)
  | SatHPLeft : forall n t1,
      sat_heap_prop t1 ->
      root t1 <= n ->
      sat_heap_prop (Left n t1)
  | SatHPRight : forall n t2,
      sat_heap_prop t2 ->
      root t2 <= n ->
      sat_heap_prop (Right n t2)
  | SatHPFork : forall n t1 t2,
      sat_heap_prop t1 ->
      sat_heap_prop t2 ->
      root t1 <= n ->
      root t2 <= n ->
      sat_heap_prop (Fork n t1 t2).

  Fixpoint max_vertex (t:bintree) : nat :=
    match t with
    | Leaf n => n
    | Left n t1 =>
      Nat.max n (max_vertex t1)
    | Right n t2 =>
      Nat.max n (max_vertex t2)
    | Fork n t1 t2 =>
      Nat.max n (Nat.max (max_vertex t1) (max_vertex t2))
    end.

  Lemma max_upper : forall a b m,
      a <= m -> b <= m -> Nat.max a b <= m.
  Proof.
    intros a b m Ea. generalize dependent b.
    induction Ea.
    - (* a = m *)
      intros b Eb. induction Eb.
      + (* b = a *)
        replace (Nat.max b b) with b. apply le_n.
        (* goal: b = Nat.max b b *)
        symmetry. apply max_l. apply le_n.
      + (* b <= m - 1 *)
        replace (Nat.max (S m) b) with (S m). apply le_n.
        (* goal: S m = Nat.max (S m) b *)
        symmetry. apply max_l. apply le_S. apply Eb.
    - (* a <= m - 1 *)
      intros b Eb. inversion Eb.
      + replace (Nat.max a (S m)) with (S m). apply le_n.
        (* goal : S m = Nat.max a (S m) *)
        symmetry. apply max_r. apply le_S. apply Ea.
      + subst. apply le_S. apply IHEa. assumption.
  Qed.

  Proposition heap_prop_max : forall t,
      sat_heap_prop t -> max_vertex t = root t.
  Proof.
    intros t E. induction E.
    - (* SatHPSingle *)
      reflexivity.
    - (* SatHPLeft *)
      simpl. apply max_l. rewrite IHE. assumption.
    - (* SatHPRight *)
      simpl. apply max_l. rewrite IHE. assumption.
    - (* SatHPInd *)
      simpl. apply max_l. rewrite IHE1. rewrite IHE2.
      apply max_upper; assumption.
  Qed.

  Definition heap (t:bintree) : Prop :=
    complete t /\ sat_heap_prop t.
  (** A binary tree is called binary heap if and only if it satisfies
      the shape property (completeness) and the heap property. *)

End HeapSort.

Module QuickSort.

  Check filter.

  Lemma filter_lt : forall (A:Type) pred (l:list A),
      length (filter pred l) <= length (filter pred l).
  Proof.
    intros. induction l as [| x l' IHl'].
    - simpl. omega.
    - simpl. destruct (pred x).
      + simpl. apply le_n_S. assumption.
      + constructor.
  Qed.

  Lemma lt_def : forall n m,
      S n <= m <-> n < m.
  Proof.
    intros n m. omega.
  Qed.

  Program Fixpoint qsort (l:list nat) {measure (length l)}
    : list nat :=
    match l with
    | [] => []
    | x :: xs =>
      let lt : list nat := filter (fun n:nat => Nat.ltb n x) xs in
      let ge : list nat := filter (fun n:nat => Nat.leb x n) xs in
      (qsort lt) ++ [x] ++ (qsort ge)
    end.
  Next Obligation.
    induction xs as [| x' xs' IHxs'].
    - (* xs = [ ] *)
      simpl. omega.
    - (* xs = x' :: xs' *)
      simpl. destruct (x' <? x) eqn:Hbool.
      + simpl. apply lt_n_S. replace (S (length xs')) with (length (x::xs')).
        apply IHxs'. intros l Hl. apply xs'.
        simpl. omega.
      + constructor. apply lt_def. apply IHxs'.
        intros l H. apply xs'.
  Qed.
  Next Obligation.
    induction xs as [| x' xs' IHxs'].
    - simpl. omega.
    - simpl. destruct (x <=? x') eqn:Hbool.
      + simpl. apply lt_n_S. replace (S (length xs')) with (length (x::xs')).
        apply IHxs'. intros l Hl. apply xs'.
        reflexivity.
      + apply le_S. replace (S (length xs')) with (length (x::xs')).
        apply lt_def. apply IHxs'. intros l Hl. apply xs'.
        reflexivity.
  Qed.

  Example qsort_example :
    qsort [3; 1; 4; 1; 5; 9; 2] = [1; 1; 2; 3; 4; 5; 9].
  Proof.
    reflexivity.
  Qed.

  Lemma qsort_length : forall l,
      length (qsort l) = length l.
  Proof.
  Abort.

  Lemma qsort_two_head : forall l'' l n m,
      qsort l = n :: m :: l'' -> n <= m.
  Proof.
    intros l''. induction l'' as [| k l'3 IHl'3]; intros l n m.
    - intros Hqsort.
      + unfold qsort in Hqsort. simpl in Hqsort.
  Abort.

  Theorem qsort_is_sort : forall l,
      sorted (qsort l).
  Proof.
    intros l1. remember (qsort l1) as l.
    generalize dependent l1.
    induction l as [| n l' IHl'].
    (* l = [] *) intros. apply SortedEmpty.
    induction l' as [| m l'' IHl''].
    - (* l = [n] *)
      intros. apply SortedSingleton.
    - (* l = n :: m :: l'' *)
      intros l1 Hl1.
      apply SortedInd.
      unfold qsort in Hl1.
      simpl in Hl1.
  Abort.

End QuickSort.


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

(** * Entropy of a distribution *)

Reserved Notation "'`H'" (at level 5).

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

Section entropy_definition.

Variable A : finType.
Variable P : dist A.

Definition entropy := - \rsum_(a in A) P a * log (P a).
Local Notation "'`H'" := (entropy).

Lemma entropy_ge0 : 0 <= `H.
Proof.
rewrite /entropy big_endo ?oppR0 //; last by move=> *; rewrite oppRD.
rewrite (_ : \rsum_(_ in _) _ = \rsum_(i in A | predT A) - (P i * log (P i))); last first.
  apply eq_bigl => i /=; by rewrite inE.
apply rsumr_ge0 => i _.
case/boolP : (P i == 0) => [/eqP ->|Hi].
  (* NB: this step in a standard textbook would be handled as a
     consequence of lim x->0 x log x = 0 *)
  rewrite mul0R oppR0; exact/leRR.
rewrite mulRC -mulNR.
apply mulR_ge0; last exact: dist_ge0.
apply oppR_ge0.
rewrite /log -(Log_1 2).
apply Log_increasing_le => //; last exact: dist_max.
apply/ltRP; rewrite lt0R Hi; exact/leRP/dist_ge0.
Qed.

Hypothesis P_pos : forall b, 0 < P b.

Lemma entropy_pos_P_pos : 0 <= `H.
Proof.
rewrite /entropy big_endo ?oppR0 //; last by move=> *; rewrite oppRD.
rewrite (_ : \rsum_(_ in _) _ = \rsum_(i in A | predT A) - (P i * log (P i))).
  apply rsumr_ge0 => i _.
  rewrite mulRC -mulNR.
  apply mulR_ge0; last exact: dist_ge0.
  apply oppR_ge0.
  rewrite /log -(Log_1 2).
  apply Log_increasing_le => //; by [by apply P_pos | exact: dist_max].
apply eq_bigl => i /=; by rewrite inE.
Qed.

End entropy_definition.

Notation "'`H'" := (entropy) : entropy_scope.

Local Open Scope entropy_scope.
Local Open Scope proba_scope.

Lemma entropy_Ex {A} (P : dist A) : `H P = `E (--log P).
Proof.
rewrite /entropy /mlog_rv ExE /= (big_morph _ morph_Ropp oppR0).
apply eq_bigr => a _; by rewrite mulRC -mulNR.
Qed.

Lemma xlnx_entropy {A} (P : dist A) :
  `H P = / ln 2 * - \rsum_(a : A) xlnx (P a).
Proof.
rewrite /entropy mulRN; f_equal.
rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)).
apply eq_bigr => a _ ;rewrite /log /Rdiv mulRA mulRC; f_equal.
rewrite /xlnx; case : ifP => // /ltRP Hcase.
have : P a = 0; last by move=> ->; rewrite mul0R.
case (Rle_lt_or_eq_dec 0 (P a)) => //; exact: dist_ge0.
Qed.

Lemma entropy_uniform {A : finType} n (HA : #|A| = n.+1) :
  `H (Uniform.d HA) = log (INR #|A|).
Proof.
rewrite /entropy /Uniform.d /Uniform.f /=.
rewrite big_const iter_addR div1R mulRA mulRV; last by rewrite INR_eq0' HA.
rewrite mul1R /log LogV ?oppRK //; by rewrite HA; apply/ltR0n.
Qed.

Local Open Scope reals_ext_scope.

Lemma entropy_max {A : finType} (P : dist A) : `H P <= log (INR #|A|).
Proof.
have [n HA] : exists n, #|A| = n.+1.
  exists (#|A|.-1); rewrite prednK //; by apply (dist_domain_not_empty P).
have : P << (Uniform.d HA) by apply dom_by_uniform.
move/leq0div => H.
rewrite /div in H.
suff Htmp : 0 <= - `H P + log (INR #|A|) by fourier.
apply/(leR_trans H)/Req_le.
transitivity (\rsum_(a|a \in A) P a * log (P a) + \rsum_(a|a \in A) P a * - log ((Uniform.d HA) a)).
  rewrite -big_split /=.
  apply eq_bigr => a _; by rewrite mulRDr.
rewrite /= /Uniform.f /= div1R -[in X in _ + X = _]big_distrl /= pmf1 mul1R.
rewrite /entropy oppRK /log LogV ?oppRK // HA; exact/ltR0n.
Qed.


(***************************)
(* sumbool と it then else *)
(***************************)

(** 帰納型のチュートリアル **)
(** A Tutorial on [Co-]Inductive Types in Coq **)
(* 2.7 Logical connectives. *)

(* {A} + {B} は sumbool A B の意味である。 *)
Locate "{ _ } + { _ }".                     (* sumbool A B : type_scope *)
Print sumbool.
Check sumbool.
Check sumbool_ind.
Check sumbool_rec.
Check left.                                 (* forall A B : Prop, A -> {A} + {B} *)
Check right.                                (* forall A B : Prop, B -> {A} + {B} *)

Require Import Arith.
(* これらを独自に定義したい。 *)
Check le_lt_dec.                            (* forall n m : nat, {n <= m} + {m < n} *)
Print le_lt_dec.
Check eq_nat_dec.                           (* forall n m : nat, {n = m} + {n <> m} *)
Print eq_nat_dec.

Eval compute in eq_nat_dec 1 1.             (* 真：left _ *)
Eval compute in eq_nat_dec 0 1.             (* 偽：right _ *)

Eval compute in le_lt_dec 0 1.              (* 真：left _ *)
Eval compute in le_lt_dec 1 0.              (* 偽：right _ *)

(* match または if-then-else による定義 *)
Definition max (n p : nat) :=
  match le_lt_dec n p with
  | left _ => p
  | right _ => n
  end.
Print max.                                  (* if le_lt_dec n p then p else n *)
Check max.                                  (* nat -> nat -> nat *)
Eval compute in max 1 2.                    (* 2 *)

(* これは、if-then-elseに変換される。 *)
Definition max' (n p : nat) :=
  if le_lt_dec n p then p else n.
Eval compute in max' 1 2.                   (* 2 *)

(* OCaml に変換すると、これは match である *)
Extraction max.

(* coqにおける、it-then-else と match の関係 *)
Eval compute in (if le_lt_dec 1 2 then 2 else 1). (* 2 *)
Eval compute in (match le_lt_dec 1 2 with left _ => 2 | right _ => 1 end). (* 2 *)

(* case による振り分け *)
Theorem le_max : forall n p, n <= p -> max n p = p.
  intros n p H.
  unfold max.
  (* Goal : (if le_lt_dec n p then p else n) = p *)
  case (le_lt_dec n p).

  (* Goal : n <= p -> p = p *)
  reflexivity.                              (* 「->」が前についていても、問題ない *)

  (* Goal : p < n -> n = p *)
  intros l.
  absurd (p < p).
  eauto with arith.
  eauto with arith.
Qed.

(* この場合の case は、
  コンストラクタの apply には置き換えられない。
  see. coq_case.v  *)

Require Import Bool.Sumbool.

(* boolを返すeq関数を定義する。 *)
Definition eq_bool (n p : nat) : bool :=
  proj1_sig (bool_of_sumbool (eq_nat_dec n p)).

Eval compute in eq_bool 1 1.                (* 真：left _ *)
Eval compute in eq_bool 0 1.                (* 偽：right _ *)

(* boolを返すle関数を定義する。 *)
Definition le_bool (n p : nat) : bool :=
  proj1_sig (bool_of_sumbool (le_lt_dec n p)).

Eval compute in le_bool 0 1.                (* 真：left _ *)
Eval compute in le_bool 1 0.                (* 偽：right _ *)

Theorem le_max' : forall n p, le_bool n p = true -> max n p = p.
(* これを証明したい。 *)
Admitted.

(* END *)


Require Import Setoid Arith List Omega Coq.Program.Tactics LibTactics tactics.
Require Import Coq.Program.Equality.

(* Set Implicit Arguments. *)

Module Type Lattice.

Parameter T : Set.
Parameter join: T -> T -> T.
Parameter meet: T -> T -> T.
Parameter flowsto : T -> T -> Prop.
Parameter bot: T.

Notation "X ⊑ Y" := (flowsto X Y) (at level 70, no associativity).
Notation "X ⊔ Y" := (join X Y) (at level 40, left associativity).

Axiom meet_symmetry: forall a b   : T,  meet a b = meet b a.
Axiom join_symmetry: forall a b   : T,  join a b = join b a.
Axiom join_assoc   : forall a b c : T,  join a (join b c) = join (join a b) c.
Axiom meet_assoc   : forall a b c : T,  meet a (meet b c) = meet (meet a b) c.
Axiom meet_distrib : forall a b   : T,  meet a (join a b) = a.
Axiom join_distrib : forall a b   : T,  join a (meet a b) = a.
Axiom flowsto_dec  : forall a b   : T,  { a ⊑ b } + { not (a ⊑ b) }.
Axiom join_flowsto : forall a b   : T,  join a b = b <-> flowsto a b.
Axiom T_dec        : forall a b   : T,  { a = b} + { a <> b }.
Axiom join_bot_left: forall a     : T, join bot a = a.
Axiom join_bot_right: forall a    : T, join a bot = a.

Hint Resolve meet_symmetry join_symmetry join_assoc meet_assoc meet_distrib join_distrib
flowsto_dec join_flowsto T_dec join_bot_left join_bot_right.

End Lattice.

Module LatticeProperties (L: Lattice).
Import L.

Lemma idem_join:
    forall a : T,
      join a a = a.
Proof.
  intros.
  eauto.
  rewrite <- (meet_distrib a a) at 2.
  eauto.
Qed.
Local Hint Resolve idem_join.

Lemma idem_meet:
    forall a : T,
      meet a a = a.
Proof.
  intros.
  rewrite <- (join_distrib a a) at 2.
  eauto.
Qed.
Local Hint Resolve idem_meet.

Lemma flowsto_refl: forall a, flowsto a a.
Proof.
  intro.
  apply join_flowsto.
  eauto.
Qed.
Local Hint Resolve flowsto_refl.

Lemma flowsto_trans:
  forall a b c,
    flowsto  a b ->
    flowsto  b c ->
    flowsto  a c.
Proof.
  intros.
  apply join_flowsto.
  apply join_flowsto in H.
  apply join_flowsto in H0.
  rewrite <- H0.
  replace  (join a(join b c)) with (join (join a b) c) by eauto.
  rewrite -> H.
  eauto.
Qed.

Hint Extern 1 (?a ⊑ ?c) =>
match goal with
| [H: a ⊑ ?b |- _] => apply (flowsto_trans a b c)
| [H: ?b ⊑ c |- _] => apply (flowsto_trans a b c)
end.

Lemma anti_sym:
  forall a b : T,
    a ⊑ b ->
    b ⊑ a ->
    a = b.
Proof.
  intros a b H1 H2.
  apply join_flowsto in H1.
  apply join_flowsto in H2.
  replace (join b a) with (join a b) in * by eauto.
  congruence.
Qed.
Local Hint Resolve anti_sym.

Lemma flowsto_not:
  forall ℓ₁ ℓ₂ ℓ₃,
    ℓ₁ ⊑ ℓ₂ ->
    not (ℓ₁ ⊑ ℓ₃) ->
    not (ℓ₂ ⊑ ℓ₃).
Proof.
  intros ℓ₁ ℓ₂ ℓ₃ H1 H2.
  intro H_absurd.
  contradiction (flowsto_trans _ _ _ H1 H_absurd).
Qed.
Hint Resolve flowsto_not.

Lemma flowsto_join:
  forall a b,
    a ⊑ join a b.
Proof.
  intros.
  apply join_flowsto.
  rewrite -> join_assoc.
  rewrite -> idem_join.
  reflexivity.
Qed.

Lemma join_flowsto_implies_flowsto:
  forall ℓ₁ ℓ₂ ℓ₃,
    join ℓ₁ ℓ₂ ⊑ ℓ₃ -> ℓ₁ ⊑ ℓ₃ /\ ℓ₂ ⊑ ℓ₃.
Proof.
  intros.
  assert (ℓ₁ ⊑ join ℓ₁ ℓ₂) by apply flowsto_join.
  assert (ℓ₂ ⊑ join ℓ₁ ℓ₂) by (rewrite -> join_symmetry; apply flowsto_join).
  split; eapply flowsto_trans; eauto.
Qed.

Ltac destruct_join_flowsto :=
  match goal with
    [H: join ?a ?b ⊑ ?c |- _] => destruct (join_flowsto_implies_flowsto a b c H); clear H
  end.

Lemma not_flowsto_implies_not_join_flowsto:
  forall a b c,
    ~ a ⊑ c ->
    ~ b ⊑ c ->
    ~ join a b ⊑ c.
Proof.
  intros.
  intro.
  rewrite <- join_flowsto in *.
  rewrite <- H1 in *.
  rewrite -> join_flowsto in *.
  rewrite <- join_assoc in *.
  contradiction H.
  eapply flowsto_join.
Qed.

Lemma implies_join_flowsto:
  forall a b c,
    a ⊑ c ->
    b ⊑ c ->
    a ⊔ b ⊑ c.
Proof.
  intros.
  rewrite <- join_flowsto.
  eapply join_flowsto in H.
  eapply join_flowsto in H0.
  rewrite <- join_assoc.
  rewrite -> H0.
  assumption.
Qed.
Hint Resolve implies_join_flowsto.

End LatticeProperties.

Module ProductLattice (A B : Lattice) <: Lattice.
  Definition T := prod A.T B.T.

  Definition meet (x y : T) :=
    match x, y with
      (a1, b1), (a2, b2) => (A.meet a1 a2, B.meet b1 b2)
    end.

  Definition join (x y : T) :=
    match x, y with
      (a1, b1), (a2, b2) => (A.join a1 a2, B.join b1 b2)
    end.

  Definition flowsto (a b : T) := join a b = b.
  Local Hint Unfold flowsto.

  Lemma meet_symmetry: forall a b : T, meet a b = meet b a.
  Proof.
    intros.
    unfolds.
    destruct a as [a1 b1].
    destruct b as [a2 b2].
    rewrite -> A.meet_symmetry.
    rewrite -> B.meet_symmetry.
    reflexivity.
  Qed.

  Lemma join_symmetry: forall a b : T, join a b = join b a.
  Proof.
    intros.
    unfolds.
    destruct a as [a1 b1].
    destruct b as [a2 b2].
    rewrite -> A.join_symmetry.
    rewrite -> B.join_symmetry.
    reflexivity.
  Qed.

  Lemma join_assoc: forall a b c : T, join a (join b c) = join (join a b) c.
  Proof.
    intros.
    unfold join.
    destruct a as [a1 b1].
    destruct b as [a2 b2].
    destruct c as [a3 b3].
    rewrite -> A.join_assoc.
    rewrite -> B.join_assoc.
    reflexivity.
  Qed.

  Lemma meet_assoc: forall a b c : T, meet a (meet b c) = meet (meet a b) c.
  Proof.
    intros.
    unfold meet.
    destruct a as [a1 b1].
    destruct b as [a2 b2].
    destruct c as [a3 b3].
    rewrite -> A.meet_assoc.
    rewrite -> B.meet_assoc.
    reflexivity.
  Qed.

  Lemma meet_distrib: forall a b : T, meet a (join a b) = a.
  Proof.
    intros.
    unfold meet, join.
    destruct a as [a1 b1].
    destruct b as [a2 b2].
    rewrite -> A.meet_distrib.
    rewrite -> B.meet_distrib.
    reflexivity.
  Qed.
  Hint Resolve meet_distrib.

  Lemma join_distrib: forall a b : T, join a (meet a b) = a.
  Proof.
    intros.
    unfold meet, join.
    destruct a as [a1 b1].
    destruct b as [a2 b2].
    rewrite -> A.join_distrib.
    rewrite -> B.join_distrib.
    reflexivity.
  Qed.
  Hint Resolve join_distrib.

  Notation "X ⊑ Y" := (flowsto X Y) (at level 70, no associativity).
  Notation "X ⊔ Y" := (join X Y) (at level 40, left associativity).

  Lemma join_flowsto: forall a b: T,
      join a b = b <-> flowsto a b.
  Proof.
    split*.
  Qed.

  Lemma flowsto_pointwise_proj1:
    forall (a1 a2 : A.T)
      (b1 b2 : B.T),
      flowsto (a1, b1) (a2, b2) ->
      A.flowsto a1 a2.
  Proof.
    intros.
    rewrite <- A.join_flowsto.
    rewrite <- join_flowsto in *.
    injects.
    assumption.
  Qed.
  Hint Resolve flowsto_pointwise_proj1.

  Lemma flowsto_pointwise_proj2:
    forall (a1 a2 : A.T)
      (b1 b2 : B.T),
      flowsto (a1, b1) (a2, b2) ->
      B.flowsto b1 b2.
  Proof.
    intros.
    rewrite <- B.join_flowsto.
    rewrite <- join_flowsto in *.
    injects.
    assumption.
  Qed.
  Hint Resolve flowsto_pointwise_proj2.

  Lemma join_is_pairwise:
    forall (a1 a2 : A.T)
      (b1 b2 : B.T),
      join (a1, b1) (a2, b2) =
      (A.join a1 a2, B.join b1 b2).
  Proof.
    intros.
    unfolds.
    reflexivity.
  Qed.

  Lemma flowsto_dec: forall a b : T,
      {a ⊑ b} + {not (a ⊑ b)}.
  Proof.
    intros a b.
    destruct a as [a1 b1].
    destruct b as [a2 b2].
    destruct (A.flowsto_dec a1 a2); destruct (B.flowsto_dec b1 b2).
    - left.
      rewrite <- join_flowsto.
      rewrite <- A.join_flowsto in * |-.
      rewrite <- B.join_flowsto in * |-.
      unfolds.
      rewrite -> f.
      rewrite -> f0.
      reflexivity.
    - right.
      intro.
      rewrite <- join_flowsto in *.
      contradict n.
      rewrite <- B.join_flowsto.
      unfolds in H.
      injects.
      assumption.
    - right.
      intro.
      rewrite <- join_flowsto in *.
      contradict n.
      rewrite <- A.join_flowsto.
      unfolds in H.
      injects.
      assumption.
    - right.
      intro.
      rewrite <- join_flowsto in *.
      unfolds in H.
      injects.
      contradict n.
      rewrite <- A.join_flowsto.
      assumption.
  Defined.

Lemma T_dec: forall a b : T, {a = b} + {a <> b}.
Proof.
  intros.
  destruct a as [a1 b1].
  destruct b as [a2 b2].
  destruct (A.T_dec a1 a2); destruct (B.T_dec b1 b2); subst.
  - left.
    reflexivity.
  - right.
    intro; injects.
    eauto.
  - right.
    intro; injects.
    eauto.
  - right.
    intro; injects.
    eauto.
Qed.

Definition bot := (A.bot, B.bot).

Lemma join_bot_left:
  forall a,
    join bot a = a.
Proof.
  intros.
  destruct a as [a b].
  unfolds.
  unfold bot.
  rewrite -> A.join_bot_left.
  rewrite -> B.join_bot_left.
  reflexivity.
Qed.
Hint Resolve join_bot_left.

Lemma join_bot_right:
  forall a,
    join a bot = a.
Proof.
  intros.
  destruct a as [a b].
  unfolds.
  unfold bot.
  rewrite -> A.join_bot_right.
  rewrite -> B.join_bot_right.
  reflexivity.
Qed.
Hint Resolve join_bot_right.

Lemma implies_flowsto:
  forall a1 a2 b1 b2,
    A.flowsto a1 a2 ->
    B.flowsto b1 b2 ->
    flowsto (a1, b1) (a2, b2).
Proof.
  intros.
  unfolds.
  rewrite -> join_is_pairwise.
  rewrite <- A.join_flowsto in *.
  rewrite <- B.join_flowsto in *.
  congruence.
Qed.
Hint Resolve implies_flowsto.

End ProductLattice.

Module LH <: Lattice.

Inductive LH :=
| L: LH
| H: LH.

Definition T := LH.

Definition meet (a b : LH) :=
  match a with
    | L => L
    | H => b
  end.

Definition join (a b : LH) :=
  match a with
  | L => b
  | H => H
  end.

Lemma meet_symmetry: forall a b : LH, meet a b = meet b a.
Proof.
  intros.
  unfold meet.
  case a; case b; auto.
Qed.

Lemma join_symmetry :forall a b : LH, join a b = join b a.
Proof.
  intros; unfold join. case a; case b; auto.
Qed.

Lemma join_assoc: forall a b c :LH , join a (join b c) = join ( join a b) c.
Proof.
  intros.
  unfold join.
  case a; case b; case c; auto.
Qed.

Lemma meet_assoc: forall a b c: LH, meet a (meet b c) = meet (meet a b) c.
Proof.
  intros.
  unfold join.
  case a; case b; case c; auto.
Qed.

Lemma meet_distrib: forall a b : LH, meet a (join a b) = a.
Proof.
  intros; case a; case b; auto.
Qed.

Lemma join_distrib: forall a b : LH, join a (meet a b) = a.
Proof.
  intros; case a; case b; auto.
Qed.

Definition flowsto a b := join a b = b.
Local Hint Unfold flowsto.

Notation "X ⊑ Y" := (flowsto X Y) (at level 70, no associativity).
Notation "X ⊔ Y" := (join X Y) (at level 20, left associativity).

Lemma flowsto_dec: forall a b : T,
    {a ⊑ b} + {not (a ⊑ b)}.
Proof.
  intros a b.
  destruct a; destruct b.
  - left; eauto.
  - left; eauto.
  - right. unfold not; intros. inversion H0.
  - left; eauto.
Defined.

Lemma T_dec: forall a b : LH, {a = b } + {a <> b}.
Proof.
  intros.
  destruct a; destruct b; eauto; right; congruence.
Qed.

Lemma join_flowsto: forall a b: LH,
  join a b = b <-> flowsto a b.
Proof.
  split.
  - eauto.
  - intros.
    eauto.
Qed.

Definition bot := L.

Lemma join_bot_left:
  forall a,
    join bot a = a.
Proof.
  reflexivity.
Qed.
Hint Resolve join_bot_left.

Lemma join_bot_right:
  forall a,
    join a bot = a.
Proof.
  intros.
  destruct a; reflexivity.
Qed.
Hint Resolve join_bot_right.

End LH.


(* BEGIN FIX *)
Fixpoint max (n m : nat) {struct n} : nat :=
  match n, m with
  | 0 , _ => m
  | S n' , 0 => n
  | S n' , S m' => S (max n' m')
  end.

Example max_test1 : max 100 200 = 200. simpl. reflexivity. Qed.
Example max_test2 : max 3 3 = 3. simpl. reflexivity. Qed.
Example max_test3 : max 4 3 = 4. simpl. reflexivity. Qed.

Inductive Tree : Type :=
  | Leaf : Tree
  | Node2 : Tree -> Tree -> Tree
  | Node3 : Tree -> Tree -> Tree -> Tree.

Definition exTree1 : Tree := Node2 (Node3 Leaf Leaf Leaf) Leaf.

Definition exTree2 : Tree := Node2 (Node2 Leaf (Node2 (Node2 Leaf Leaf) Leaf)) (Node2 Leaf Leaf).

Fixpoint height (t : Tree) {struct t} : nat :=
(* END FIX *)
 match t with
  | Leaf => 0
  | Node2 t1 t2 => 1 + (max (height t1) (height t2))
  | Node3 t1 t2 t3 => 1 + max (max (height t1) (height t2)) (height t3)
end.

(* BEGIN FIX *)
Example height_test_1 : height exTree1 = 2.
(* END FIX *)
simpl.
reflexivity.
Qed.

(* BEGIN FIX *)
Example height_test_2 : height exTree2 = 4.
(* END FIX *)
simpl.
reflexivity.
Qed.

(* BEGIN FIX *)
Lemma max_0 (m : nat) : max m 0 = m.
(* END FIX *)
simpl.
induction m as [|m H].
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

(* BEGIN FIX *)
Lemma height_Leaf (t : Tree) : height (Node2 t Leaf) = height (Node2 Leaf t).
(* END FIX *)
simpl.
rewrite -> max_0.
reflexivity.
Qed.

(* BEGIN FIX *)
Lemma max_comm : forall (m n : nat),  max m n = max n m.
(* END FIX *)
induction m as[|m' H].
intros.
rewrite -> max_0.
simpl.
reflexivity.
intros.
simpl.
induction n as [|n' H2].
simpl.
reflexivity.
simpl.
rewrite -> H.
reflexivity.
Qed.


(*This contains both natlists and bags implementation*)

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

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

  Notation "x + y" := (plus x y)
                      (at level 50, left associativity).

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

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
  end.

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).
Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.
Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3: [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.

Definition hd (default:nat) (l:natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Example test_hd1: hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.

Example test_hd2: hd 0 [] = 0.
Proof. reflexivity. Qed.

Example test_tl: tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.

Fixpoint nonzeros (k:natlist) : natlist :=
  match k with
  | nil => nil
  | 0 :: l => nonzeros(l)
  | h :: l => [h] ++ nonzeros(l)
  end.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. reflexivity. Qed.

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

Fixpoint oddmembers (k:natlist) : natlist :=
  match k with
  | nil => nil
  | h :: l =>
    match evenb(h) with
    |true => oddmembers (l)
    |false => [h] ++ oddmembers (l)
    end
  end.

Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
  Proof. reflexivity. Qed.

Definition countoddmembers (l:natlist) : nat :=
length(oddmembers(l)).

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
  Proof. reflexivity. Qed.

Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
  Proof. reflexivity. Qed.

Example test_countoddmembers3:
  countoddmembers nil = 0.
  Proof. reflexivity. Qed.

Definition bag := natlist.

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

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => 0
  | m :: s' =>
    match beq_nat (v) (m) with
    | true => 1 + count (v) (s')
    | false  => count (v) (s')
    end
  end.

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
 Proof. reflexivity. Qed.
Example test_count2: count 6 [1;2;3;1;4;1] = 0.
 Proof. reflexivity. Qed.

Definition sum : bag -> bag -> bag := app.

Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
 Proof. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag := sum s [v].

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
Proof. reflexivity. Qed.
Example test_add2: count 5 (add 1 [1;4;1]) = 0.
Proof. reflexivity. Qed.

Definition member (v:nat) (s:bag) : bool :=
match beq_nat (count (v) (s)) (0) with
|true => false
|false => true
end.

Example test_member1: member 1 [1;4;1] = true.
Proof. reflexivity. Qed.
Example test_member2: member 2 [1;4;1] = false.
Proof. reflexivity. Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
match s with
| nil => nil
| x :: n =>
  match beq_nat (x) (v) with
  | true => n
  | false => x :: remove_one (v) (n)
  end
end.

Example test_remove_one1:
  count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.

Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
match s with
| nil => nil
| x :: n =>
  match beq_nat (x) (v) with
  | true => remove_all (v) (n)
  | false => x :: remove_all (v) (n)
  end
end.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.
Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. reflexivity. Qed.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
  | nil => true
  | x :: n =>
    match member (x) (s2) with
    |true => subset (n) (remove_one x s2)
    |false => false
    end
  end.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
Proof. reflexivity. Qed.
Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
Proof. reflexivity. Qed.

Theorem bag_theorem : forall x:nat, count(x)(add (x) ([])) = 1.
Proof.
intros x.
simpl. induction x as [|IHx].
- reflexivity.
- simpl. rewrite -> IHIHx. reflexivity.
Qed.

Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons n l' *)
    reflexivity. Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons n l1' *)
    simpl. rewrite -> IHl1'. reflexivity. Qed.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => rev t ++ [h]
  end.
Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.
Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  (* WORKED IN CLASS *)
  intros l1 l2. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons *)
    simpl. rewrite -> IHl1'. reflexivity. Qed.

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

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
intros n m.
induction m as [| m' IHm'].
- simpl. induction n as [| n' IHn'].
+ reflexivity.
+ simpl. rewrite -> IHn'. reflexivity.
- simpl. rewrite <- IHm'. rewrite -> plus_n_Sm. reflexivity.
Qed.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons *)
    simpl. rewrite -> app_length, plus_comm.
    simpl. rewrite -> IHl'. reflexivity. Qed.


Require Import Arith.

Goal forall x y, x < y -> x + 10 < y + 10.
Proof.
  intros.
  apply plus_lt_compat_r.
  exact H.
Qed.

Goal forall P Q : nat -> Prop, P 0 -> (forall x, P x -> Q x) -> Q 0.
Proof.
  intros.
  apply H0.
  exact H.
Qed.

Goal forall P : nat -> Prop, P 2 -> (exists y, P (1 + y)).
Proof.
  intros.
  exists 1.
  simpl.
  exact H.
Qed.

Goal forall P : nat -> Prop, (forall n m, P n -> P m) -> (exists p, P p) -> forall q, P q.
Proof.
  intros.
  destruct H0. (* existsに対してdestructできることを覚えておこう *)
  apply (H x).
  exact H0.
Qed.

Goal forall m n : nat, (n * 10) + m = (10 * n) + m.
Proof.
  intros m n.
  rewrite mult_comm.
  reflexivity.
Qed.

Goal forall n m p q : nat, (n + m) + (p + q) = (n + p) + (m + q).
Proof.
  intros.
  apply plus_permute_2_in_4.
Qed.

Goal forall n m : nat, (n + m) * (n + m) = n * n + m * m + 2 * n * m.
Proof.
  intros.
  rewrite mult_plus_distr_l.
  rewrite mult_plus_distr_r.
  rewrite mult_plus_distr_r.
  simpl.
  rewrite <- plus_n_O.
  rewrite mult_plus_distr_r.
  rewrite (plus_comm (n * m) (m * m)).
  rewrite plus_permute_2_in_4.
  rewrite (mult_comm m n).
  reflexivity.
Qed.

Module Task10.
Parameter G : Set.
Parameter mult : G -> G -> G.
Notation "x * y" := (mult x y).
Parameter one : G.
Notation "1" := one.
Parameter inv : G -> G.
Notation "/ x" := (inv x).
(* Notation "x / y" := (mult x (inv y)). *) (* 使ってもよい *)

Axiom mult_assoc : forall x y z, x * (y * z) = (x * y) * z.
Axiom one_unit_l : forall x, 1 * x = x.
Axiom inv_l : forall x, /x * x = 1.

(* 自力じゃできなかった... *)
(* 群論のサイト見た *)
Lemma inv_r : forall x, x * / x = 1.
Proof.
  intro x.
  rewrite <- (one_unit_l (x * / x)).
  rewrite <- (inv_l (/ x)) at 1.
  rewrite <- (mult_assoc (/ / x) (/ x) (x * / x)).
  rewrite (mult_assoc (/ x) x (/ x)).
  rewrite (inv_l x).
  rewrite one_unit_l.
  rewrite inv_l.
  reflexivity.
Qed.

Lemma one_unit_r : forall x, x * 1 = x.
Proof.
  intros.
  rewrite <- (inv_l x).
  rewrite mult_assoc.
  rewrite (inv_r x).
  rewrite one_unit_l.
  reflexivity.
Qed.

End Task10.


(* ------   In this file we formalize the concept of sorting in a list.  We consider lists
   of elements (on an arbitrary type A) with a boolean comparison operator (lr: A-> A-> bool).
   Most of  the results in this file assumes only
   1. reflexive,
   2. transitive and
   3. comparable
   nature of the boolean operator lr.
   Only the last result (equality of head) assumes the antisymmetric
   property of lr.

   Following are the concepts formalized in this file:

   Sorted l      <==> l is sorted w.r.t comp operator lr
   putin a l      ==> puts the element a into a sorted list at its correct position w.r.t lr
   sort l         ==> sorts the list l w.r.t the comp operator lr

   Some of the useful results in this file are:

   Lemma putin_correct (H_trans: transitive lr)(H_comp: comparable lr):
    forall (a:A) (l: list A), Sorted l -> Sorted (putin a l).

   Lemma nodup_putin (a:A)(l:list A): NoDup (a::l)-> NoDup (putin a l).

   Lemma sort_correct (H_trans: transitive lr)(H_comp: comparable lr):
    forall(l: list A), Sorted (sort l).

   Lemma sort_equal (l: list A): Equal l (sort l).

   Lemma nodup_sort (l: list A): NoDup l -> NoDup (sort l). ------------------  *)

Require Export Lists.List.
Require Export GenReflect SetSpecs.
Require Export Lia.

Set Implicit Arguments.

Section Sorting.
  Context {A: Type }.

  Variable lr: A->A-> bool.
  Notation " a <=r b":= (lr a b)(at level 70, no associativity).
  (* ------------- sorting a list of elements by lr relation ------------------------------*)

  Inductive  Sorted : list A-> Prop:=
  | nil_Sorted: Sorted nil
  | cons_Sorted (a:A)(l: list A): Sorted l -> (forall x, (In x l -> (a <=r x))) -> Sorted (a::l).

  Lemma Sorted_intro (a:A)(b:A)(l: list A)(Htrans: transitive lr):
    a <=r b -> Sorted (b::l)-> Sorted (a::b::l).
  Proof. { intros H H0. constructor. auto. intros x H1. destruct H1. subst x. auto.
         eapply Htrans with (y:=b). eauto. inversion H0. eauto. } Qed.

  Lemma Sorted_elim1 (a:A) (b:A) (l: list A): (Sorted (a::b::l)) -> (a <=r b).
  Proof. intro H. inversion H.  eapply H3. auto.  Qed.
  Lemma Sorted_elim4 (a:A) (l:list A): Sorted (a::l) ->(forall x, In x l -> a <=r x).
  Proof. intro H. inversion H. auto. Qed.
  Lemma Sorted_elim2 (a:A) (l:list A)(Hrefl: reflexive lr):
    Sorted (a::l) ->(forall x, In x (a::l) -> a <=r x).
  Proof. intro H. inversion H. intros. destruct H4. subst x.  eauto. eauto. Qed.
  Lemma Sorted_elim3 (a:A) (l:list A): (Sorted (a::l)) -> Sorted l.
  Proof. intro H. inversion H;auto. Qed.
  Lemma Sorted_subset (a1 a2:A) (l1 l2: list A) (Htrans: transitive lr)(Hrefl: reflexive lr):
  Sorted (a1::l1) -> Sorted (a2::l2) -> (a1::l1) [<=] (a2::l2) -> In a2 (a1::l1)
  -> (a1 <=r a2)/\a2 <=r a1.
  Proof. intros. eapply Sorted_elim2 with (a:=a1)(x:=a2) in H. assert (In a1 (a2::l2)).
  apply H1. auto. eapply Sorted_elim2 with (a:=a2)(x:=a1) in H3. auto. auto. auto.
  auto. auto. Qed.

  Lemma Sorted_single : forall a:A, (Sorted (a::nil)).
  Proof. constructor. constructor. intros;simpl;contradiction. Qed.

  Lemma last_in_Sorted (a d:A)(l:list A)(Htrans: transitive lr)(Hrefl: reflexive lr):
   Sorted l -> In a l -> lr a (last l d).
  Proof. { revert a.
         induction l as [|b1 l'].
         { intros a H H0. simpl in H0. auto. }
         { intros a0 H H0.
           destruct H0.
           { subst b1.
           case l' as [|b2 l''] eqn: H1.
           { simpl. auto. }
           { replace (last (a0 :: b2 :: l'') d) with (last (b2 :: l'') d).
             assert (H2: b2 <=r (last (b2 :: l'') d)).
             { apply IHl'. eapply Sorted_elim3. exact H. auto. }
             assert (H3: a0 <=r b2).
             { eapply Sorted_elim1. exact H. }
             eauto.
             simpl. destruct l'';auto. } }
            { case l' as [|b2 l''] eqn: H1.
             { destruct H0. }
             { replace (last (b1 :: b2 :: l'') d) with (last (b2 :: l'') d).
             apply IHl'. eapply Sorted_elim3. exact H. auto.
             simpl. destruct l'';auto. } } } } Qed.

  Hint Resolve Sorted_elim1 Sorted_elim2 Sorted_elim3 Sorted_elim4
       Sorted_single Sorted_intro last_in_Sorted : core.

  Fixpoint putin (a: A) (l: list A) : list A:=
    match l with
    |nil=> a::nil
    |b::l1 => match a <=r b with
             |true => a::l
             |false => b::(putin a l1)
                    end
    end.

  Lemma putin_intro (a:A) (l: list A): forall x, In x l -> In x (putin a l).
  Proof. { intros x H. induction l. simpl in H. contradiction. simpl.
           destruct ( a <=r a0). destruct H. subst x. all: auto.  destruct H. subst x; auto.
          apply IHl in H as H1;auto.  } Qed.

  Lemma putin_intro1 (a:A) (l: list A): In a (putin a l).
  Proof. { induction l. simpl. tauto. simpl. destruct ( a <=r a0). all: auto.  } Qed.

  Lemma putin_elim (a:A) (l: list A): forall x, In x (putin a l) -> (x=a)\/(In x l).
  Proof. { intros x H. induction l. simpl in H. simpl. destruct H. left. auto. auto.
           simpl in H. destruct ( a <=r a0).   destruct H. auto. auto. destruct H.
           right;subst x;auto. apply IHl in H as H2. destruct H2. auto. right. auto.  } Qed.

(*  Definition comparable (lr: A->A-> bool) := forall x y, lr x y =false-> lr y x.*)
Definition comparable (lr: A->A-> bool) := forall x y, lr x y =true \/ lr y x = true.
  Lemma putin_correct (H_trans: transitive lr)(H_comp: comparable lr):
    forall (a:A) (l: list A), Sorted l -> Sorted (putin a l).
  Proof. { intros a l. revert a.  induction l.
         { intros a1 H.  simpl. apply Sorted_single. }
           simpl. intros a1 H.  destruct ( a1 <=r a) eqn:H0.
         {  auto.  }
         { unfold comparable in H_comp. specialize (H_comp a1 a).
           destruct H_comp. { rewrite H1 in H0. inversion H0. } { constructor. eauto.
           intros x H2. apply putin_elim in H2 as H3. destruct H3.
           subst x;auto. eauto. } } } Qed.

  Lemma nodup_putin (a:A)(l:list A): NoDup (a::l)-> NoDup (putin a l).
  Proof.  { revert a. induction l.
          { simpl. auto. }
          { intros a0 H. assert (Ha: NoDup (a::l)).  eauto.
            simpl. destruct (a0 <=r a) eqn: H1. auto.
            constructor.
            { intro H2. assert ( H2a: a=a0 \/ In a l). eauto using putin_elim.
              destruct H2a. subst a. inversion H. eauto.  inversion Ha; contradiction. }
            apply IHl. inversion H. constructor; eauto.  } } Qed.

  Lemma putin_card (a:A)(l: list A): | putin a l | = S (|l|).
  Proof. { induction l.
         { simpl;auto. }
         { simpl. case (a <=r a0) eqn:H.
           simpl; auto. simpl; rewrite IHl; auto. } } Qed.

  Hint Resolve putin_intro putin_intro1 putin_elim putin_correct nodup_putin: core.

   Fixpoint sort (l: list A): list A:=
    match l with
    |nil => nil
    |a::l1 => putin a (sort l1)
    end.

  Lemma sort_intro (l: list A): forall x, In x l -> In x (sort l).
  Proof. { intros x H. induction l. eauto. simpl. destruct H. subst x.
         apply putin_intro1. eauto using putin_intro. } Qed.

  Lemma sort_elim (l: list A): forall x, In x (sort l) -> In x l.
  Proof. { intros x H. induction l. simpl in H. contradiction.
         simpl in H. apply putin_elim in H. destruct H. subst x;eauto. eauto. } Qed.

  Lemma sort_correct (H_trans: transitive lr)(H_comp: comparable lr):
    forall(l: list A), Sorted (sort l).
  Proof. induction l. simpl. constructor. simpl. eauto using putin_correct. Qed.

  Hint Resolve sort_elim sort_intro sort_correct: core.

  Lemma sort_equal (l: list A): Equal l (sort l).
  Proof. split;intro; eauto. Qed.

   Lemma sort_equal1 (l: list A): Equal (sort l) l.
  Proof. split;intro; eauto. Qed.

  Lemma sort_same_size (l: list A): |sort l| = |l|.
  Proof. { induction l.
         { simpl;auto. }
         { simpl. replace (|putin a (sort l)|) with (S(|sort l|)).
           rewrite IHl. auto. symmetry. apply putin_card. } } Qed.

  Lemma Sorted_equal (l l': list A): Equal l l' -> Equal l (sort l').
  Proof. intro. cut (Equal l' (sort l')). eauto.  apply sort_equal. Qed.
  Lemma Sorted_equal1(l l': list A): Equal l l' -> Equal (sort l) l'.
  Proof. intro. cut (Equal l (sort l)). eauto. apply sort_equal. Qed.

  Lemma nodup_sort (l: list A): NoDup l -> NoDup (sort l).
  Proof. { induction l. eauto.
         {  simpl. intro H.  cut (NoDup (a::sort l)). eauto.
            constructor.
            { intro H1. absurd (In a l). inversion H; auto. eapply  sort_equal;auto. }
            eauto. } } Qed.

  (*--upto this point only reflexive, transitive and comparable property of <=r is needed--- *)

  (* ---------------------head in Sorted lists l and l'-------------------------- *)

   Definition empty: list A:= nil.

  Lemma empty_equal_nil_l (l: list A): l [=] empty -> l = empty.
  Proof. { case l. auto. intros s l0. unfold "[=]". intro H.
           destruct H as [H1 H2]. absurd (In s empty). all: eauto. } Qed.

   (*-------- antisymmetric requirement is only needed in the following lemma--------*)
  Lemma head_equal_l (a b: A)(l s: list A)(Href: reflexive lr)(Hanti: antisymmetric lr):
    Sorted (a::l)-> Sorted (b::s)-> Equal (a::l) (b::s)-> a=b.
  Proof. { intros H H1 H2.
         assert(H3: In b (a::l)).
         unfold "[=]" in H2. apply H2. auto.
         assert (H3A: a <=r b). eapply Sorted_elim2;eauto.
         assert(H4: In a (b::s)).
         unfold "[=]" in H2. apply H2. auto.
         assert (H4A: b <=r a). eapply Sorted_elim2;eauto.
         eapply Hanti. split_;auto. } Qed.
  Lemma sort_equal_nodup (l: list A)(Href: reflexive lr)(Hanti: antisymmetric lr):
    Sorted l-> NoDup l-> sort l = l.
  Proof. { induction l. auto. intros. simpl. rewrite IHl.
           eauto. eauto. case l eqn:Hl. simpl. auto. intros. simpl.
           destruct (a <=r a0) eqn:Ha. f_equal.
           apply Sorted_elim2 with (x:=a0) in H.
           assert(a=a0). apply Hanti. apply /andP.
           split. auto. rewrite H in Ha.
           auto. subst. assert(~In a0 ((a0 :: l0))).
           eauto. assert(In a0 (a0 :: l0)). auto.
           unfold not in H1. apply H1 in H2.
           elim H2. apply Href. auto. } Qed.

End Sorting.

Hint Resolve Sorted_elim1 Sorted_elim2 Sorted_elim3 Sorted_elim4
     Sorted_single Sorted_intro last_in_Sorted : core.
Hint Resolve putin_intro putin_intro1 putin_elim putin_correct nodup_putin : core.
Hint Resolve sort_elim sort_intro sort_correct sort_same_size : core.
Hint Resolve sort_equal sort_equal1 Sorted_equal Sorted_equal1 nodup_sort: core.
Hint Resolve empty_equal_nil_l head_equal_l: core.
Hint Immediate sort_equal_nodup: core.

(*
 Definition l := 12::42::12::11::20::0::3::30::20::0::nil.
 Eval compute in (sort (fun x y => Nat.ltb y x) l).
 Eval compute in (sort (fun x y => ~~ (Nat.ltb x y)) l).
*)


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-withoutlocality".
From Foundations Require Export Logic.
From Coq Require Import Lia.

Fixpoint div2 (n : nat) :=
  match n with
  | O => O
  | 1 => O
  | S (S n') => S (div2 n')
  end.

Definition f (n : nat) :=
  if even n then div2 n
  else (3 * n) + 1.

Fail Fixpoint reaches_1_in (n : nat) :=
  if n =? 1 then 0
  else 1 + reaches_1_in (f n).

Inductive reaches_1 : nat -> Prop :=
  | term_done : reaches_1 1
  | term_more (n : nat) : reaches_1 (f n) -> reaches_1 n.

Module LePlayground.

Inductive le : nat -> nat -> Prop :=
  | le_n (n : nat) : le n n
  | le_S (n m : nat) : le n m -> le n (S m).

End LePlayground.

Inductive clos_trans {X : Type} (R : X -> X -> Prop) : X -> X -> Prop :=
  | t_step (x y : X) : R x y -> clos_trans R x y
  | t_trans (x y z : X) :
      clos_trans R x y ->
      clos_trans R y z ->
      clos_trans R x z.

Inductive clos_refl_trans {X : Type} (R : X -> X -> Prop) : X -> X -> Prop :=
  | rt_step (x y : X) : R x y -> clos_refl_trans R x y
  | rt_trans (x y z : X) :
      clos_refl_trans R x y ->
      clos_refl_trans R y z ->
      clos_refl_trans R x z
  | rt_refl (x : X) : clos_refl_trans R x x.

Inductive clos_sym_refl_trans {X : Type} (R : X -> X -> Prop) : X -> X -> Prop :=
  | srt_step (x y : X) : R x y -> clos_sym_refl_trans R x y
  | srt_trans (x y z : X) :
      clos_sym_refl_trans R x y ->
      clos_sym_refl_trans R y z ->
      clos_sym_refl_trans R x z
  | srt_refl (x : X) : clos_sym_refl_trans R x x
  | srt_sym (x y : X) :
      clos_sym_refl_trans R x y ->
      clos_sym_refl_trans R y x.

Inductive Perm3 {X : Type} : list X -> list X -> Prop :=
  | perm3_swap12 (a b c : X) :
      Perm3 [a;b;c] [b;a;c]
  | perm3_swap23 (a b c : X) :
      Perm3 [a;b;c] [a;c;b]
  | perm3_trans (l1 l2 l3 : list X) :
      Perm3 l1 l2 -> Perm3 l2 l3 -> Perm3 l1 l3.