From Hammer Require Import Hammer.

From ZornsLemma Require Export FiniteTypes.
From ZornsLemma Require Import InfiniteTypes.
From ZornsLemma Require Import CSB.
From ZornsLemma Require Import DecidableDec.
Require Export Relation_Definitions.
From ZornsLemma Require Import Relation_Definitions_Implicit.
Require Import Description.
From ZornsLemma Require Import Proj1SigInjective.
From ZornsLemma Require Import DependentTypeChoice.

Set Asymmetric Patterns.

Inductive CountableT (X:Type) : Prop :=
| intro_nat_injection: forall f:X->nat, injective f -> CountableT X.

Lemma CountableT_is_FiniteT_or_countably_infinite:
forall X:Type, CountableT X ->
{FiniteT X} + {exists f:X->nat, bijective f}.
Proof. hammer_hook "CountableTypes" "CountableTypes.CountableT_is_FiniteT_or_countably_infinite".
intros.
apply exclusive_dec.
red; intro.
destruct H0 as [? [f ?]].
contradiction nat_infinite.
apply bij_finite with _ f; trivial.
apply bijective_impl_invertible; trivial.

case (classic (FiniteT X)).
left; trivial.
right.
apply infinite_nat_inj in H0.
destruct H.
destruct H0 as [g].
apply CSB with f g; trivial.
Qed.

Lemma countable_nat_product: CountableT (nat*nat).
Proof. hammer_hook "CountableTypes" "CountableTypes.countable_nat_product".
pose (sum_1_to_n := fix sum_1_to_n n:nat := match n with
| O => O
| S m => (sum_1_to_n m) + n
end).
exists (fun p:nat*nat => let (m,n):=p in
(sum_1_to_n (m+n)) + n).
assert (forall m n:nat, m<n ->
sum_1_to_n m + m < sum_1_to_n n).
intros.
induction H.
simpl.
auto with arith.
apply lt_trans with (sum_1_to_n m0).
assumption.
simpl.
assert (0 < S m0); auto with arith.
assert (sum_1_to_n m0 + 0 < sum_1_to_n m0 + S m0); auto with arith.
assert (sum_1_to_n m0 + 0 = sum_1_to_n m0); auto with arith.
rewrite H2 in H1; assumption.

red; intros.
destruct x1 as [x1 y1].
destruct x2 as [x2 y2].
Require Import Compare_dec.
case (lt_eq_lt_dec (x1+y1) (x2+y2)); intro.
case s; intro.
assert (sum_1_to_n (x1+y1) + y1 < sum_1_to_n (x2+y2) + y2).
apply le_lt_trans with (sum_1_to_n (x1+y1) + (x1+y1)).
assert (sum_1_to_n (x1+y1) + (x1+y1) =
(sum_1_to_n (x1+y1) + y1) + x1).
Require Import ArithRing.
ring.
auto with arith.
apply lt_le_trans with (sum_1_to_n (x2+y2)).
apply H; trivial.
auto with arith.
rewrite H0 in H1.
contradict H1.
auto with arith.

assert (y1=y2).
rewrite e in H0.
Require Import Arith.
apply plus_reg_l in H0.
assumption.
f_equal; trivial.
rewrite H1 in e.
rewrite plus_comm in e.
rewrite (plus_comm x2 y2) in e.
apply plus_reg_l in e.
assumption.

assert (sum_1_to_n (x2+y2) + y2 < sum_1_to_n (x1+y1) + y1).
apply le_lt_trans with (sum_1_to_n (x2+y2) + (x2+y2)).
auto with arith.
apply lt_le_trans with (sum_1_to_n (x1+y1)); auto with arith.
rewrite H0 in H1.
contradict H1.
auto with arith.
Qed.

Lemma countable_sum: forall X Y:Type,
CountableT X -> CountableT Y -> CountableT (X+Y).
Proof. hammer_hook "CountableTypes" "CountableTypes.countable_sum".
intros.
destruct H as [f].
destruct H0 as [g].
destruct countable_nat_product as [h].
exists (fun s:X+Y => match s with
| inl x => h (0, f x)
| inr y => h (1, g y)
end).
red; intros s1 s2 ?.
destruct s1 as [x1|y1]; destruct s2 as [x2|y2];
apply H1 in H2; try discriminate H2;
intros; f_equal; (apply H || apply H0); injection H2; trivial.
Qed.

Lemma countable_product: forall X Y:Type,
CountableT X -> CountableT Y -> CountableT (X*Y).
Proof. hammer_hook "CountableTypes" "CountableTypes.countable_product".
intros.
destruct H as [f].
destruct H0 as [g].
pose (fg := fun (p:X*Y) => let (x,y):=p in (f x, g y)).
destruct countable_nat_product as [h].
exists (fun p:X*Y => h (fg p)).
red; intros.
apply H1 in H2.
destruct x1 as [x1 y1].
destruct x2 as [x2 y2].
unfold fg in H2.
injection H2; intros.
apply H0 in H3.
apply H in H4.
f_equal; trivial.
Qed.

Require Import FunctionalExtensionality.

Lemma countable_exp: forall X Y:Type,
FiniteT X -> CountableT Y -> CountableT (X->Y).
Proof. hammer_hook "CountableTypes" "CountableTypes.countable_exp".
intros.
induction H.
exists (fun _ => 0).
red; intros.
extensionality f.
destruct f.

destruct (countable_product (T->Y) Y); trivial.

exists (fun (g:option T->Y) =>
f (fun x:T => g (Some x), g None)).
red; intros g1 g2 ?.
apply H1 in H2.
extensionality o.
destruct o.
injection H2; intros.
pose proof (equal_f H4).
simpl in H5.
apply H5.
injection H2; trivial.

destruct H1.
destruct IHFiniteT.
exists (fun (h:Y0->Y) => f0 (fun x:X => h (f x))).
red; intros h1 h2 ?.
apply H3 in H4.
pose proof (equal_f H4).
simpl in H5.
extensionality y.
rewrite <- (H2 y).
apply H5.
Qed.

Definition Countable {X:Type} (S:Ensemble X) : Prop :=
CountableT {x:X | In S x}.

Lemma inj_countable: forall {X Y:Type} (f:X->Y),
CountableT Y -> injective f -> CountableT X.
Proof. hammer_hook "CountableTypes" "CountableTypes.inj_countable".
intros.
destruct H as [g].
exists (fun x:X => g (f x)).
red; intros; auto.
Qed.

Lemma surj_countable: forall {X Y:Type} (f:X->Y),
CountableT X -> surjective f -> CountableT Y.
Proof. hammer_hook "CountableTypes" "CountableTypes.surj_countable".
intros.
Require Import ClassicalChoice.

pose proof (choice (fun (y:Y) (x:X) => f x = y)).
destruct H1 as [finv].
exact H0.

apply inj_countable with finv.
assumption.
red; intros.
congruence.
Qed.

Lemma countable_downward_closed: forall {X:Type} (S T:Ensemble X),
Countable T -> Included S T -> Countable S.
Proof. hammer_hook "CountableTypes" "CountableTypes.countable_downward_closed".
intros.
destruct H.
exists (fun x:{x:X | In S x} => match x with
| exist x0 i => f (exist _ x0 (H0 _ i))
end).
red; intros.
destruct x1 as [x1].
destruct x2 as [x2].
apply H in H1.
injection H1; intros.
destruct H2.
destruct (proof_irrelevance _ i i0).
trivial.
Qed.

Lemma countable_img: forall {X Y:Type} (f:X->Y) (S:Ensemble X),
Countable S -> Countable (Im S f).
Proof. hammer_hook "CountableTypes" "CountableTypes.countable_img".
intros.
assert (forall x:X, In S x -> In (Im S f) (f x)).
auto with sets.
pose (fS := fun x:{x:X | In S x} =>
match x return {y:Y | In (Im S f) y} with
| exist x0 i => exist _ (f x0) (H0 x0 i)
end).
apply surj_countable with fS; trivial.
red; intros.
destruct y.
destruct i.
exists (exist _ x i).
simpl.
generalize (H0 x i); intro.
generalize (Im_intro X Y S f x i y e); intro.
destruct e.
destruct (proof_irrelevance _ i0 i1).
trivial.
Qed.

Lemma countable_type_ensemble: forall {X:Type} (S:Ensemble X),
CountableT X -> Countable S.
Proof. hammer_hook "CountableTypes" "CountableTypes.countable_type_ensemble".
intros.
red.
apply inj_countable with (@proj1_sig _ (fun x:X => In S x)).
assumption.
red; intros.
apply proj1_sig_injective.
assumption.
Qed.

Lemma FiniteT_impl_CountableT: forall X:Type,
FiniteT X -> CountableT X.
Proof. hammer_hook "CountableTypes" "CountableTypes.FiniteT_impl_CountableT".
intros.
induction H.
exists (False_rect nat).
red; intros.
destruct x1.
destruct IHFiniteT.
exists (fun x:option T => match x with
| Some x0 => S (f x0)
| None => 0
end).
red; intros.
destruct x1; destruct x2; try (injection H1 || discriminate H1); trivial.
intro.
apply H0 in H2.
destruct H2; trivial.

destruct IHFiniteT as [g].
destruct H0 as [finv].
exists (fun y:Y => g (finv y)).
red; intros y1 y2 ?.
apply H1 in H3.
congruence.
Qed.

Lemma Finite_impl_Countable: forall {X:Type} (S:Ensemble X),
Finite _ S -> Countable S.
Proof. hammer_hook "CountableTypes" "CountableTypes.Finite_impl_Countable".
intros.
apply FiniteT_impl_CountableT.
apply Finite_ens_type; trivial.
Qed.

Require Export ZArith.

Lemma positive_countable: CountableT positive.
Proof. hammer_hook "CountableTypes" "CountableTypes.positive_countable".
exists nat_of_P.
red; intros.
apply nat_of_P_inj; trivial.
Qed.

Lemma Z_countable: CountableT Z.
Proof. hammer_hook "CountableTypes" "CountableTypes.Z_countable".
destruct (countable_nat_product) as [f].
destruct positive_countable as [g].
exists (fun n:Z => match n with
| Z0 => f (0, 0)
| Zpos p => f (1, g p)
| Zneg p => f (2, g p)
end).
red; intros n1 n2 ?.
destruct n1 as [|p1|p1]; destruct n2 as [|p2|p2]; apply H in H1;
try discriminate H1.
trivial.
injection H1; intro; f_equal; auto.
injection H1; intro; f_equal; auto.
Qed.

Require Export QArith.

Lemma Q_countable: CountableT Q.
Proof. hammer_hook "CountableTypes" "CountableTypes.Q_countable".
destruct countable_nat_product as [f].
destruct positive_countable as [g].
destruct Z_countable as [h].
exists (fun q:Q => match q with
n # d => f (h n, g d)
end).
red; intros q1 q2 ?.
destruct q1 as [n1 d1]; destruct q2 as [n2 d2].
apply H in H2.
injection H2; intros.
f_equal; auto.
Qed.

From ZornsLemma Require Export IndexedFamilies.

Lemma countable_union: forall {X A:Type}
(F:IndexedFamily A X), CountableT A ->
(forall a:A, Countable (F a)) ->
Countable (IndexedUnion F).
Proof. hammer_hook "CountableTypes" "CountableTypes.countable_union".
intros.
destruct (choice_on_dependent_type (fun (a:A)
(f:{x:X | In (F a) x} -> nat) =>
injective f)) as [choice_fun_inj].
intro.
destruct (H0 a).
exists f; trivial.

destruct (choice (fun (x:{x:X | In (IndexedUnion F) x}) (a:A) =>
In (F a) (proj1_sig x))) as [choice_fun_a].
destruct x as [x [a]].
exists a.
assumption.

destruct countable_nat_product as [g].
destruct H as [h].
exists (fun x:{x:X | In (IndexedUnion F) x} =>
g (h (choice_fun_a x), choice_fun_inj (choice_fun_a x)
(exist _ (proj1_sig x) (H2 x)))).
red; intros.
apply H3 in H4.
injection H4; intros.
apply H in H6.
revert H5.
generalize (H2 x1).
generalize (H2 x2).
rewrite H6.
intros.
apply H1 in H5.
injection H5.
apply proj1_sig_injective.
Qed.


(* week-01_fixpoints.v *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 17 Aug 2020 *)

(* ********** *)

Require Import Arith Bool.

(* ***** *)

Definition beq_option_nat (on1 on2 : option nat) : bool :=
  match on1 with
  | Some n1 =>
    match on2 with
    | Some n2 =>
      n1 =? n2
    | None =>
      false
    end
  | None =>
    match on2 with
    | Some n2 =>
      false
    | None =>
      true
    end
  end.

Definition beq_option_bool (ob1 ob2 : option bool) : bool :=
  match ob1 with
  | Some b1 =>
    match ob2 with
    | Some b2 =>
      eqb b1 b2
    | None =>
      false
    end
  | None =>
    match ob2 with
    | Some b2 =>
      false
    | None =>
      true
    end
  end.

(* ***** *)

Definition test_fac_0 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) None) &&
  (beq_option_nat (candidate 1) None) &&
  (beq_option_nat (candidate 2) None) &&
  (beq_option_nat (candidate 3) None) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition fac_0 (n : nat) : option nat :=
  None.

Compute (test_fac_0 fac_0). (* = true : bool *)

(* ***** *)

Definition test_fac_1 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some 1)) &&
  (beq_option_nat (candidate 1) None) &&
  (beq_option_nat (candidate 2) None) &&
  (beq_option_nat (candidate 3) None) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition fac_1 (n : nat) : option nat :=
  match n with
  | O =>
    Some 1
  | S n' =>
    match fac_0 n' with
    | Some fac_n' =>
      Some (n * fac_n')
    | None =>
      None
    end
  end.

Compute (eqb (test_fac_1 fac_0) false). (* = true : bool *)
Compute (test_fac_1 fac_1). (* = true : bool *)

(* ***** *)

Definition test_fac_2 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some 1)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) None) &&
  (beq_option_nat (candidate 3) None) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition fac_2 (n : nat) : option nat :=
  match n with
  | O =>
    Some 1
  | S n' =>
    match fac_1 n' with
    | Some fac_n' =>
      Some (n * fac_n')
    | None =>
      None
    end
  end.

Compute (eqb (test_fac_2 fac_0) false). (* = true : bool *)
Compute (eqb (test_fac_2 fac_1) false). (* = true : bool *)
Compute (test_fac_2 fac_2). (* = true : bool *)

(* ***** *)

Definition test_fac_3 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some 1)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 2)) &&
  (beq_option_nat (candidate 3) None) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition fac_3 (n : nat) : option nat :=
  match n with
  | O =>
    Some 1
  | S n' =>
    match fac_2 n' with
    | Some fac_n' =>
      Some (n * fac_n')
    | None =>
      None
    end
  end.

Compute (eqb (test_fac_3 fac_0) false). (* = true : bool *)
Compute (eqb (test_fac_3 fac_1) false). (* = true : bool *)
Compute (eqb (test_fac_3 fac_2) false). (* = true : bool *)
Compute (test_fac_3 fac_3). (* = true : bool *)

(* ***** *)

Definition test_fac_4 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some 1)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 2)) &&
  (beq_option_nat (candidate 3) (Some 6)) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition fac_4 (n : nat) : option nat :=
  match n with
  | O =>
    Some 1
  | S n' =>
    match fac_3 n' with
    | Some fac_n' =>
      Some (n * fac_n')
    | None =>
      None
    end
  end.

Compute (eqb (test_fac_4 fac_0) false). (* = true : bool *)
Compute (eqb (test_fac_4 fac_1) false). (* = true : bool *)
Compute (eqb (test_fac_4 fac_2) false). (* = true : bool *)
Compute (eqb (test_fac_4 fac_3) false). (* = true : bool *)
Compute (test_fac_4 fac_4). (* = true : bool *)

(* ***** *)

Definition test_fac_5 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some 1)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 2)) &&
  (beq_option_nat (candidate 3) (Some 6)) &&
  (beq_option_nat (candidate 4) (Some 24)) &&
  (beq_option_nat (candidate 5) None).

Definition fac_5 (n : nat) : option nat :=
  match n with
  | O =>
    Some 1
  | S n' =>
    match fac_4 n' with
    | Some fac_n' =>
      Some (n * fac_n')
    | None =>
      None
    end
  end.

Compute (eqb (test_fac_5 fac_0) false). (* = true : bool *)
Compute (eqb (test_fac_5 fac_1) false). (* = true : bool *)
Compute (eqb (test_fac_5 fac_2) false). (* = true : bool *)
Compute (eqb (test_fac_5 fac_3) false). (* = true : bool *)
Compute (eqb (test_fac_5 fac_4) false). (* = true : bool *)
Compute (test_fac_5 fac_5). (* = true : bool *)

(* ***** *)

Definition test_fac_6 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some 1)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 2)) &&
  (beq_option_nat (candidate 3) (Some 6)) &&
  (beq_option_nat (candidate 4) (Some 24)) &&
  (beq_option_nat (candidate 5) (Some 120)) &&
  (beq_option_nat (candidate 6) None).

Definition fac_6 (n : nat) : option nat :=
  match n with
  | O =>
    Some 1
  | S n' =>
    match fac_5 n' with
    | Some fac_n' =>
      Some (n * fac_n')
    | None =>
      None
    end
  end.

Compute (eqb (test_fac_6 fac_0) false). (* = true : bool *)
Compute (eqb (test_fac_6 fac_1) false). (* = true : bool *)
Compute (eqb (test_fac_6 fac_2) false). (* = true : bool *)
Compute (eqb (test_fac_6 fac_3) false). (* = true : bool *)
Compute (eqb (test_fac_6 fac_4) false). (* = true : bool *)
Compute (eqb (test_fac_6 fac_5) false). (* = true : bool *)
Compute (test_fac_6 fac_6). (* = true : bool *)

(* ***** *)

Definition Fac (fac : nat -> option nat) : nat -> option nat :=
  fun n =>
    match n with
    | O =>
      Some 1
    | S n' =>
      match fac n' with
      | Some fac_n' =>
        Some (n * fac_n')
      | None =>
        None
      end
    end.

Definition fac_1_alt := Fac fac_0.

Compute (test_fac_1 fac_1_alt). (* = true : bool *)

Definition fac_2_alt := Fac fac_1_alt.

Compute (test_fac_2 fac_2_alt). (* = true : bool *)

Definition fac_3_alt := Fac fac_2_alt.

Compute (test_fac_3 fac_3_alt). (* = true : bool *)

Definition fac_4_alt := Fac fac_3_alt.

Compute (test_fac_4 fac_4_alt). (* = true : bool *)

Definition fac_5_alt := Fac fac_4_alt.

Compute (test_fac_5 fac_5_alt). (* = true : bool *)

Definition fac_6_alt := Fac fac_5_alt.

Compute (test_fac_6 fac_6_alt). (* = true : bool *)

(* at the limit of this strictly increasing chain of approximants,
   therere is fac_oo_alt (where "oo" is pronounced "infinity")
   which is such that Fac f_oo_alt = f_oo_alt.
   This limit, f_oo_alt, is a fixed point of Fac,
   and is, mathematically, the factorial function.
   (Technically, it is even the least fixed point of Fac.)

   And that is how the keyword "Fixpoint" got its name.
*)

(* ***** *)

(* A closing word about bounded recursion:
   the argument of the factorial function determines the number of its recursive calls.
*)

Fixpoint nat_fold_right (V : Type) (zero_case : V) (succ_case : V -> V) (n : nat) : V :=
  match n with
  | O =>
    zero_case
  | S n' =>
    succ_case (nat_fold_right V zero_case succ_case n')
  end.

(* Key idea: evaluating
    nat_fold_right V z s 0 is equivalent to evaluating z
    nat_fold_right V z s 1 is equivalent to evaluating s z
    nat_fold_right V z s 2 is equivalent to evaluating s (s z)
    nat_fold_right V z s 3 is equivalent to evaluating s (s (s z))
    nat_fold_right V z s 4 is equivalent to evaluating s (s (s (s z)))
  i.e., in short, and abusing notation, evaluating
    nat_fold_right V z s n is equivalent to evaluating s^n z
  where s^n is the self-composition of s, n times
*)

(* ***** *)

Definition fac (n : nat) : option nat :=
  nat_fold_right (nat -> option nat) fac_0 Fac (S n) n.

Definition test_fac (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some 1)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 2)) &&
  (beq_option_nat (candidate 3) (Some 6)) &&
  (beq_option_nat (candidate 4) (Some 24)) &&
  (beq_option_nat (candidate 5) (Some 120)) &&
  (beq_option_nat (candidate 6) (Some 720)).

Compute (test_fac fac).

(* ********** *)

(*** Exercise 6 *)

(* Exercise: walk the same walk with the summatorial function,
   i.e., the function that given n, computes 0 + 1 + 2 + ... + n.
*)

Definition sum_0 (n : nat) : option nat :=
  None.

Definition sum_1 (n : nat) : option nat :=
  match n with
  | O => Some O
  | S n' => match sum_0 n' with
           | Some sum_n' => Some (n + sum_n')
           | None => None
           end
  end.

Definition sum_2 (n : nat) : option nat :=
  match n with
  | O => Some O
  | S n' => match sum_1 n' with
           | Some sum_n' => Some (n + sum_n')
           | None => None
           end
  end.

Definition test_sum_0 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) None) &&
  (beq_option_nat (candidate 1) None) &&
  (beq_option_nat (candidate 2) None) &&
  (beq_option_nat (candidate 3) None) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition test_sum_1 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some O)) &&
  (beq_option_nat (candidate 1) None) &&
  (beq_option_nat (candidate 2) None) &&
  (beq_option_nat (candidate 3) None) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition test_sum_2 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some O)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) None) &&
  (beq_option_nat (candidate 3) None) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition test_sum_3 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some O)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 3)) &&
  (beq_option_nat (candidate 3) None) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition test_sum_4 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some O)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 3)) &&
  (beq_option_nat (candidate 3) (Some 6)) &&
  (beq_option_nat (candidate 4) None) &&
  (beq_option_nat (candidate 5) None).

Definition test_sum_5 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some O)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 3)) &&
  (beq_option_nat (candidate 3) (Some 6)) &&
  (beq_option_nat (candidate 4) (Some 10)) &&
  (beq_option_nat (candidate 5) None).

Definition test_sum_6 (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some O)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 3)) &&
  (beq_option_nat (candidate 3) (Some 6)) &&
  (beq_option_nat (candidate 4) (Some 10)) &&
  (beq_option_nat (candidate 5) (Some 15)).

Compute (test_sum_2 sum_2).

Definition Sum (sum: nat -> option nat) : nat -> option nat :=
  fun n => match n with
        | O => Some O
        | S n' => match sum n' with
                 | Some sum_n' => Some (n + sum_n')
                 | None => None
                 end
        end.

Definition sum_1_alt := Sum sum_0.

Compute (test_sum_1 sum_1_alt). (* = true : bool *)

Definition sum_2_alt := Sum sum_1_alt.

Compute (test_sum_2 sum_2_alt). (* = true : bool *)

Definition sum_3_alt := Sum sum_2_alt.

Compute (test_sum_3 sum_3_alt). (* = true : bool *)

Definition sum_4_alt := Sum sum_3_alt.

Compute (test_sum_4 sum_4_alt). (* = true : bool *)

Definition sum_5_alt := Sum sum_4_alt.

Compute (test_sum_5 sum_5_alt). (* = true : bool *)

Definition sum_6_alt := Sum sum_5_alt.

Compute (test_sum_6 sum_6_alt). (* = true : bool *)

Definition sum (n : nat) :=
  nat_fold_right (nat -> option nat) sum_0 Sum (S n) n.

Definition test_sum (candidate : nat -> option nat) :=
  (beq_option_nat (candidate 0) (Some O)) &&
  (beq_option_nat (candidate 1) (Some 1)) &&
  (beq_option_nat (candidate 2) (Some 3)) &&
  (beq_option_nat (candidate 3) (Some 6)) &&
  (beq_option_nat (candidate 4) (Some 10)) &&
  (beq_option_nat (candidate 5) (Some 15)) &&
  (beq_option_nat (candidate 6) (Some 21)).

Compute (test_sum sum).

(* ********** *)

Definition test_even_and_odd_once (even odd : nat -> option bool) (n : nat) : bool :=
  (beq_option_bool (even (2 * n)) (Some true)) &&
  (beq_option_bool  (odd (2 * n)) (Some false)) &&
  (beq_option_bool (even (S (2 * n))) (Some false)) &&
  (beq_option_bool  (odd (S (2 * n))) (Some true)).

Definition test_even_and_odd (even odd : nat -> option bool) :=
  (beq_option_bool (even 0) (Some true)) &&
  (beq_option_bool  (odd 0) (Some false)) &&
  (beq_option_bool (even 1) (Some false)) &&
  (beq_option_bool  (odd 1) (Some true)) &&
  (beq_option_bool (even 2) (Some true)) &&
  (beq_option_bool  (odd 2) (Some false)) &&
  (beq_option_bool (even 3) (Some false)) &&
  (beq_option_bool  (odd 3) (Some true)) &&
  (beq_option_bool (even 4) (Some true)) &&
  (beq_option_bool  (odd 4) (Some false)) &&
  (beq_option_bool (even 5) (Some false)) &&
  (beq_option_bool  (odd 5) (Some true)) &&
  (test_even_and_odd_once even odd 10) &&
  (test_even_and_odd_once even odd 11).

Definition even (n : nat) : option bool :=
  let (even, _) := nat_fold_right ((nat -> option bool) * (nat -> option bool))
                                  (fun _ => None, fun _ => None)
                                  (fun p =>
                                     let (even, odd) := p
                                     in ((fun n =>
                                            match n with
                                            | O =>
                                              Some true
                                            | S n' =>
                                              odd n'
                                            end),
                                         (fun n =>
                                            match n with
                                            | O =>
                                              Some false
                                            | S n' =>
                                              even n'
                                            end)))
                                  (S n)
  in even n.

Definition odd (n : nat) : option bool :=
  let (_, odd) := nat_fold_right ((nat -> option bool) * (nat -> option bool))
                                 ((fun _ => None), (fun _ => None))
                                 (fun p =>
                                    let (even, odd) := p
                                    in ((fun n =>
                                           match n with
                                           | O =>
                                             Some true
                                           | S n' =>
                                             odd n'
                                           end),
                                        (fun n =>
                                           match n with
                                           | O =>
                                             Some false
                                           | S n' =>
                                             even n'
                                           end)))
                                 (S n)
  in odd n.

Compute (test_even_and_odd even odd).

(* ***** *)

Fixpoint even'_aux (n : nat) (a : bool) : option bool :=
  match n with
  | O =>
    Some a
  | S n' =>
    even'_aux n' (negb a)
  end.

Definition even' (n : nat) : option bool :=
  even'_aux n true.

Fixpoint odd'_aux (n : nat) (a : bool) : option bool :=
  match n with
  | O =>
    Some a
  | S n' =>
    odd'_aux n' (negb a)
  end.

Definition odd' (n : nat) : option bool :=
  odd'_aux n false.

Compute (test_even_and_odd even' odd').

(* ***** *)

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

Definition even'' (n : nat) : bool :=
  even''_aux n.

Definition odd'' (n : nat) : bool :=
  odd''_aux n.

Compute (test_even_and_odd (fun n => Some (even'' n)) (fun n => Some (odd'' n))).

(* ********** *)

(*** Exercise 7 *)

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

Definition test_ternaries_once (ternary pre_ternary post_ternary : nat -> option bool) (n : nat) : bool :=
  (beq_option_bool (ternary (3 * n)) (Some true)) &&
  (beq_option_bool (pre_ternary (3 * n)) (Some false)) &&
  (beq_option_bool (post_ternary (3 * n)) (Some false)) &&
  (beq_option_bool (ternary (S (3 * n))) (Some false)) &&
  (beq_option_bool (pre_ternary (S (3 * n))) (Some false)) &&
  (beq_option_bool (post_ternary (S (3 * n))) (Some true)) &&
  (beq_option_bool (ternary (S (S (3 * n)))) (Some false)) &&
  (beq_option_bool (pre_ternary (S (S (3 * n)))) (Some true)) &&
  (beq_option_bool (post_ternary (S (S (3 * n)))) (Some false)).

Definition test_ternaries (ternary pre_ternary post_ternary : nat -> option bool) :=
  (test_ternaries_once ternary pre_ternary post_ternary 0) &&
  (test_ternaries_once ternary pre_ternary post_ternary 1) &&
  (test_ternaries_once ternary pre_ternary post_ternary 2) &&
  (test_ternaries_once ternary pre_ternary post_ternary 3) &&
  (test_ternaries_once ternary pre_ternary post_ternary 4) &&
  (test_ternaries_once ternary pre_ternary post_ternary 5) &&
  (test_ternaries_once ternary pre_ternary post_ternary 6) &&
  (test_ternaries_once ternary pre_ternary post_ternary 7) &&
  (test_ternaries_once ternary pre_ternary post_ternary 8) &&
  (test_ternaries_once ternary pre_ternary post_ternary 9) &&
  (test_ternaries_once ternary pre_ternary post_ternary 10).

Compute (test_ternaries (fun n => Some (ternary n)) (fun n => Some (pre_ternary n)) (fun n => Some (post_ternary n))).

(* end of week-01_fixpoints.v *)


Require Import compcert.lib.Coqlib.
Require Import VST.msl.Coqlib2.

(* deliberately imported here *)
Require Import Coq.Wellfounded.Inclusion.
Require Import Coq.Wellfounded.Inverse_Image.

(* ssreflect *)

From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

Require Import VST.concurrency.pos.
Require Import VST.concurrency.cast.

(** * Well-Founded Orders *)

(** This file defines a generalized lexicographic order on dependently
typed products.  It exposes the following interface: *)

(** Assumptions:
- [Variable N : nat.]
- [Variable N_pos : (0 < N)%coq_nat.]
- [Variable types : 'I_N -> Type.]
- [Variable ords  : forall i : 'I_N, types i -> types i -> Prop.]
- [Variable wf_ords : forall i : 'I_N, well_founded (@ords i).] *)

(** Exported:
- [t        : Type]
- [mk       : (forall i : 'I_N, types i) -> t]
- [get      : (i : 'I_N) (d : t), types i]
- [set      : {i : 'I_N} (d : t) (x : types i), t]
- [ord      : t -> t -> Prop]
- [wf_ord   : well_founded ord]
- [ord_set  : (i : 'I_N) (d : t) (x : types i),
               ords i x (get i d) -> ord (set d x) d]
- [gss      : (i : 'I_N) (x : types i) (d : t), get i (set i x d) = x]
- [gso      : (i j : 'I_N) (x : types i) (d : t),
               i <> j -> get j (set i x d) = get j d] *)

(** In addition, it defines a WF order on the [\Sigma]-type
      [\Sigma ix : 'I_N. T ix] *)

Lemma ord_dec (N : nat) (i j : 'I_N) : {i=j} + {~i=j}.
Proof.
case: i; case: j=> m pf n pf'; move: pf pf'; case: (eq_nat_dec n m).
by move=> -> pf pf'; left; f_equal; apply: proof_irr.
by move=> neq pf pf'; right; case.
Qed.

Lemma wf_eta {A: Type}{f: A -> A -> Prop} :
  well_founded f -> well_founded (fun a1 a2 => f a1 a2).
Proof.
by move=> H1; have ->: ((fun a1 a2 => f a1 a2) = f) by do 2 extensionality.
Qed.

Lemma wf_eta' {A: Type}{f: A -> A -> Prop} :
  well_founded (fun a1 a2 => f a1 a2) -> well_founded f.
Proof.
by move=> H1; have <-: ((fun a1 a2 => f a1 a2) = f) by do 2 extensionality.
Qed.

Lemma wf_funct {A B: Type}{R: B -> B -> Prop}(f: A -> B) :
  well_founded R -> well_founded (fun a1 a2 => R (f a1) (f a2)).
Proof.
move=> H1; set (F := fun a b => f a = b).
apply: (wf_incl _ _
 (fun x y: A => exists2 b : B, F x b & forall c : B, F y c -> R b c)).
by move=> a1 a2 HR; exists (f a1); rewrite/F=> //; move=> b <-.
by apply: wf_inverse_rel.
Qed.

Module Type LEX.

Parameter t : forall (N : pos) (types : 'I_N -> Type), Type.

Arguments t {N} types.

Parameter ord : forall (N : pos)
  (types : 'I_N -> Type) (ords : forall i : 'I_N, types i -> types i -> Prop),
  t types -> t types -> Prop.

Parameter wf_ord : forall (N : pos)
  (types : 'I_N -> Type) (ords : forall i : 'I_N, types i -> types i -> Prop)
  (wf_ords : forall i : 'I_N, well_founded (ords i)),
  well_founded (ord ords).

Section lex.

Variable N : pos.
Variable types : 'I_N -> Type.
Variable ords  : forall i : 'I_N, types i -> types i -> Prop.
Variable wf_ords : forall i : 'I_N, well_founded (@ords i).

Notation t   := (t types).
Notation ord := (@ord N types ords).

Parameter mk  : (forall i : 'I_N, types i) -> t.
Parameter get : forall i : 'I_N, t -> types i.
Parameter set : forall (i : 'I_N) (x : types i), t -> t.
Parameter ord_upd :
  forall (i : 'I_N) (x : types i) (d : t),
  ords x (get i d) -> ord (set x d) d.
Parameter gss :
  forall (i : 'I_N) (x : types i) (d : t), get i (set x d) = x.
Parameter gso :
  forall (i j : 'I_N) (x : types i) (d : t), i <> j ->
    get j (set x d) = get j d.

End lex. End LEX.

Module Lex : LEX. Section lex.

Variable N : pos.
Variable types : 'I_N -> Type.
Variable ords  : forall i : 'I_N, types i -> types i -> Prop.
Variable wf_ords : forall i : 'I_N, well_founded (@ords i).

Lemma N_minus_lt (n : nat) : ((N - S n) < N)%N.
Proof. case: N=> m pf; rewrite -minusE; apply/ltP=> /=; omega. Qed.

Definition t : Type := forall i : 'I_N, types i.

Definition mk : t -> t := id.

Fixpoint ty' (n : nat) : Type :=
  match n with
    | O => unit
    | S n' => (types (Ordinal (N_minus_lt n')) * ty' n')%type
  end.

Fixpoint ty_intro' (n : nat) (data : t) : ty' n :=
  match n as m in nat return ty' m with
    | O => tt
    | S n' => (data (Ordinal (N_minus_lt n')), ty_intro' n' data)
  end.

Definition ty := ty' N.

Definition ty_intro := ty_intro' N.

Fixpoint ord' (n : nat) : ty' n -> ty' n -> Prop :=
  match n as m in nat return ty' m -> ty' m -> Prop with
    | O => fun d1 d2 => False
    | S n' => fun d1 d2 =>
        lex_ord (@ords (Ordinal (N_minus_lt n'))) (ord' n') d1 d2
  end.

Lemma wf_ord' n : well_founded (ord' n).
Proof.
rewrite/ord'; move: wf_ords; move: ords; clear ords wf_ords.
induction n=> ords WF; first by constructor.
apply: wf_eta; apply: wf_lex_ord; first by [].
by apply: (IHn ords).
Qed.

Definition ord (d1 d2 : t) := ord' N (ty_intro d1) (ty_intro d2).

Lemma wf_ord : well_founded ord.
Proof. by rewrite/ord; apply: wf_funct; apply: wf_ord'. Qed.

Definition cast_ty (T1 T2: Type) (pf: T1=T2) (x : T1) : T2.
Proof.
rewrite pf in x; refine x.
Defined.

Lemma types_eq (i j : 'I_N) : i=j -> types i=types j.
Proof. by move=> ->. Defined.

Definition get i (d : t) : types i := d i.

Definition set i (new_i : types i) (d : t) : t :=
  fun j : 'I_N =>
    match ord_dec i j with
      | left pf => cast_ty (types_eq pf) new_i
      | right _ => d j
    end.
Implicit Arguments set [].

Lemma gss i x d : get i (set i x d) = x.
Proof.
rewrite/get/set; case: (ord_dec i i)=> //.
rewrite/cast_ty/eq_rect_r/eq_rect/types_eq/eq_ind_r/eq_ind/eq_rect=> e.
by rewrite (UIP_refl _ _ e).
Qed.

Lemma gso i j x d : i<>j -> get j (set i x d) = get j d.
Proof. by rewrite/get/set; case: (ord_dec i j). Qed.

Local Open Scope nat_scope.

Lemma ord_upd' : forall i data1 data2 num_cores,
  @ords i (get i data2) (get i data1) ->
  (N - num_cores <= i < N)%nat -> (num_cores <= N)%nat ->
  (forall j : 'I_N, j < i -> get j data1=get j data2) ->
  ord' num_cores (ty_intro' num_cores data2) (ty_intro' num_cores data1).
Proof.
move=> [i pf] d1 d2 num_cores H1; move/andP=> []; move/leP=> H2; move/ltP.
induction num_cores as [|n]; first by rewrite -minusE /= in H2=> /= H3; omega.
move=> /= H3 H4 H5; case: (ord_dec (Ordinal pf) (Ordinal (N_minus_lt n))).
by move=> EQ; apply: lex_ord_left; rewrite -EQ.
rewrite/get in H5; move=> NEQ; rewrite -H5; have NEQ2: (i <> N - n.+1)
  by move=> H6; apply: NEQ; subst; f_equal; apply: proof_irr.
have: (N - S n < i) by apply/ltP; simpl in H2; omega.
move/ltP=> H6; apply lex_ord_right; apply: IHn=> //=.
by move: H6; rewrite -minusE=> H6; omega.
by move: (ltP H4)=> H7; apply/leP; omega.
have H6: (i <> N - n.+1)
  by move=> H6; apply: NEQ; subst; f_equal; apply: proof_irr.
by move: H2=> /= H2; apply/ltP; omega.
Qed.

Lemma ord_upd i x d : ords x (get i d) -> ord (set i x d) d.
Proof.
move=> A; apply ord_upd' with (i := i)=> //.
rewrite gss=> //.
have B: (O <= i < N) by apply/andP; split.
rewrite -minusE; move: (andP B)=> {A B}[]A B.
move: (leP A)=> A'; move: (ltP B)=> B'; apply/andP; split.
- by apply/leP; omega.
- by apply/ltP; omega.
move=> j Hlt; rewrite gso=> //.
case: i x A Hlt; case: j=> /= i pf new_i A Hlt j pf'=> H1.
by move: pf'; case: H1=> ->; move/ltP=> ?; omega.
Qed.

End lex.

End Lex.

(** The following defines a wf-order on the type
      \Sigma ix : 'I_N. T ix *)

Section sig_ord.

Variable N : pos.

Variable T : 'I_N -> Type.

Variable ords : forall ix : 'I_N, T ix -> T ix -> Prop.

Variable ords_wf : forall ix, well_founded (@ords ix).

Definition sig_data := {ix : 'I_N & T ix}.

Definition sig_ord (x y : sig_data) :=
  exists pf : projT1 x = projT1 y,
    (@ords (projT1 x))
      (projT2 x)
      (cast_ty (lift_eq _ (sym_eq pf)) (projT2 y)).

Lemma wf_sig_ord : well_founded sig_ord.
Proof.
move=> []i.
apply (well_founded_induction (@ords_wf i)).
move=> x IH.
apply: Acc_intro=> []j []/=pf H2.

have H3: @ords i (cast _ pf (projT2 j)) x.
{ move: pf H2; case: j=> /= ix j pf; subst ix.
  by rewrite !cast_ty_erefl. }

case: (IH _ H3)=> H4.

apply: Acc_intro=> y H5; apply: H4.

have pf2: projT1 y = i.
{ by case: H5=> pf0 _; rewrite pf0. }

exists pf2=> /=.

move: pf2; set r := projT1 y; subst i.
rewrite cast_ty_erefl.

move=> pf2; move: H5; subst r; case=> pf3.
by have ->: sym_eq pf3 = sym_eq pf2 by apply: proof_irr.
Qed.

End sig_ord.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Bool Morphisms Setoid Bvector BinPos BinNat PeanoNat Pnat Nnat.

Local Open Scope N_scope.

(** This file is mostly obsolete, see directly [BinNat] now. *)

(** Compatibility names for some bitwise operations *)

Notation Pxor := Pos.lxor (only parsing).
Notation Nxor := N.lxor (only parsing).
Notation Pbit := Pos.testbit_nat (only parsing).
Notation Nbit := N.testbit_nat (only parsing).

Notation Nxor_eq := N.lxor_eq (only parsing).
Notation Nxor_comm := N.lxor_comm (only parsing).
Notation Nxor_assoc := N.lxor_assoc (only parsing).
Notation Nxor_neutral_left := N.lxor_0_l (only parsing).
Notation Nxor_neutral_right := N.lxor_0_r (only parsing).
Notation Nxor_nilpotent := N.lxor_nilpotent (only parsing).

(** Equivalence of bit-testing functions,
    either with index in [N] or in [nat]. *)

Lemma Ptestbit_Pbit :
 forall p n, Pos.testbit p (N.of_nat n) = Pos.testbit_nat p n.
Proof.
 induction p as [p IH|p IH| ]; intros [|n]; simpl; trivial;
  rewrite <- IH; f_equal; rewrite (pred_Sn n) at 2; now rewrite Nat2N.inj_pred.
Qed.

Lemma Ntestbit_Nbit : forall a n, N.testbit a (N.of_nat n) = N.testbit_nat a n.
Proof.
 destruct a. trivial. apply Ptestbit_Pbit.
Qed.

Lemma Pbit_Ptestbit :
 forall p n, Pos.testbit_nat p (N.to_nat n) = Pos.testbit p n.
Proof.
 intros; now rewrite <- Ptestbit_Pbit, N2Nat.id.
Qed.

Lemma Nbit_Ntestbit :
 forall a n, N.testbit_nat a (N.to_nat n) = N.testbit a n.
Proof.
 destruct a. trivial. apply Pbit_Ptestbit.
Qed.

(** Equivalence of shifts, index in [N] or [nat] *)

Lemma Nshiftr_nat_S : forall a n,
 N.shiftr_nat a (S n) = N.div2 (N.shiftr_nat a n).
Proof.
 reflexivity.
Qed.

Lemma Nshiftl_nat_S : forall a n,
 N.shiftl_nat a (S n) = N.double (N.shiftl_nat a n).
Proof.
 reflexivity.
Qed.

Lemma Nshiftr_nat_equiv :
 forall a n, N.shiftr_nat a (N.to_nat n) = N.shiftr a n.
Proof.
 intros a [|n]; simpl. unfold N.shiftr_nat.
 trivial.
 symmetry. apply Pos2Nat.inj_iter.
Qed.

Lemma Nshiftr_equiv_nat :
 forall a n, N.shiftr a (N.of_nat n) = N.shiftr_nat a n.
Proof.
 intros. now rewrite <- Nshiftr_nat_equiv, Nat2N.id.
Qed.

Lemma Nshiftl_nat_equiv :
 forall a n, N.shiftl_nat a (N.to_nat n) = N.shiftl a n.
Proof.
 intros [|a] [|n]; simpl; unfold N.shiftl_nat; trivial.
 induction (Pos.to_nat n) as [|? H]; simpl; now try rewrite H.
 rewrite <- Pos2Nat.inj_iter. symmetry. now apply Pos.iter_swap_gen.
Qed.

Lemma Nshiftl_equiv_nat :
 forall a n, N.shiftl a (N.of_nat n) = N.shiftl_nat a n.
Proof.
 intros. now rewrite <- Nshiftl_nat_equiv, Nat2N.id.
Qed.

(** Correctness proofs for shifts, nat version *)

Lemma Nshiftr_nat_spec : forall a n m,
  N.testbit_nat (N.shiftr_nat a n) m = N.testbit_nat a (m+n).
Proof.
 induction n; intros m.
 now rewrite <- plus_n_O.
 simpl. rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn.
 destruct (N.shiftr_nat a n) as [|[p|p|]]; simpl; trivial.
Qed.

Lemma Nshiftl_nat_spec_high : forall a n m, (n<=m)%nat ->
  N.testbit_nat (N.shiftl_nat a n) m = N.testbit_nat a (m-n).
Proof.
 induction n; intros m H.
 - now rewrite Nat.sub_0_r.
 - destruct m.
   + inversion H.
   + apply le_S_n in H.
     simpl. rewrite <- IHn; trivial.
     destruct (N.shiftl_nat a n) as [|[p|p|]]; simpl; trivial.
Qed.

Lemma Nshiftl_nat_spec_low : forall a n m, (m<n)%nat ->
 N.testbit_nat (N.shiftl_nat a n) m = false.
Proof.
 induction n; intros m H. inversion H.
 rewrite Nshiftl_nat_S.
 destruct m.
 - destruct (N.shiftl_nat a n); trivial.
 - apply Lt.lt_S_n in H.
   specialize (IHn m H).
   destruct (N.shiftl_nat a n); trivial.
Qed.

(** A left shift for positive numbers (used in BigN) *)

Lemma Pshiftl_nat_0 : forall p, Pos.shiftl_nat p 0 = p.
Proof. reflexivity. Qed.

Lemma Pshiftl_nat_S :
 forall p n, Pos.shiftl_nat p (S n) = xO (Pos.shiftl_nat p n).
Proof. reflexivity. Qed.

Lemma Pshiftl_nat_N :
 forall p n, Npos (Pos.shiftl_nat p n) = N.shiftl_nat (Npos p) n.
Proof.
 unfold Pos.shiftl_nat, N.shiftl_nat.
 induction n; simpl; auto. now rewrite <- IHn.
Qed.

Lemma Pshiftl_nat_plus : forall n m p,
  Pos.shiftl_nat p (m + n) = Pos.shiftl_nat (Pos.shiftl_nat p n) m.
Proof.
 induction m; simpl; intros. reflexivity.
 now f_equal.
Qed.

(** Semantics of bitwise operations with respect to [N.testbit_nat] *)

Lemma Pxor_semantics p p' n :
 N.testbit_nat (Pos.lxor p p') n = xorb (Pos.testbit_nat p n) (Pos.testbit_nat p' n).
Proof.
 rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_lxor_spec.
Qed.

Lemma Nxor_semantics a a' n :
 N.testbit_nat (N.lxor a a') n = xorb (N.testbit_nat a n) (N.testbit_nat a' n).
Proof.
 rewrite <- !Ntestbit_Nbit. apply N.lxor_spec.
Qed.

Lemma Por_semantics p p' n :
 Pos.testbit_nat (Pos.lor p p') n = (Pos.testbit_nat p n) || (Pos.testbit_nat p' n).
Proof.
 rewrite <- !Ptestbit_Pbit. apply N.pos_lor_spec.
Qed.

Lemma Nor_semantics a a' n :
 N.testbit_nat (N.lor a a') n = (N.testbit_nat a n) || (N.testbit_nat a' n).
Proof.
 rewrite <- !Ntestbit_Nbit. apply N.lor_spec.
Qed.

Lemma Pand_semantics p p' n :
 N.testbit_nat (Pos.land p p') n = (Pos.testbit_nat p n) && (Pos.testbit_nat p' n).
Proof.
 rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_land_spec.
Qed.

Lemma Nand_semantics a a' n :
 N.testbit_nat (N.land a a') n = (N.testbit_nat a n) && (N.testbit_nat a' n).
Proof.
 rewrite <- !Ntestbit_Nbit. apply N.land_spec.
Qed.

Lemma Pdiff_semantics p p' n :
 N.testbit_nat (Pos.ldiff p p') n = (Pos.testbit_nat p n) && negb (Pos.testbit_nat p' n).
Proof.
 rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_ldiff_spec.
Qed.

Lemma Ndiff_semantics a a' n :
 N.testbit_nat (N.ldiff a a') n = (N.testbit_nat a n) && negb (N.testbit_nat a' n).
Proof.
 rewrite <- !Ntestbit_Nbit. apply N.ldiff_spec.
Qed.

(** Equality over functional streams of bits *)

Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n.

Program Instance eqf_equiv : Equivalence eqf.

Local Infix "==" := eqf (at level 70, no associativity).

(** If two numbers produce the same stream of bits, they are equal. *)

Local Notation Step H := (fun n => H (S n)).

Lemma Pbit_faithful_0 : forall p, ~(Pos.testbit_nat p == (fun _ => false)).
Proof.
 induction p as [p IHp|p IHp| ]; intros H; try discriminate (H O).
  apply (IHp (Step H)).
Qed.

Lemma Pbit_faithful : forall p p', Pos.testbit_nat p == Pos.testbit_nat p' -> p = p'.
Proof.
 induction p as [p IHp|p IHp| ]; intros [p'|p'|] H; trivial;
  try discriminate (H O).
 f_equal. apply (IHp _ (Step H)).
 destruct (Pbit_faithful_0 _ (Step H)).
 f_equal. apply (IHp _ (Step H)).
 symmetry in H. destruct (Pbit_faithful_0 _ (Step H)).
Qed.

Lemma Nbit_faithful : forall n n', N.testbit_nat n == N.testbit_nat n' -> n = n'.
Proof.
 intros [|p] [|p'] H; trivial.
 symmetry in H. destruct (Pbit_faithful_0 _ H).
 destruct (Pbit_faithful_0 _ H).
 f_equal. apply Pbit_faithful, H.
Qed.

Lemma Nbit_faithful_iff : forall n n', N.testbit_nat n == N.testbit_nat n' <-> n = n'.
Proof.
 split. apply Nbit_faithful. intros; now subst.
Qed.

Local Close Scope N_scope.

(** Checking whether a number is odd, i.e.
   if its lower bit is set. *)

Notation Nbit0 := N.odd (only parsing).

Definition Nodd (n:N) := N.odd n = true.
Definition Neven (n:N) := N.odd n = false.

Lemma Nbit0_correct : forall n:N, N.testbit_nat n 0 = N.odd n.
Proof.
  destruct n; trivial.
  destruct p; trivial.
Qed.

Lemma Ndouble_bit0 : forall n:N, N.odd (N.double n) = false.
Proof.
  destruct n; trivial.
Qed.

Lemma Ndouble_plus_one_bit0 :
 forall n:N, N.odd (N.succ_double n) = true.
Proof.
  destruct n; trivial.
Qed.

Lemma Ndiv2_double :
 forall n:N, Neven n -> N.double (N.div2 n) = n.
Proof.
  destruct n. trivial. destruct p. intro H. discriminate H.
  intros. reflexivity.
  intro H. discriminate H.
Qed.

Lemma Ndiv2_double_plus_one :
 forall n:N, Nodd n -> N.succ_double (N.div2 n) = n.
Proof.
  destruct n. intro. discriminate H.
  destruct p. intros. reflexivity.
  intro H. discriminate H.
  intro. reflexivity.
Qed.

Lemma Ndiv2_correct :
 forall (a:N) (n:nat), N.testbit_nat (N.div2 a) n = N.testbit_nat a (S n).
Proof.
  destruct a; trivial.
  destruct p; trivial.
Qed.

Lemma Nxor_bit0 :
 forall a a':N, N.odd (N.lxor a a') = xorb (N.odd a) (N.odd a').
Proof.
  intros. rewrite <- Nbit0_correct, (Nxor_semantics a a' O).
  rewrite Nbit0_correct, Nbit0_correct. reflexivity.
Qed.

Lemma Nxor_div2 :
 forall a a':N, N.div2 (N.lxor a a') = N.lxor (N.div2 a) (N.div2 a').
Proof.
  intros. apply Nbit_faithful. unfold eqf. intro.
  rewrite (Nxor_semantics (N.div2 a) (N.div2 a') n), Ndiv2_correct, (Nxor_semantics a a' (S n)).
  rewrite 2! Ndiv2_correct.
  reflexivity.
Qed.

Lemma Nneg_bit0 :
 forall a a':N,
   N.odd (N.lxor a a') = true -> N.odd a = negb (N.odd a').
Proof.
  intros.
  rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc,
    xorb_nilpotent, xorb_false.
  reflexivity.
Qed.

Lemma Nneg_bit0_1 :
 forall a a':N, N.lxor a a' = Npos 1 -> N.odd a = negb (N.odd a').
Proof.
  intros. apply Nneg_bit0. rewrite H. reflexivity.
Qed.

Lemma Nneg_bit0_2 :
 forall (a a':N) (p:positive),
   N.lxor a a' = Npos (xI p) -> N.odd a = negb (N.odd a').
Proof.
  intros. apply Nneg_bit0. rewrite H. reflexivity.
Qed.

Lemma Nsame_bit0 :
 forall (a a':N) (p:positive),
   N.lxor a a' = Npos (xO p) -> N.odd a = N.odd a'.
Proof.
  intros. rewrite <- (xorb_false (N.odd a)).
  assert (H0: N.odd (Npos (xO p)) = false) by reflexivity.
  rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb.
    reflexivity.
Qed.

(** a lexicographic order on bits, starting from the lowest bit *)

Fixpoint Nless_aux (a a':N) (p:positive) : bool :=
  match p with
  | xO p' => Nless_aux (N.div2 a) (N.div2 a') p'
  | _ => andb (negb (N.odd a)) (N.odd a')
  end.

Definition Nless (a a':N) :=
  match N.lxor a a' with
  | N0 => false
  | Npos p => Nless_aux a a' p
  end.

Lemma Nbit0_less :
 forall a a',
   N.odd a = false -> N.odd a' = true -> Nless a a' = true.
Proof.
  intros. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless.
  rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity.
  assert (H1: N.odd (N.lxor a a') = false) by (rewrite H2; reflexivity).
  rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1.
  simpl. rewrite H, H0. reflexivity.
  assert (H2: N.odd (N.lxor a a') = false) by (rewrite H1; reflexivity).
  rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2.
Qed.

Lemma Nbit0_gt :
 forall a a',
   N.odd a = true -> N.odd a' = false -> Nless a a' = false.
Proof.
  intros. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless.
  rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity.
  assert (H1: N.odd (N.lxor a a') = false) by (rewrite H2; reflexivity).
  rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1.
  simpl. rewrite H, H0. reflexivity.
  assert (H2: N.odd (N.lxor a a') = false) by (rewrite H1; reflexivity).
  rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2.
Qed.

Lemma Nless_not_refl : forall a, Nless a a = false.
Proof.
  intro. unfold Nless. rewrite (N.lxor_nilpotent a). reflexivity.
Qed.

Lemma Nless_def_1 :
 forall a a', Nless (N.double a) (N.double a') = Nless a a'.
Proof.
  destruct a; destruct a'. reflexivity.
  trivial.
  unfold Nless. simpl. destruct p; trivial.
  unfold Nless. simpl. destruct (Pos.lxor p p0). reflexivity.
  trivial.
Qed.

Lemma Nless_def_2 :
 forall a a',
   Nless (N.succ_double a) (N.succ_double a') = Nless a a'.
Proof.
  destruct a; destruct a'. reflexivity.
  trivial.
  unfold Nless. simpl. destruct p; trivial.
  unfold Nless. simpl. destruct (Pos.lxor p p0). reflexivity.
  trivial.
Qed.

Lemma Nless_def_3 :
 forall a a', Nless (N.double a) (N.succ_double a') = true.
Proof.
  intros. apply Nbit0_less. apply Ndouble_bit0.
  apply Ndouble_plus_one_bit0.
Qed.

Lemma Nless_def_4 :
 forall a a', Nless (N.succ_double a) (N.double a') = false.
Proof.
  intros. apply Nbit0_gt. apply Ndouble_plus_one_bit0.
  apply Ndouble_bit0.
Qed.

Lemma Nless_z : forall a, Nless a N0 = false.
Proof.
  induction a. reflexivity.
  unfold Nless. rewrite (N.lxor_0_r (Npos p)). induction p; trivial.
Qed.

Lemma N0_less_1 :
 forall a, Nless N0 a = true -> {p : positive | a = Npos p}.
Proof.
  destruct a. discriminate.
  intros. exists p. reflexivity.
Qed.

Lemma N0_less_2 : forall a, Nless N0 a = false -> a = N0.
Proof.
  induction a as [|p]; intro H. trivial.
  exfalso. induction p as [|p IHp|]; discriminate || simpl; auto using IHp.
Qed.

Lemma Nless_trans :
 forall a a' a'',
   Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true.
Proof.
  induction a as [|a IHa|a IHa] using N.binary_ind; intros a' a'' H H0.
  - case_eq (Nless N0 a'') ; intros Heqn.
    + trivial.
    + rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0.
  - induction a' as [|a' _|a' _] using N.binary_ind.
    + rewrite (Nless_z (N.double a)) in H. discriminate H.
    + rewrite (Nless_def_1 a a') in H.
      induction a'' using N.binary_ind.
      * rewrite (Nless_z (N.double a')) in H0. discriminate H0.
      * rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a'').
        exact (IHa _ _ H H0).
      * apply Nless_def_3.
    + induction a'' as [|a'' _|a'' _] using N.binary_ind.
      * rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
      * rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
      * apply Nless_def_3.
  - induction a' as [|a' _|a' _] using N.binary_ind.
    + rewrite (Nless_z (N.succ_double a)) in H. discriminate H.
    + rewrite (Nless_def_4 a a') in H. discriminate H.
    + induction a'' using N.binary_ind.
      * rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
      * rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
      * rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H.
        rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0).
Qed.

Lemma Nless_total :
 forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}.
Proof.
  induction a using N.binary_rec; intro a'.
  - case_eq (Nless N0 a') ; intros Heqb.
    + left. left. auto.
    + right. rewrite (N0_less_2 a' Heqb). reflexivity.
  - induction a' as [|a' _|a' _] using N.binary_rec.
    + case_eq (Nless N0 (N.double a)) ; intros Heqb.
      * left. right. auto.
      * right. exact (N0_less_2 _  Heqb).
    + rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->].
      * left. assumption.
      * right. reflexivity.
    + left. left. apply Nless_def_3.
  - induction a' as [|a' _|a' _] using N.binary_rec.
    + left. right. destruct a; reflexivity.
    + left. right. apply Nless_def_3.
    + rewrite 2!Nless_def_2. destruct (IHa a') as [ | ->].
      * left. assumption.
      * right. reflexivity.
Qed.

(** Number of digits in a number *)

Notation Nsize := N.size_nat (only parsing).

(** conversions between N and bit vectors. *)

Fixpoint P2Bv (p:positive) : Bvector (Pos.size_nat p) :=
 match p return Bvector (Pos.size_nat p) with
   | xH => Bvect_true 1%nat
   | xO p => Bcons false (Pos.size_nat p) (P2Bv p)
   | xI p => Bcons true (Pos.size_nat p) (P2Bv p)
 end.

Definition N2Bv (n:N) : Bvector (N.size_nat n) :=
  match n as n0 return Bvector (N.size_nat n0) with
    | N0 => Bnil
    | Npos p => P2Bv p
  end.

Fixpoint Bv2N (n:nat)(bv:Bvector n) : N :=
  match bv with
    | Vector.nil _ => N0
    | Vector.cons _ false n bv => N.double (Bv2N n bv)
    | Vector.cons _ true n bv => N.succ_double (Bv2N n bv)
  end.

Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n.
Proof.
destruct n.
simpl; auto.
induction p; simpl in *; auto; rewrite IHp; simpl; auto.
Qed.

(** The opposite composition is not so simple: if the considered
  bit vector has some zeros on its right, they will disappear during
  the return [Bv2N] translation: *)

Lemma Bv2N_Nsize : forall n (bv:Bvector n), N.size_nat (Bv2N n bv) <= n.
Proof.
induction bv; intros.
auto.
simpl.
destruct h;
 destruct (Bv2N n bv);
 simpl ; auto with arith.
Qed.

(** In the previous lemma, we can only replace the inequality by
  an equality whenever the highest bit is non-null. *)

Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)),
  Bsign _ bv = true <->
  N.size_nat (Bv2N _ bv) = (S n).
Proof.
apply Vector.rectS ; intros ; simpl.
destruct a ; compute ; split ; intros x ; now inversion x.
 destruct a, (Bv2N (S n) v) ;
  simpl ;intuition ; try discriminate.
Qed.

(** To state nonetheless a second result about composition of
 conversions, we define a conversion on a given number of bits : *)

Fixpoint N2Bv_gen (n:nat)(a:N) : Bvector n :=
 match n return Bvector n with
   | 0 => Bnil
   | S n => match a with
       | N0 => Bvect_false (S n)
       | Npos xH => Bcons true _ (Bvect_false n)
       | Npos (xO p) => Bcons false _ (N2Bv_gen n (Npos p))
       | Npos (xI p) => Bcons true _ (N2Bv_gen n (Npos p))
      end
  end.

(** The first [N2Bv] is then a special case of [N2Bv_gen] *)

Lemma N2Bv_N2Bv_gen : forall (a:N), N2Bv a = N2Bv_gen (N.size_nat a) a.
Proof.
destruct a; simpl.
auto.
induction p; simpl; intros; auto; congruence.
Qed.

(** In fact, if [k] is large enough, [N2Bv_gen k a] contains all digits of
   [a] plus some zeros. *)

Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat),
 N2Bv_gen (N.size_nat a + k) a = Vector.append (N2Bv a) (Bvect_false k).
Proof.
destruct a; simpl.
destruct k; simpl; auto.
induction p; simpl; intros;unfold Bcons; f_equal; auto.
Qed.

(** Here comes now the second composition result. *)

Lemma N2Bv_Bv2N : forall n (bv:Bvector n),
   N2Bv_gen n (Bv2N n bv) = bv.
Proof.
induction bv; intros.
auto.
simpl.
generalize IHbv; clear IHbv.
unfold Bcons.
destruct (Bv2N _ bv);
 destruct h; intro H; rewrite <- H; simpl; trivial;
  induction n; simpl; auto.
Qed.

(** accessing some precise bits. *)

Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)),
  N.odd (Bv2N _ bv) = Blow _ bv.
Proof.
apply Vector.caseS.
intros.
unfold Blow.
simpl.
destruct (Bv2N n t); simpl;
 destruct h; auto.
Qed.

Notation Bnth := (@Vector.nth_order bool).

Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n),
  Bnth bv H = N.testbit_nat (Bv2N _ bv) p.
Proof.
induction bv; intros.
inversion H.
destruct p ; simpl.
  destruct (Bv2N n bv); destruct h; simpl in *; auto.
  specialize IHbv with p (Lt.lt_S_n _ _ H).
    simpl in * ; destruct (Bv2N n bv); destruct h; simpl in *; auto.
Qed.

Lemma Nbit_Nsize : forall n p, N.size_nat n <= p -> N.testbit_nat n p = false.
Proof.
destruct n as [|n].
simpl; auto.
induction n; simpl in *; intros; destruct p; auto with arith.
inversion H.
inversion H.
Qed.

Lemma Nbit_Bth: forall n p (H:p < N.size_nat n),
  N.testbit_nat n p = Bnth (N2Bv n) H.
Proof.
destruct n as [|n].
inversion H.
induction n ; destruct p ; unfold Vector.nth_order in *; simpl in * ; auto.
intros H ; destruct (Lt.lt_n_O _ (Lt.lt_S_n _ _ H)).
Qed.

(** Binary bitwise operations are the same in the two worlds. *)

Lemma Nxor_BVxor : forall n (bv bv' : Bvector n),
  Bv2N _ (BVxor _ bv bv') = N.lxor (Bv2N _ bv) (Bv2N _ bv').
Proof.
apply Vector.rect2 ; intros.
now simpl.
simpl.
destruct a, b, (Bv2N n v1), (Bv2N n v2); simpl in *; rewrite H ; now simpl.
Qed.

Lemma Nand_BVand : forall n (bv bv' : Bvector n),
  Bv2N _ (BVand _ bv bv') = N.land (Bv2N _ bv) (Bv2N _ bv').
Proof.
refine (@Vector.rect2 _ _ _ _ _); simpl; intros; auto.
rewrite H.
destruct a, b, (Bv2N n v1), (Bv2N n v2);
 simpl; auto.
Qed.