Local Notation iffT A B := ((A -> B) * (B -> A))%type.

Definition pull_forall_sigT {A B C}
: iffT (forall a : A, { b : B a & C a b })
       { b : forall a : A, B a & forall a, C a (b a) }.
Proof.
  split.
  { intro f.
    exists (fun a => projT1 (f a)).
    exact (fun a => projT2 (f a)). }
  { intros f a.
    exists (projT1 f a).
    exact (projT2 f a). }
Defined.

Definition pull_forall2_sigT {A B X C}
: iffT (forall a : A, { b : B a & forall x : X, C x a b })
       { b : forall a : A, B a & forall x a, C x a (b a) }.
Proof.
  split.
  { intro f.
    exists (fun a => projT1 (f a)).
    exact (fun x a => projT2 (f a) x). }
  { intros f a.
    exists (projT1 f a).
    exact (fun x => projT2 f x a). }
Defined.

Definition pull_forall3_sigT {A B X Y C}
: iffT (forall a : A, { b : B a & forall (x : X) (y : Y x), C x y a b })
       { b : forall a : A, B a & forall x y a, C x y a (b a) }.
Proof.
  split.
  { intro f.
    exists (fun a => projT1 (f a)).
    exact (fun x y a => projT2 (f a) x y). }
  { intros f a.
    exists (projT1 f a).
    exact (fun x y => projT2 f x y a). }
Defined.

Ltac pull_forall_sigT :=
  idtac;
  (lazymatch goal with
  | [ |- sigT (fun f : forall a : ?A, @?B a => forall a' : ?A, _) ]
    => (let H := fresh in
        pose proof (fun C' => fst (@pull_forall_sigT A B C')) as H;
        cbv beta in H;
        let f' := fresh in
        let H' := fresh in
        edestruct H as [f' H']; clear H;
        [
        | exists f';
          let a := fresh in
          intro a; specialize (H' a);
          pattern a, (f' a);
          eexact H' ];
        cbv beta; intro)
  | [ |- sigT (fun f : forall a : ?A, @?B a => forall (x' : ?X) (a' : ?A), _) ]
    => (let H := fresh in
        pose proof (fun C' => fst (@pull_forall3_sigT A B X C')) as H;
        cbv beta in H;
        let f' := fresh in
        let H' := fresh in
        edestruct H as [f' H']; clear H;
        [
        | exists f';
          let a := fresh in
          let x := fresh in
          intros x a; specialize (H' x a);
          pattern x, a, (f' a);
          eexact H' ];
        cbv beta; intro)
  | [ |- sigT (fun f : forall a : ?A, @?B a => forall (x' : ?X) (y' : @?Y x') (a' : ?A), _) ]
    => (let H := fresh in
        pose proof (fun C' => fst (@pull_forall3_sigT A B X Y C')) as H;
        cbv beta in H;
        let f' := fresh in
        let H' := fresh in
        edestruct H as [f' H']; clear H;
        [
        | exists f';
          let a := fresh in
          let x := fresh in
          let y := fresh in
          intros x y a; specialize (H' x y a);
          pattern x, y, a, (f' a);
          eexact H' ];
        cbv beta; intro)
   end).


From Hammer Require Import Hammer.

Require Export Arith_base.
Require Import BinInt.
Require Import Zorder.
Require Import Decidable.
Require Import Peano_dec.
Require Export Compare_dec.

Local Open Scope Z_scope.

Theorem Zne_left n m : Zne n m -> Zne (n + - m) 0.
Proof. hammer_hook "auxiliary" "auxiliary.Zne_left".
unfold Zne. now rewrite <- Z.sub_move_0_r.
Qed.

Theorem Zegal_left n m : n = m -> n + - m = 0.
Proof. hammer_hook "auxiliary" "auxiliary.Zegal_left".
apply Z.sub_move_0_r.
Qed.

Theorem Zle_left n m : n <= m -> 0 <= m + - n.
Proof. hammer_hook "auxiliary" "auxiliary.Zle_left".
apply Z.le_0_sub.
Qed.

Theorem Zle_left_rev n m : 0 <= m + - n -> n <= m.
Proof. hammer_hook "auxiliary" "auxiliary.Zle_left_rev".
apply Z.le_0_sub.
Qed.

Theorem Zlt_left_rev n m : 0 < m + - n -> n < m.
Proof. hammer_hook "auxiliary" "auxiliary.Zlt_left_rev".
apply Z.lt_0_sub.
Qed.

Theorem Zlt_left_lt n m : n < m -> 0 < m + - n.
Proof. hammer_hook "auxiliary" "auxiliary.Zlt_left_lt".
apply Z.lt_0_sub.
Qed.

Theorem Zlt_left n m : n < m -> 0 <= m + -1 + - n.
Proof. hammer_hook "auxiliary" "auxiliary.Zlt_left".
intros. rewrite Z.add_shuffle0. change (-1) with (- Z.succ 0).
now apply Z.le_0_sub, Z.le_succ_l, Z.lt_0_sub.
Qed.

Theorem Zge_left n m : n >= m -> 0 <= n + - m.
Proof. hammer_hook "auxiliary" "auxiliary.Zge_left".
Z.swap_greater. apply Z.le_0_sub.
Qed.

Theorem Zgt_left n m : n > m -> 0 <= n + -1 + - m.
Proof. hammer_hook "auxiliary" "auxiliary.Zgt_left".
Z.swap_greater. apply Zlt_left.
Qed.

Theorem Zgt_left_gt n m : n > m -> n + - m > 0.
Proof. hammer_hook "auxiliary" "auxiliary.Zgt_left_gt".
Z.swap_greater. apply Z.lt_0_sub.
Qed.

Theorem Zgt_left_rev n m : n + - m > 0 -> n > m.
Proof. hammer_hook "auxiliary" "auxiliary.Zgt_left_rev".
Z.swap_greater. apply Z.lt_0_sub.
Qed.

Theorem Zle_mult_approx n m p :
n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p.
Proof. hammer_hook "auxiliary" "auxiliary.Zle_mult_approx".
Z.swap_greater. intros. Z.order_pos.
Qed.

Theorem Zmult_le_approx n m p :
n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
Proof. hammer_hook "auxiliary" "auxiliary.Zmult_le_approx".
Z.swap_greater. intros. apply Z.lt_succ_r.
apply Z.mul_pos_cancel_r with n; trivial. Z.nzsimpl.
apply Z.le_lt_trans with (m*n+p); trivial.
now apply Z.add_lt_mono_l.
Qed.


(* This file is copied from RamifyCoq project. *)

Require Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Export Coq.Classes.Equivalence.
Require Export Coq.Sets.Ensembles.
Require Import Coq.Sets.Constructive_sets.
Require Import Logic.lib.Coqlib.

Lemma Full_set_spec: forall A (v: A), Full_set A v <-> True.
Proof.
  intros.
  split; intros; constructor.
Qed.

Lemma Empty_set_spec: forall A (v: A), Empty_set A v <-> False.
  intros.
  split; intros [].
Qed.

Lemma Intersection_spec: forall A (v: A) P Q, Intersection _ P Q v <-> P v /\ Q v.
Proof.
  intros.
  split; intros.
  + inversion H; auto.
  + constructor; tauto.
Qed.

Lemma Union_spec: forall A (v: A) P Q, Union _ P Q v <-> P v \/ Q v.
Proof.
  intros.
  split; intros.
  + inversion H; auto.
  + destruct H; [apply Union_introl | apply Union_intror]; auto.
Qed.

Lemma Disjoint_spec: forall A P Q, Disjoint A P Q <-> (forall x, P x -> Q x -> False).
Proof.
  intros; split; intros.
  + inversion H.
    eapply H2.
    unfold In; rewrite Intersection_spec; split; eauto.
  + constructor.
    intros.
    unfold In; rewrite Intersection_spec.
    intro; apply H with x; tauto.
Qed.

Lemma Singleton_spec: forall U x y, (Singleton U x) y <-> x = y.
Proof.
  intros; split; intro.
  + inversion H; auto.
  + subst; constructor.
Qed.

Lemma Included_Full_set: forall A P, Included A P (Full_set A).
Proof.
  intros.
  hnf; unfold In; intros.
  apply Full_set_spec; auto.
Qed.

Lemma Intersection_Complement: forall A (P Q: Ensemble A),
  Same_set A
  (Intersection A (Complement A P) (Complement A Q))
  (Complement A (Union A P Q)).
Proof.
  intros.
  unfold Same_set, Included, Complement, Ensembles.In.
  split; intros.
  + rewrite Union_spec.
    rewrite Intersection_spec in H.
    tauto.
  + rewrite Union_spec in H.
    rewrite Intersection_spec.
    tauto.
Qed.

Lemma Union_iff: forall U A B x, Ensembles.In U (Union U A B) x <-> Ensembles.In U A x \/ Ensembles.In U B x.
Proof.
  intros; split; intros.
  + apply Constructive_sets.Union_inv; auto.
  + destruct H; [apply Union_introl | apply Union_intror]; auto.
Qed.

Lemma Empty_set_iff: forall U x, Ensembles.In U (Empty_set U) x <-> False.
Proof.
  intros; split; intro; inversion H.
Qed.

Lemma Singleton_iff: forall U x y, Ensembles.In U (Singleton U x) y <-> x = y.
Proof.
  intros; split; intro.
  + inversion H; auto.
  + subst; constructor.
Qed.

Arguments Included {U} B C.
Arguments Same_set {U} B C.

Lemma Same_set_refl: forall A (S : Ensemble A), Same_set S S. Proof. intros; split; intro; tauto. Qed.

Lemma Same_set_sym: forall A (S1 S2 : Ensemble A), Same_set S1 S2 -> Same_set S2 S1. Proof. intros; destruct H; split; auto. Qed.

Lemma Same_set_trans: forall A (S1 S2 S3: Ensemble A), Same_set S1 S2 -> Same_set S2 S3 -> Same_set S1 S3.
Proof. intros; destruct H, H0; split; repeat intro; [apply H0, H, H3 | apply H1, H2, H3]. Qed.

Add Parametric Relation {A} : (Ensemble A) Same_set
    reflexivity proved by (Same_set_refl A)
    symmetry proved by (Same_set_sym A)
    transitivity proved by (Same_set_trans A) as Same_set_rel.

Lemma Same_set_spec: forall A P Q, Same_set P Q <-> (pointwise_relation A iff) P Q.
Proof.
  intros.
  unfold Same_set, Included, In, pointwise_relation.
  firstorder.
Qed.

Lemma Complement_Empty_set: forall A, Same_set (Complement A (Empty_set _)) (Full_set _).
Proof.
  intros.
  rewrite Same_set_spec.
  intro a.
  unfold Complement, Ensembles.In.
  pose proof Empty_set_iff _ a.
  pose proof Full_set_spec _ a.
  tauto.
Qed.

Lemma Intersection_comm: forall A P Q, Same_set (Intersection A P Q) (Intersection A Q P).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Intersection_spec.
  tauto.
Qed.

Lemma Intersection_assoc: forall A P Q R, Same_set (Intersection A (Intersection A P Q) R) (Intersection A P (Intersection A Q R)).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Intersection_spec.
  tauto.
Qed.

Lemma Union_comm: forall A P Q, Same_set (Union A P Q) (Union A Q P).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Union_spec.
  tauto.
Qed.

Lemma Union_assoc: forall A P Q R, Same_set (Union A (Union A P Q) R) (Union A P (Union A Q R)).
Proof.
  intros.
  rewrite Same_set_spec; hnf; intros.
  rewrite !Union_spec.
  tauto.
Qed.

Lemma Intersection_Union_distr_l: forall A P Q R,
  Same_set (Intersection A (Union A Q R) P)
   (Union A (Intersection A Q P) (Intersection A R P)).
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite !Intersection_spec, !Union_spec, !Intersection_spec.
  tauto.
Qed.

Lemma Intersection_Union_distr_r: forall A P Q R,
  Same_set (Intersection A P (Union A Q R))
   (Union A (Intersection A P Q) (Intersection A P R)).
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite !Intersection_spec, !Union_spec, !Intersection_spec.
  tauto.
Qed.

Instance Included_proper (V: Type): Proper (Same_set ==> Same_set ==> iff) (@Included V).
Proof.
  hnf; intros.
  hnf; intros.
  rewrite Same_set_spec in *.
  unfold pointwise_relation, Included, Ensembles.In in *.
  firstorder.
Defined.

Instance complement_proper (V: Type): Proper (Same_set ==> Same_set) (Complement V).
  hnf; intros.
  rewrite Same_set_spec in *.
  hnf; intros.
  unfold Complement, Ensembles.In.
  specialize (H a).
  tauto.
Defined.

Instance Union_proper (V: Type): Proper (Same_set ==> Same_set ==> Same_set) (Union V).
  hnf; intros.
  hnf; intros.
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *; intros.
  rewrite !Union_spec.
  firstorder.
Defined.

Instance Disjoint_proper (V: Type): Proper (Same_set ==> Same_set ==> iff) (Disjoint V).
  hnf; intros.
  hnf; intros.
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  rewrite !Disjoint_spec.
  firstorder.
Defined.

Lemma Union_Included {A: Type}: forall P Q R, Included (Union A P Q) R <-> Included P R /\ Included Q R.
Proof.
  intros.
  unfold Included.
  pose proof Union_iff A P Q.
  firstorder.
Qed.

Lemma left_Included_Union {A: Type}: forall P Q, Included P (Union A P Q).
Proof.
  intros.
  intros ? ?.
  rewrite Union_iff.
  tauto.
Qed.

Lemma right_Included_Union {A: Type}: forall P Q, Included Q (Union A P Q).
Proof.
  intros.
  intros ? ?.
  rewrite Union_iff.
  tauto.
Qed.

Lemma Union_Empty_left {A: Type}: forall P, Same_set (Union _ (Empty_set A) P) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Union_spec.
  pose proof Noone_in_empty A a.
  tauto.
Qed.

Lemma Union_Empty_right {A: Type}: forall P, Same_set (Union _ P (Empty_set A)) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Union_spec.
  pose proof Noone_in_empty A a.
  tauto.
Qed.

Lemma Intersection_Full_left {A: Type}: forall P, Same_set (Intersection _ (Full_set A) P) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Full_set_spec A a.
  tauto.
Qed.

Lemma Intersection_Full_right {A: Type}: forall P, Same_set (Intersection _ P (Full_set A)) P.
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Full_set_spec A a.
  tauto.
Qed.

Lemma Intersection_Empty_left {A: Type}: forall P, Same_set (Intersection _ (Empty_set A) P) (Empty_set A).
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Empty_set_spec A a.
  tauto.
Qed.

Lemma Intersection_Empty_right {A: Type}: forall P, Same_set (Intersection _ P (Empty_set A)) (Empty_set A).
Proof.
  intros.
  rewrite Same_set_spec.
  hnf; intros.
  rewrite Intersection_spec.
  pose proof Empty_set_spec A a.
  tauto.
Qed.

Lemma Intersection_absort_right: forall U (A B: Ensemble U), Included A B -> Same_set (Intersection _ A B) A.
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite Intersection_spec.
  specialize (H x); unfold Ensembles.In in H.
  tauto.
Qed.

Lemma Intersection_absort_left: forall U (A B: Ensemble U), Included B A -> Same_set (Intersection _ A B) B.
Proof.
  intros.
  rewrite Same_set_spec; intro x.
  rewrite Intersection_spec.
  specialize (H x); unfold Ensembles.In in H.
  tauto.
Qed.

Lemma Complement_Included_rev: forall (U: Type) P Q, Included P Q -> Included (Complement U Q) (Complement U P).
Proof.
  unfold Included, Complement, Ensembles.In.
  intros.
  firstorder.
Qed.

Instance Intersection_proper {A}: Proper (Same_set ==> Same_set ==> Same_set) (Intersection A).
Proof.
  do 2 (hnf; intros).
  rewrite Same_set_spec in *.
  intro a; specialize (H0 a); specialize (H a).
  rewrite !Intersection_spec.
  tauto.
Defined.

Lemma Included_Disjoint: forall A P Q P' Q',
  Included P P' ->
  Included Q Q' ->
  Disjoint A P' Q' ->
  Disjoint A P Q.
Proof.
  intros.
  rewrite Disjoint_spec in H1 |- *.
  intros; apply (H1 x).
  + apply H; auto.
  + apply H0; auto.
Qed.

Lemma Union_left_Disjoint: forall A P Q R,
  Disjoint A (Union A P Q) R <-> Disjoint A P R /\ Disjoint A Q R.
Proof.
  intros.
  rewrite !Disjoint_spec.
  pose proof (fun x => Union_spec A x P Q).
  firstorder.
Qed.

Lemma Union_right_Disjoint: forall A P Q R,
  Disjoint A R (Union A P Q) <-> Disjoint A R P /\ Disjoint A R Q.
Proof.
  intros.
  rewrite !Disjoint_spec.
  pose proof (fun x => Union_spec A x P Q).
  firstorder.
Qed.

Lemma Included_Complement_Disjoint: forall A P Q,
  (Included P (Complement _ Q)) <-> Disjoint A P Q.
Proof.
  intros.
  unfold Included, Complement, In.
  rewrite Disjoint_spec.
  firstorder.
Qed.

Lemma Disjoint_comm: forall A P Q,
  Disjoint A P Q <-> Disjoint A Q P.
Proof.
  intros.
  rewrite !Disjoint_spec.
  firstorder.
Qed.

Lemma Disjoint_Empty_set_right: forall {A} (P: Ensemble A), Disjoint A P (Empty_set A).
Proof.
  intros.
  rewrite Disjoint_comm.
  apply Included_Complement_Disjoint.
  apply Constructive_sets.Included_Empty.
Qed.

Lemma Disjoint_Empty_set_left: forall {A} (P: Ensemble A), Disjoint A (Empty_set A) P.
Proof.
  intros.
  apply Included_Complement_Disjoint.
  apply Constructive_sets.Included_Empty.
Qed.

Lemma Included_trans: forall {A} (P Q R: Ensemble A), Included P Q -> Included Q R -> Included P R.
Proof.
  unfold Included, Ensembles.In.
  intros; firstorder.
Qed.

Lemma Intersection1_Included: forall {A} P Q R, Included P R -> Included (Intersection A P Q) R.
Proof.
  unfold Included, Ensembles.In.
  intros.
  rewrite Intersection_spec in H0.
  firstorder.
Qed.

Lemma Intersection2_Included: forall {A} P Q R, Included Q R -> Included (Intersection A P Q) R.
Proof.
  unfold Included, Ensembles.In.
  intros.
  rewrite Intersection_spec in H0.
  firstorder.
Qed.

Lemma Included_refl: forall A P, @Included A P P.
Proof.
  intros; hnf; auto.
Qed.

Definition app_same_set {A: Type} {P Q: Ensemble A} (H: Same_set P Q) (x: A): P x <-> Q x := proj1 (Same_set_spec A P Q) H x.

Coercion app_same_set : Same_set >-> Funclass.

(* TODO: rename it into preimage set *)
Definition respectful_set {A B: Type} (X: Ensemble B) (f: A -> B): Ensemble A := fun x => X (f x).

Inductive image_set {A B: Type}: Ensemble A -> (A -> B) -> Ensemble B :=
  | image_set_intro: forall (X: Ensemble A) (f: A -> B) (x: A), X x -> image_set X f (f x).

Lemma image_set_spec: forall {A B: Type} f X (y: B),
  image_set X f y <-> exists x: A, X x /\ y = f x.
Proof.
  intros.
  split; intros.
  + inversion H; subst.
    exists x.
    split; auto.
  + destruct H as [x [?H ?H]].
    subst.
    constructor; auto.
Qed.

Instance respectful_set_proper {A B: Type}: Proper (Same_set ==> pointwise_relation A (@eq B) ==> Same_set) respectful_set.
Proof.
  intros.
  do 2 (hnf; intros).
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  unfold respectful_set.
  firstorder.
  + rewrite <- H, <- H0; firstorder.
  + rewrite H, H0; firstorder.
Qed.

Instance image_set_proper2 {A B: Type}: Proper (Same_set ==> eq ==> Same_set) (@image_set A B).
Proof.
  intros.
  do 2 (hnf; intros).
  rewrite Same_set_spec in *.
  unfold pointwise_relation in *.
  intros.
  rewrite !image_set_spec.
  firstorder.
  + subst. firstorder.
  + subst. firstorder.
Qed.

Lemma resp_Included: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Included X Y ->
  Included (respectful_set X f) (respectful_set Y f).
Proof.
  intros.
  unfold respectful_set, Included, In.
  intro x.
  apply H.
Qed.

Lemma resp_Same_set: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Same_set X Y ->
  Same_set (respectful_set X f) (respectful_set Y f).
Proof.
  intros.
  unfold Same_set in *.
  split; apply resp_Included; tauto.
Qed.

Lemma resp_Intersection: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Same_set
   (respectful_set (Intersection _ X Y) f)
   (Intersection _ (respectful_set X f) (respectful_set Y f)).
Proof.
  intros.
  rewrite Same_set_spec; intros x.
  unfold respectful_set.
  rewrite !Intersection_spec.
  reflexivity.
Qed.

Lemma resp_Union: forall {A B: Type} (X Y: Ensemble B) (f: A -> B) ,
  Same_set
   (respectful_set (Union _ X Y) f)
   (Union _ (respectful_set X f) (respectful_set Y f)).
Proof.
  intros.
  rewrite Same_set_spec; intros x.
  unfold respectful_set.
  rewrite !Union_spec.
  reflexivity.
Qed.

Lemma resp_Complement: forall {A B: Type} (X: Ensemble B) (f: A -> B),
  Same_set
   (respectful_set (Complement _ X) f)
   (Complement _ (respectful_set X f)).
Proof.
  intros.
  rewrite Same_set_spec; intros x.
  unfold respectful_set, Complement, In.
  reflexivity.
Qed.

Lemma resp_Disjoint: forall {A B: Type} (X Y: Ensemble B) (f: A -> B),
  Disjoint _ X Y ->
  Disjoint _ (respectful_set X f) (respectful_set Y f).
Proof.
  intros.
  rewrite <- Included_Complement_Disjoint in *.
  rewrite <- resp_Complement.
  apply resp_Included; auto.
Qed.

Lemma resp_Empty: forall {A B: Type} (f: A -> B),
  Same_set (respectful_set (Empty_set _) f) (Empty_set _).
Proof.
  intros.
  rewrite Same_set_spec.
  intro x.
  pose proof Noone_in_empty A.
  pose proof Noone_in_empty B.
  firstorder.
Qed.

Lemma image_Included: forall {A B: Type} (f: A -> B) (X Y: Ensemble A),
  Included X Y ->
  Included (image_set X f) (image_set Y f).
Proof.
  intros.
  unfold Included, In.
  intro y.
  rewrite !image_set_spec.
  intros [x [? ?]].
  exists x; split; auto.
  apply H; auto.
Qed.

Lemma image_Same_set: forall {A B: Type} (f: A -> B) (X Y: Ensemble A),
  Same_set X Y ->
  Same_set (image_set X f) (image_set Y f).
Proof.
  intros.
  unfold Same_set in *.
  split; apply image_Included; tauto.
Qed.

Lemma image_Intersection: forall {A B: Type} (X Y: Ensemble A) (f: A -> B),
  Included
   (image_set (Intersection _ X Y) f)
   (Intersection _ (image_set X f) (image_set Y f)).
Proof.
  intros.
  unfold Included, In; intros y.
  rewrite !Intersection_spec, !image_set_spec.
  intros [x [? ?]].
  rewrite Intersection_spec in H.
  split; exists x; tauto.
Qed.

Lemma image_Union: forall {A B: Type} (X Y: Ensemble A) (f: A -> B),
  Same_set
   (image_set (Union _ X Y) f)
   (Union _ (image_set X f) (image_set Y f)).
Proof.
  intros.
  rewrite Same_set_spec; intros y.
  rewrite !Union_spec, !image_set_spec.
  pose proof (fun x => Union_spec A x X Y).
  firstorder.
Qed.

Lemma image_Disjoint_rev: forall {A B: Type} (X Y: Ensemble A) (f: A -> B),
  Disjoint _ (image_set X f) (image_set Y f) ->
  Disjoint _ X Y.
Proof.
  intros.
  rewrite Disjoint_spec in *.
  intros x ? ?.
  apply (H (f x)); constructor; auto.
Qed.

Lemma image_Empty: forall {A B: Type} (f: A -> B),
  Same_set (image_set (Empty_set _) f) (Empty_set _).
Proof.
  intros.
  rewrite Same_set_spec.
  intro x.
  rewrite image_set_spec.
  pose proof Noone_in_empty A.
  pose proof Noone_in_empty B.
  firstorder.
Qed.

Lemma image_single: forall {A B: Type} (a: A) (f: A -> B),
  Same_set (image_set (eq a) f) (eq (f a)).
Proof.
  intros.
  rewrite Same_set_spec.
  intro x.
  rewrite image_set_spec.
  split; intros; eauto.
  destruct H as [? [? ?]]; subst; auto.
Qed.

Definition Countable_Union (A: Type) (P: nat -> Ensemble A) : Ensemble A :=
  fun x => exists i, P i x.

Definition Non_Empty {U: Type} (A: Ensemble U): Prop := exists x, A x.

Definition Binart_set_list (U: Type) (A B: Ensemble U): nat -> Ensemble U :=
  fun n => match n with | 0 => A | 1 => B | _ => Empty_set _ end.

Lemma Union_is_Countable_Union: forall {U: Type} (A B: Ensemble U),
  Same_set (Union _ A B) (Countable_Union _ (Binart_set_list _ A B)).
Proof.
  intros.
  rewrite Same_set_spec.
  intros x.
  rewrite Union_spec; unfold Countable_Union.
  split.
  + intros [? | ?].
    - exists 0; auto.
    - exists 1; auto.
  + intros [[ | [ | ]] ?].
    - left; auto.
    - right; auto.
    - intros; inversion H.
Qed.

Lemma Intersection_is_Complement_Union (classic: forall P: Prop, P \/ ~ P): forall {U: Type} (A B: Ensemble U),
  Same_set (Intersection _ A B) (Complement _ (Union _ (Complement _ A) (Complement _ B))).
Proof.
  intros.
  rewrite Same_set_spec.
  intros x; unfold Complement, Ensembles.In.
  rewrite Union_spec, Intersection_spec.
  destruct (classic (A x)), (classic (B x)); tauto.
Qed.

Arguments Included: clear implicits.
Arguments Same_set: clear implicits.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export ArithRing.
Require Export Compare_dec.
Require Export Wf_nat.
Require Export Arith.
Require Export Omega.

Theorem minus_minus : forall a b c : nat, a - b - c = a - (b + c).
intros a; elim a; auto.
intros n' Hrec b; case b; auto.
Qed.

Remark expand_mult2 : forall x : nat, 2 * x = x + x.
intros x; ring.
Qed.

Theorem lt_neq : forall x y : nat, x < y -> x <> y.
unfold not in |- *; intros x y H H1; elim (lt_irrefl x);
 pattern x at 2 in |- *; rewrite H1; auto.
Qed.
Hint Resolve lt_neq.

Theorem monotonic_inverse :
 forall f : nat -> nat,
 (forall x y : nat, x < y -> f x < f y) ->
 forall x y : nat, f x < f y -> x < y.
intros f Hmon x y Hlt; case (le_gt_dec y x); auto.
intros Hle; elim (le_lt_or_eq _ _ Hle).
intros Hlt'; elim (lt_asym _ _ Hlt); apply Hmon; auto.
intros Heq; elim (lt_neq _ _ Hlt); rewrite Heq; auto.
Qed.

Theorem mult_lt : forall a b c : nat, c <> 0 -> a < b -> a * c < b * c.
intros a b c; elim c.
intros H; elim H; auto.
intros c'; case c'.
intros; omega.
intros c'' Hrec Hneq Hlt;
 repeat rewrite <- (fun x : nat => mult_n_Sm x (S c'')).
auto with *.
Qed.

Remark add_sub_square_identity :
 forall a b : nat,
 (b + a - b) * (b + a - b) = (b + a) * (b + a) + b * b - 2 * ((b + a) * b).
intros a b; rewrite minus_plus.
repeat rewrite mult_plus_distr_r || rewrite <- (mult_comm (b + a)).
replace (b * b + a * b + (b * a + a * a) + b * b) with
 (b * b + a * b + (b * b + a * b + a * a)); try (ring; fail).
rewrite expand_mult2; repeat rewrite minus_plus; auto with *.
Qed.

Theorem sub_square_identity :
 forall a b : nat, b <= a -> (a - b) * (a - b) = a * a + b * b - 2 * (a * b).
intros a b H; rewrite (le_plus_minus b a H); apply add_sub_square_identity.
Qed.

Theorem square_monotonic : forall x y : nat, x < y -> x * x < y * y.
intros x; case x.
intros y; case y; simpl in |- *; auto with *.
intros x' y Hlt; apply lt_trans with (S x' * y).
rewrite (mult_comm (S x') y); apply mult_lt; auto.
apply mult_lt; omega.
Qed.

Theorem root_monotonic : forall x y : nat, x * x < y * y -> x < y.
exact (monotonic_inverse (fun x : nat => x * x) square_monotonic).
Qed.

Remark square_recompose : forall x y : nat, x * y * (x * y) = x * x * (y * y).
intros; ring.
Qed.

Remark mult2_recompose : forall x y : nat, x * (2 * y) = x * 2 * y.
intros; ring.
Qed.
Section sqrt2_decrease.
Variables (p q : nat) (pos_q : 0 < q) (hyp_sqrt : p * p = 2 * (q * q)).

Theorem sqrt_q_non_zero : 0 <> q * q.
generalize pos_q; case q.
intros H; elim (lt_n_O 0); auto.
intros n H.
simpl in |- *; discriminate.
Qed.
Hint Resolve sqrt_q_non_zero.

Ltac solve_comparison :=
  apply root_monotonic; repeat rewrite square_recompose; rewrite hyp_sqrt;
   rewrite mult2_recompose; apply mult_lt; auto with arith.

Theorem comparison1 : q < p.
replace q with (1 * q); try ring.
replace p with (1 * p); try ring.
solve_comparison.
Qed.

Theorem comparison2 : 2 * p < 3 * q.
solve_comparison.
Qed.

Theorem comparison3 : 4 * q < 3 * p.
solve_comparison.
Qed.
Hint Resolve comparison1 comparison2 comparison3: arith.

Theorem comparison4 : 3 * q - 2 * p < q.
apply plus_lt_reg_l with (2 * p).
rewrite <- le_plus_minus; try (simple apply lt_le_weak; auto with arith).
replace (3 * q) with (2 * q + q); try ring.
apply plus_lt_le_compat; auto.
repeat rewrite (mult_comm 2); apply mult_lt; auto with arith.
Qed.

Remark mult_minus_distr_l : forall a b c : nat, a * (b - c) = a * b - a * c.
intros a b c; repeat rewrite (mult_comm a); apply mult_minus_distr_r.
Qed.

Remark minus_eq_decompose :
 forall a b c d : nat, a = b -> c = d -> a - c = b - d.
intros a b c d H H0; rewrite H; rewrite H0; auto.
Qed.

Theorem new_equality :
 (3 * p - 4 * q) * (3 * p - 4 * q) = 2 * ((3 * q - 2 * p) * (3 * q - 2 * p)).
repeat rewrite sub_square_identity; auto with arith.
repeat rewrite square_recompose; rewrite mult_minus_distr_l.
apply minus_eq_decompose; try rewrite hyp_sqrt; ring.
Qed.
End sqrt2_decrease.
Hint Resolve lt_le_weak comparison2: sqrt.

Theorem sqrt2_not_rational :
 forall p q : nat, q <> 0 -> p * p = 2 * (q * q) -> False.
intros p q; generalize p; clear p; elim q using (well_founded_ind lt_wf).
clear q; intros q Hrec p Hneq; generalize (neq_O_lt _ (sym_not_equal Hneq));
 intros Hlt_O_q Heq.
apply (Hrec (3 * q - 2 * p) (comparison4 _ _ Hlt_O_q Heq) (3 * p - 4 * q)).
apply sym_not_equal; apply lt_neq; apply plus_lt_reg_l with (2 * p);
 rewrite <- plus_n_O; rewrite <- le_plus_minus; auto with *.
apply new_equality; auto.
Qed.


Set Implicit Arguments.
Global Set Asymmetric Patterns.

Require Import Relations.
Require Export Basics.
Require Import Setoid.

Arguments eq {A}.
Arguments fst {A B}.

Hint Unfold compose.

Definition proj1_conj (A B: Prop) (c: A /\ B): A :=
  match c with conj x _ => x end.

Definition proj2_conj (A B: Prop) (c: A /\ B): B :=
  match c with conj _ x => x end.

Lemma eq_trans (X: Set) (a b c: X): a = b -> b = c -> a = c.
Proof. intros. subst. reflexivity. Qed.

Definition cmp_cmp (x y: comparison): { x = y } + { x <> y } :=
  (* instead of being lazy with tactics, let's try to make as short a term as possible *)
  match x, y return { x = y } + { x <> y } with
  | Lt, Lt | Gt, Gt | Eq, Eq => left _ (refl_equal _)
  | a, b => right _ (
      match a, b
      return match a, b with Lt, Lt | Gt, Gt | Eq, Eq => True | _, _ => ~(a = b) end with
      | Lt, Lt | Gt, Gt | Eq, Eq => I
      | Lt, _ => fun q => match q in _ = Lt with refl_equal => I end
      | Gt, _ => fun q => match q in _ = Gt with refl_equal => I end
      | Eq, _ => fun q => match q in _ = Eq with refl_equal => I end
      end
    )
  end. (* todo: derive this using the new equality Schemes *)

Fixpoint nat_cmp (x y: nat) {struct x}: comparison :=
  match x, y with
  | 0, 0 => Eq
  | 0, S _ => Lt
  | S _, 0 => Gt
  | S x', S y' => nat_cmp x' y'
  end.

Ltac cset e := let v := fresh in set (v := e); clearbody v.
Ltac cset' e := let v := fresh in set (v := e) in *; clearbody v.

Ltac extro x := generalize x; clear x.

Definition unsum_bool (A B: Prop) (sb: sumbool A B): bool := if sb then true else false.

Definition decision (P: Prop): Set := { P } + { ~ P }.
Definition predDecider (T: Set) (P: T -> Prop): Type := forall t, decision (P t).

Lemma negb_inv (b b': bool): negb b = negb b' -> b = b'.
Proof. destruct b; destruct b'; auto. Qed.

Lemma negb_negb (b: bool): negb (negb b) = b.
Proof. destruct b; auto. Qed.

Definition id {X} (x: X): X := x.

(* extensional equality on simple functions *)

Definition ext_eq {A B: Type} (f g: A -> B): Prop := forall x, f x = g x.

Lemma ext_eq_trans: forall A B, transitive _ (@ext_eq A B).
Proof. intros. unfold transitive. intros. intro. rewrite H. rewrite H0. reflexivity. Qed.

Lemma ext_eq_refl: forall A B, reflexive _ (@ext_eq A B).
Proof. intros. unfold reflexive. intros. intro. reflexivity. Qed.

Lemma ext_eq_sym: forall A B, symmetric _ (@ext_eq A B).
Proof. intros. unfold symmetric. intros. intro. rewrite H. reflexivity. Qed.

Add Parametric Relation X Y: (X -> Y) (@ext_eq X Y)
  reflexivity proved by (@ext_eq_refl X Y)
  symmetry proved by (@ext_eq_sym X Y)
  transitivity proved by (@ext_eq_trans X Y)
    as ext_eq_rel.

Lemma ext_eq_rw (A B: Type) (f g: A -> B): ext_eq f g -> forall x, f x = g x.
Proof. intros. apply H. Qed.

(* function composition *)

Notation " g ∘ f " := (compose g f) (at level 40, left associativity).

Lemma comp_apply (A B C: Set) (f: B -> C) (g: A -> B) (x: A): (f ∘ g) x = f (g x).
Proof. reflexivity. Qed.

Lemma comp_ass (A B C D: Set) (f: A -> B) (g: B -> C) (h: C -> D): h ∘ (g ∘ f) = (h ∘ g) ∘ f.
Proof. reflexivity. Qed.

Definition compose_lunit A B (f: A -> B): ext_eq (@id B ∘ f) f.
Proof. intros. intro. reflexivity. Qed.

Definition compose_runit A B (f: A -> B): ext_eq (f ∘ @id A) f.
Proof. intros. intro. reflexivity. Qed.

Add Parametric Morphism (X Y Z: Set): (@compose X Y Z) with signature (@ext_eq Y Z) ==> (@ext_eq X Y) ==> (@ext_eq X Z) as compose_ext_eq_morph.
Proof.
  intros.
  intro.
  unfold compose.
  unfold ext_eq in *.
  rewrite H0.
  rewrite H.
  reflexivity.
Qed.

Definition map_snd (A B: Set) (f: A -> B) (C: Set) (p: C * A): C * B := (fst p, f (snd p)).

Lemma fst_map_snd (A B: Set) (f: A -> B) (C: Set) (p: C * A): fst (map_snd f p) = fst p.
Proof. destruct p. auto. Qed.

Definition on {A B: Type} {C: B -> B -> Type} (g: A -> B) (f: forall b b', C b b') (x y: A): C (g x) (g y) := f (g x) (g y).

Definition unsumbool {A B}: { A } + { B } -> bool := fun x => if x then true else false.

Definition dep_flip {A B: Type} {C: A -> B -> Type} (f: forall a b, C a b) (b: B) (a: A): C a b := f a b.

Coercion conj_prod (A B: Prop): A /\ B -> A * B.
  firstorder.
Qed.

Definition uncurry A B C (f: A -> B -> C) (ab: A * B): C := f (fst ab) (snd ab).

Section well_founded_pairs.

  Variables (A B: Type)
    (Ra: relation A) (Rb: relation B).

  Inductive pair_rel: relation (A * B) :=
    | pair_rel_l a a' b: Ra a a' -> pair_rel (a, b) (a', b)
    | pair_rel_r a b b': Rb b b' -> pair_rel (a, b) (a, b').

  Fixpoint acc_pairs a (Aa: Acc Ra a) {struct Aa}: forall b (Ab: Acc Rb b), Acc pair_rel (a, b) :=
    fix G b (Ab: Acc Rb b) {struct Ab}: Acc pair_rel _ := @Acc_intro _ pair_rel _
      match Aa, Ab with
      | Acc_intro x, Acc_intro y =>  fun z (za: pair_rel z (a, b)) =>
          match za in pair_rel z ab return
            (forall (p: A) (q: Ra p (fst ab)), Acc pair_rel (p, (snd ab))) -> (forall p, Rb p (snd ab) -> Acc pair_rel (fst ab, p)) -> Acc pair_rel z with
          | pair_rel_l v w c d => fun fr gr => fr _ d
          | pair_rel_r v w c d => fun fr gr => gr _ d
          end
          (fun (p: A) (q: Ra p (fst (a, b))) => @acc_pairs p (x p q) b Ab : Acc pair_rel (p, b))
          (fun (p: B) (q: Rb p (snd (a, b))) => @G p (y p q): Acc pair_rel (a, p))
      end.

   Lemma well_founded_pairs (Wa: well_founded Ra) (Wb: well_founded Rb): well_founded pair_rel.
     unfold well_founded.
     intros.
     destruct a.
     apply (acc_pairs (Wa a) (Wb b)).
   Qed.

End well_founded_pairs.


Require Export UniMath.MoreFoundations.Notations.
Require Import UniMath.MoreFoundations.Tactics.

Lemma retract_dec {X Y} (f : X -> Y) (g : Y -> X) (h : f ∘ g ~ idfun Y) : isdeceq X -> isdeceq Y.
Proof.
  intros i y y'. induction (i (g y) (g y')) as [eq|ne].
  - apply ii1. exact (! h y @ maponpaths f eq @ h y').
  - apply ii2. intro p. apply ne. exact (maponpaths g p).
Defined.

Lemma logeq_dec {X Y} : (X <-> Y) -> decidable X -> decidable Y.
Proof.
  intros iff decX. induction iff as [XtoY YtoX].
  induction decX as [x|nx].
  - now apply ii1, XtoY.
  - now apply ii2, (negf YtoX).
Defined.

Definition decidable_prop (X:hProp) := make_hProp (decidable X) (isapropdec X (pr2 X)).

Definition LEM : hProp := ∀ P : hProp, decidable_prop P.

(** ** Decidability via complementary pairs *)

Definition ComplementaryPair : UU := ∑ (P Q : UU), complementary P Q.
Definition Part1 (C : ComplementaryPair) : UU := pr1 C.
Definition Part2 (C : ComplementaryPair) : UU := pr1 (pr2 C).
Definition pair_contradiction (C : ComplementaryPair) : Part1 C -> Part2 C -> ∅
  := pr1 (pr2 (pr2 C)).
Definition chooser (C : ComplementaryPair) : Part1 C ⨿ Part2 C
  := pr2 (pr2 (pr2 C)).

Definition isTrue (C : ComplementaryPair)
  := hfiber (@ii1 (Part1 C) (Part2 C)) (chooser C).
Definition isFalse (C : ComplementaryPair)
  := hfiber (@ii2 (Part1 C) (Part2 C)) (chooser C).

Definition  trueWitness {C : ComplementaryPair} : isTrue  C -> Part1 C := pr1.
Definition falseWitness {C : ComplementaryPair} : isFalse C -> Part2 C := pr1.

Coercion  trueWitness : isTrue  >-> Part1.
Coercion falseWitness : isFalse >-> Part2.

Lemma complementaryDecisions (C : ComplementaryPair) :
  iscontr (isTrue C ⨿ isFalse C).
Proof.
  (* the idea of this proof is to show that [isTrue C ⨿ isFalse C] is the same
     as the decomposition provided by [weqcoprodsplit] *)
  intros.
  apply iscontrifweqtounit. assert (w := weqcoprodsplit (λ _:unit, chooser C)).
  apply invweq. apply (weqcomp w). apply weqcoprodf; apply weqhfiberunit.
Defined.

Lemma isaprop_isTrue (C : ComplementaryPair) : isaprop (isTrue C).
(* No axioms are used. *)
Proof.
  intros.
  apply (isapropcomponent1 (isTrue C) (isFalse C)).
  apply isapropifcontr.
  apply complementaryDecisions.
Defined.

Lemma isaprop_isFalse (C : ComplementaryPair) : isaprop (isFalse C).
(* No axioms are used. *)
(* By contrast, to prove [¬P] is a proposition requires the use of functional
   extensionality. *)
Proof.
  intros.
  apply (isapropcomponent2 (isTrue C) (isFalse C)).
  apply isapropifcontr.
  apply complementaryDecisions.
Defined.

Ltac unpack_pair C P Q con c := induction C as [P Qc]; induction Qc as [Q c];
                                induction c as [con c]; simpl in c, P, Q.

Lemma pair_truth (C : ComplementaryPair) : Part1 C -> isTrue C.
Proof.
  intros p.
  unpack_pair C P Q con c;
    unfold isTrue, hfiber, Part1, Part2, chooser in *; simpl in *.
  induction c as [p'|q].
  - now exists p'.
  - apply fromempty. contradicts (con p) q.
Defined.

Lemma pair_falsehood (C : ComplementaryPair) : Part2 C -> isFalse C.
Proof.
  intros q.
  unpack_pair C P Q con c;
    unfold isFalse, hfiber, Part1, Part2, chooser in *; simpl in *.
  induction c as [p|q'].
  - apply fromempty. contradicts (con p) q.
  - now exists q'.
Defined.

Definition to_ComplementaryPair {P : UU} (c : P ⨿ neg P) : ComplementaryPair
  (* By using [isTrue _] instead, we're effectively replacing P by a
     propositional subtype of it: *)
  (* the part connected to the element of [P ⨿ ¬P]. *)
  (* Similarly, by using [isFalse _] instead, we're effectively replacing [¬P]
     by a propositional subtype of it.  *)
  (* Both are proved to be propositions without [funextemptyAxiom] *)
  := (P,,neg P,,(λ p n, n p),,c).

(* Relate isolated points to complementary pairs *)

Definition isolation {X : UU} (x : X) (is : isisolated X x) (y : X) : UU
  := isFalse (to_ComplementaryPair (is y)).

Definition isaprop_isolation {X : UU} (x : X) (is : isisolated X x) (y : X) :
  isaprop (isolation x is y) := isaprop_isFalse _.

Definition isolation_to_inequality {X : UU} (x : X) (is : isisolated X x)
           (y : X) :
  isolation x is y -> x != y := falseWitness.

Definition inequality_to_isolation {X : UU} (x : X) (i : isisolated X x)
           (y : X) :
  x != y -> isolation x i y := pair_falsehood (to_ComplementaryPair (i y)).

(* operations on complementary pairs *)

Definition pairNegation (C : ComplementaryPair) : ComplementaryPair
  := Part2 C,, Part1 C ,, (λ q p, pair_contradiction C p q),,
           coprodcomm _ _ (chooser C).

Definition pairConjunction (C C' : ComplementaryPair) : ComplementaryPair.
Proof.
  unpack_pair C P Q con c; unpack_pair C' P' Q' con' c'; simpl in *.
  unfold ComplementaryPair. exists (P × P'); exists (Q ⨿ Q'). split.
  - simpl. intros a b. induction a as [p p']. induction b as [b|b].
    + induction c' as [_|q'].
      * contradicts (con p) b.
      * contradicts (con p) b.
    + contradicts (con' p') b.
  - simpl. induction c as [p|q].
    + induction c' as [p'|q'].
      * apply ii1. exact (p,,p').
      * apply ii2, ii2. exact q'.
    + induction c' as [p'|q'].
      * apply ii2, ii1. exact q.
      * apply ii2, ii2. exact q'.
Defined.

Definition pairDisjunction (C C' : ComplementaryPair) : ComplementaryPair.
Proof.
  intros.
  exact (pairNegation (pairConjunction (pairNegation C) (pairNegation C'))).
Defined.

Definition dnegelim {P Q : UU} : complementary P Q -> ¬¬ P -> P.
Proof.
  intros c nnp. induction c as [n c].
  induction c as [p|q].
  - assumption.
  - contradicts nnp (λ p, n p q).
Defined.

(* Law of Excluded Middle

   We don't state LEM as an axiom, because we want to force it
   to be a hypothesis of any corollaries of any theorems that
   appeal to it. *)

Lemma LEM_for_sets (X : UU) : LEM -> isaset X -> isdeceq X.
Proof. intros lem is x y. exact (lem (make_hProp (x = y) (is x y))). Defined.

Lemma isaprop_LEM : isaprop LEM.
Proof.
  unfold LEM. apply impred_isaprop; intro P. apply isapropdec. apply propproperty.
Defined.

Lemma dneg_LEM (P : hProp) : LEM -> ¬¬ P -> P.
Proof. intros lem. exact (dnegelim ((λ p np, np p),,lem P)). Defined.

Corollary reversal_LEM (P Q : hProp) : LEM -> (¬ P -> Q) -> (¬ Q -> P).
Proof.
  intros lem f n.
  assert (g := negf f); clear f.
  assert (h := g n); clear g n.
  apply (dneg_LEM _ lem).
  exact h.
Defined.

(*****************************************************************************)
(* all of this stuff about decidable propositions will be replaced by the better code above *)
(*****************************************************************************)

Definition DecidableProposition : UU := ∑ X : UU, isdecprop X.

Definition isdecprop_to_DecidableProposition {X : UU} (i : isdecprop X) :
  DecidableProposition := X,,i.

Definition decidable_to_isdecprop {X : hProp} : decidable X -> isdecprop X.
Proof.
  intros dec. apply isdecpropif.
  - apply propproperty.
  - exact dec.
Defined.

Definition decidable_to_isdecprop_2 {X : UU} :
  isaprop X -> X ⨿ ¬ X -> isdecprop X.
Proof.
  intros i dec. apply isdecpropif.
  - exact i.
  - exact dec.
Defined.

Definition decidable_to_DecidableProposition {X : hProp} :
  decidable X -> DecidableProposition.
Proof. intros dec. exists X. now apply decidable_to_isdecprop. Defined.

Definition DecidableProposition_to_isdecprop (X : DecidableProposition) :
  isdecprop (pr1 X).
Proof. apply pr2. Defined.

Definition DecidableProposition_to_hProp : DecidableProposition -> hProp.
Proof.
  intros X.
  exact (pr1 X,, isdecproptoisaprop (pr1 X) (pr2 X)).
Defined.
Coercion DecidableProposition_to_hProp : DecidableProposition >-> hProp.
Definition decidabilityProperty (X : DecidableProposition) :
  isdecprop X := pr2 X.

Definition DecidableSubtype (X : UU) : UU := X -> DecidableProposition.
Definition DecidableRelation (X : UU) : UU := X -> X -> DecidableProposition.

Definition decrel_to_DecidableRelation {X : UU} :
  decrel X -> DecidableRelation X.
Proof.
  intros R x y. induction R as [R is]. exists (R x y).
  apply isdecpropif. { apply propproperty. } apply is.
Defined.

Definition decidableAnd (P Q : DecidableProposition) : DecidableProposition.
Proof.
  intros. exists (P × Q). apply isdecpropdirprod; apply decidabilityProperty.
Defined.

Definition decidableOr (P Q : DecidableProposition) : DecidableProposition.
Proof.
  intros. exists (P ∨ Q). apply isdecprophdisj; apply decidabilityProperty.
Defined.

Lemma neg_isdecprop {X : UU} : isdecprop X -> isdecprop (¬ X).
Proof.
  intros i.
  set (j := isdecproptoisaprop X i).
  apply isdecpropif.
  - apply isapropneg.
  - unfold isdecprop in i.
    set (k := pr1 i).
    induction k as [k|k].
    + apply ii2. now apply todneg.
    + now apply ii1.
Defined.

Definition decidableNot (P : DecidableProposition) : DecidableProposition.
Proof.
  intros. exists (¬ P). apply neg_isdecprop; apply decidabilityProperty.
Defined.

Declare Scope decidable_logic.
Notation "X ∨ Y" := (decidableOr X Y) (at level 85, right associativity) :
                      decidable_logic.
Notation "A ∧ B" := (decidableAnd A B) (at level 80, right associativity) :
                      decidable_logic.
Notation "'¬' X" := (decidableNot X) (at level 35, right associativity) :
                      decidable_logic.
Delimit Scope decidable_logic with declog.

Ltac choose P yes no := induction (pr1 (decidabilityProperty P)) as [yes|no].

Definition choice {W : UU} : DecidableProposition -> W -> W -> W.
Proof.
  intros P yes no.
  choose P p q.
  - exact yes.
  - exact no.
Defined.

Definition dependent_choice {W : UU} (P : DecidableProposition) :
  (P -> W) -> (¬ P -> W) -> W.
Proof.
  intros yes no.
  choose P p q.
  - exact (yes p).
  - exact (no q).
Defined.

Definition choice_compute_yes {W : UU} (P : DecidableProposition) (p : P)
           (yes no : W) :
  choice P yes no = yes.
Proof.
  intros.
  unfold choice.
  choose P a b.
  - simpl. reflexivity.
  - simpl. contradicts p b.
Defined.

Definition choice_compute_no {W : UU} (P : DecidableProposition) (p : ¬ P)
           (yes no : W) :
  choice P yes no = no.
Proof.
  intros.
  unfold choice.
  choose P a b.
  - simpl. contradicts p a.
  - simpl. reflexivity.
Defined.

Definition decidableSubtypeCarrier {X : UU} : DecidableSubtype X -> UU.
Proof. intros S. exact (∑ x, S x). Defined.

Definition decidableSubtypeCarrier' {X : UU} : DecidableSubtype X -> UU.
Proof. intros P.
       (* for use with isfinitedecsubset *)
       exact (hfiber (λ x, choice (P x) true false) true).
Defined.

Definition decidableSubtypeCarrier_weq {X : UU} (P : DecidableSubtype X) :
  decidableSubtypeCarrier' P ≃ decidableSubtypeCarrier P.
Proof.
  intros.
  apply weqfibtototal.
  intros x.
  unfold choice.
  simpl.
  change (pr1 (decidabilityProperty (P x)))
  with (pr1 (decidabilityProperty (P x))).
  choose (P x) p q.
  - simpl. apply weqiff.
    + apply logeq_both_true.
      * reflexivity.
      * assumption.
    + apply isasetbool.
    + apply (propproperty (DecidableProposition_to_hProp _)).
  - simpl. apply weqiff.
    + apply logeq_both_false.
      * exact nopathsfalsetotrue.
      * assumption.
    + apply isasetbool.
    + apply (propproperty (DecidableProposition_to_hProp _)).
Defined.

Definition DecidableSubtype_to_hsubtype {X : UU} (P : DecidableSubtype X) :
  hsubtype X
  := λ x, DecidableProposition_to_hProp (P x).
Coercion DecidableSubtype_to_hsubtype : DecidableSubtype >-> hsubtype.

Definition DecidableRelation_to_hrel {X : UU} (P : DecidableRelation X) : hrel X
  := λ x y, DecidableProposition_to_hProp(P x y).
Coercion DecidableRelation_to_hrel : DecidableRelation >-> hrel.

Definition natlth_DecidableProposition : DecidableRelation nat :=
  decrel_to_DecidableRelation natlthdec.

Definition natleh_DecidableProposition : DecidableRelation nat :=
  decrel_to_DecidableRelation natlehdec.

Definition natgth_DecidableProposition : DecidableRelation nat :=
  decrel_to_DecidableRelation natgthdec.

Definition natgeh_DecidableProposition : DecidableRelation nat :=
  decrel_to_DecidableRelation natgehdec.

Definition nateq_DecidableProposition : DecidableRelation nat :=
  decrel_to_DecidableRelation natdeceq.

Definition natneq_DecidableProposition : DecidableRelation nat :=
  decrel_to_DecidableRelation natdecneq.

Declare Scope decidable_nat.
Notation " x < y " := (natlth_DecidableProposition x y) (at level 70, no associativity) :
                        decidable_nat.
Notation " x <= y " := (natleh_DecidableProposition x y) (at level 70, no associativity) :
                         decidable_nat.
Notation " x ≤ y " := (natleh_DecidableProposition x y) (at level 70, no associativity) :
                        decidable_nat.
Notation " x ≥ y " := (natgeh_DecidableProposition x y) (at level 70, no associativity) :
                        decidable_nat.
Notation " x ≥ y " := (natgeh_DecidableProposition x y) (at level 70, no associativity) :
                        decidable_nat.
Notation " x > y " := (natgth_DecidableProposition x y) (at level 70, no associativity) :
                        decidable_nat.
Notation " x =? y " := (nateq_DecidableProposition x y) (at level 70, no associativity) :
                         decidable_nat.
Notation " x ≠ y " := (natneq_DecidableProposition x y) (at level 70, no associativity) :
                        decidable_nat.

Delimit Scope decidable_nat with dnat.


(*|
##########################################################
Coq adding a new variable instead of using the correct one
##########################################################

:Link: https://stackoverflow.com/q/39459959
|*)

(*|
Question
********

I'm working on my own implementation of vectors in Coq, and I'm
running into a bizarre problem.

Here is my code thus far:
|*)

Set Implicit Arguments.

Inductive Fin : nat -> Type :=
| FZ : forall n, Fin (S n)
| FS : forall n, Fin n -> Fin (S n).

Definition emptyf (A : Type) : Fin 0 -> A.
  intro e. inversion e.
Defined.

Inductive Vec (A : Type) : nat -> Type :=
| Nil  : Vec A 0
| Cons : forall n, A -> Vec A n -> Vec A (S n).

Definition head (A : Type) (n : nat) (v : Vec A (S n)) : A :=
  match v with
  | Cons a _ => a
  end.

Definition tail (A : Type) (n : nat) (v : Vec A (S n)) : Vec A n :=
  match v with
  | Cons _ w => w
  end.

Fail Fixpoint index (A : Type) (n : nat) : Vec A n -> Fin n -> A :=
  match n as n return Vec A n -> Fin n -> A with
  | 0   => fun _ i => emptyf _ i
  | S m => fun v i => match i with
                      | FZ _ => head v
                      | FS j => index (tail v) j
                      end
  end. (* .fails *)

(*|
Everything up to ``tail`` compiles fine, but when I try to compile
``index``, I receive the following error:
|*)

Fail Fixpoint index (A : Type) (n : nat) : Vec A n -> Fin n -> A :=
  match n as n return Vec A n -> Fin n -> A with
  | 0   => fun _ i => emptyf _ i
  | S m => fun v i => match i with
                      | FZ _ => head v
                      | FS j => index (tail v) j
                      end
  end. (* .unfold .messages *)

(*|
Clearly, the culprit is that Coq introduces the new variable ``n0``
instead of assigning ``j`` the type ``Fin m``, even though this is the
only possible type for ``j`` which would result in ``i`` being built
from ``j``. Any idea why this would happen, and how I might be able to
resolve this issue?
|*)

(*|
Answer (eponier)
****************

Note that you do not need to pattern-match against ``n``, but only
against the argument of type ``Fin n``. The resulting definition is
simpler.
|*)

Fixpoint index {A : Type} {n : nat} (i : Fin n) : Vec A n -> A :=
  match i in Fin n0 return Vec A n0 -> A with
  | FZ _ => fun v => head v
  | FS j => fun v => index j (tail v)
  end.

(*| Coq is actually cleaver enough to guess the annotations. |*)

Reset index. (* .none *)
Fixpoint index {A : Type} {n : nat} (i : Fin n) : Vec A n -> A :=
  match i with
  | FZ _ => fun v => head v
  | FS j => fun v => index j (tail v)
  end.

(*|
----

**A (Anton Trunov):** This one feels like magic -- simple argument
swapping solves the problem instantaneously. Nice!

**A:** I did not realize that I switched the arguments. Another
difference with the original function: the decreasing argument is
``i``, not ``n``.

**A (Anton Trunov):** Yes, however if you start with pattern-mathing
on a vector (as in `my answer
<http://stackoverflow.com/a/39469676/2747511>`__), you will have to
use something like the convoy pattern (see `larsr's answer
<http://stackoverflow.com/a/39467904/2747511>`__). So that swap is
actually a big deal.
|*)

(*|
Answer (ejgallego)
******************

I find ``Vec`` and ``Fin`` very hard to use in general, so these days
I use ``'I_n`` and ``n.-tuples T`` from math-comp, which are just
naturals and lists with an irrelevant proof attached. However, if you
want to continue the fun of complex pattern matches, you could try to
define a stronger pattern matching principle:
|*)

Reset index. (* .none *)
Definition fin_case T m (i : Fin m) : T -> (Fin (pred m) -> T) -> T :=
  match i with
  | FZ _ => fun fn fz => fn
  | FS j => fun fn fz => fz j
  end.

(*| Once you have ``fin_case``, you function definition works: |*)

Fixpoint index (A : Type) (n : nat) : Vec A n -> Fin n -> A :=
  match n as n return Vec A n -> Fin n -> A with
  | 0   => fun _ i => emptyf _ i
  | S m => fun v i => fin_case i (head v) (index (tail v))
  end.

(*|
----

**Q:** Thanks for the reply, but It seems to me like this just pushes
the problem onto how to define ``fin_case``. No matter what I try, I
still run into the same problem. Would you mind sharing the definition
you have in mind?

**A:** Updated, a couple of comments:

a) Note that this "pushing the problem onto" is indeed more than that
   and a crucial tool in Coq style dependent programming.
b) There are many other ways to solve these kind of problems, indeed,
   writing a proper match still feels like a bit of an art.
|*)

(*|
Answer (Anton Trunov)
*********************

Just to add to the other answers, a tactic-based solution:
|*)

Reset index. (* .none *)
Fixpoint index (A : Type) (n : nat) (v : Vec A n) (i : Fin n) : A.
  destruct v as [| n h tl].
  - exact (emptyf A i).
  - inversion i as [ | ? i'].
    + exact h.
    + exact (index _ _ tl i').
Defined.

(*|
The ``inversion`` tactic takes care of the "information loss". If you
try to ``Print index.`` the result won't be pretty, but Coq
essentially uses the convoy pattern @larsr has mentioned.

Notice that this approach doesn't use pattern-matching on ``n``. It
pattern-matches on the vector argument instead, that's why it doesn't
need the ``head`` and ``tail`` functions.
|*)

(*|
Answer (larsr)
**************

When you use ``match`` you can lose information. I used the `convoy
pattern <http://adam.chlipala.net/cpdt/html/MoreDep.html>`__ to get
the info back into the context.

.. code-block:: coq

    match i in Fin (S n0) return n0 = m -> A with
      ... => fun H : n0 = m => ...
    end eq_refl

enables Coq to get the info ``n0 = m`` into the context. It is sent
into the match clauses as a function parameter. To use it in the type
check I use ``(match H with ... end)`` so that Coq understands that
``Fin n0 = Fin m``. This is the solution.
|*)

Reset index. (* .none *)
Fixpoint index (A : Type) (n : nat) : Vec A n -> Fin n -> A :=
  match n as n return Vec A n -> Fin n -> A with
  | 0   => fun _ i => emptyf _ i
  | S m => fun v i =>
             match i in Fin (S n') return n' = m -> A with
             | FZ _ => fun _ => head v
             | FS j => fun H => index (tail v) (match H with eq_refl _ => j end)
             end eq_refl
  end.

(*|
When the type checking doesn't understand that two things are equal,
usually the convoy pattern can help you get that info into the
context. I also recommend using ``refine`` to incrementally build up
the term. It let's you see what information there is in the context.

----

**A:** A simple
|*)

Definition cast (m n : nat) (i : Fin m) (H : m = n) : Fin n :=
  eq_rec m Fin i n H.

(*|
might make the code a bit easier to read (``(match H with eq_refl _ =>
j end)`` gets replaced by ``(cast j H)``).

**A:** A comment on the solutions using equality casts, (including the
one with ``inversion``) is that they may not compute/reduce properly
inside Coq, needing additional rewrites.
|*)


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Functor.Opposite.
Require Import Category.Structure.Cone.

Generalizable All Variables.

Program Definition Cones `(F : J ⟶ C) : Category := {|
  obj     := Cone F;
  hom     := fun N L => { u : vertex_obj[N] ~> vertex_obj[L]
                              & ∀ j, vertex_map[L] ∘ u ≈ @vertex_map _ _ _ F
                                       (@coneFrom _ _ _ N) j };
  homset  := fun _ _ => {| equiv := fun f g => `1 f ≈ `1 g |};
  id      := fun x => (id; _);
  compose := fun _ _ _ f g => (`1 f ∘ `1 g; _);
|}.
Next Obligation.
  rewrite comp_assoc.
  rewrite X0; auto.
Qed.

Definition Cocones `(F : J ⟶ C) := Cones (F^op).


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Set Implicit Arguments.

Require Import Bvector.
Require Import List.
Require Import Arith.

Require Import HMAC_functional_prog.
Require Import Integers.
Require Import Coqlib.
Require Import sha_padding_lemmas.
Require Import functional_prog.

(* Require Import List. Import ListNotations. *)

Definition Blist := list bool.

Fixpoint splitVector (A : Set) (n m : nat) :
  Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
    | 0%nat =>
      fun (v : Vector.t A (O + m)) => (@Vector.nil A, v) (* TODO *)
    | S n' =>
      fun (v : Vector.t A (S n' + m)) =>
        let (v1, v2) := splitVector _ _ (Vector.tl v) in
          (Vector.cons _ (Vector.hd v) _ v1, v2)
  end.

Definition concatToList (n m : nat) (v1 : Bvector n) (v2 : Bvector m) : Blist :=
  Vector.to_list v1 ++ Vector.to_list v2.

Definition compose {A B C : Type} (f : B -> C) (g : A -> B) (x : A) := f (g x).
Notation "f @ g" := (compose f g) (at level 80, right associativity).

Section HMAC.

(* b = block size
   c = digest (output) size
   p = padding = b - c (fixed) *)
  Variable c p : nat.
  Definition b := (c + p)%nat.

  (* The compression function *)
  Variable h : Bvector c -> Bvector b -> Bvector c.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Bvector c.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : list (Bvector b)) :=
    fold_left h m k.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  Check hash_words.
  Check h_star.

  Variable splitAndPad : Blist -> list (Bvector b).

  Definition hash_words_padded : Blist -> Bvector c :=
    hash_words @ splitAndPad.

(* New design:

hash_words : list (Bvector b) -> Bvector c

split_and_pad : Blist -> list (Bvector b)

hash_words_padded : Blist -> Bvector c
   hash_words_padded := hash_words . split_and_pad

concatToList : Bvector n -> Bvector m -> Blist

(p, fpad, app_fpad removed; c <= b)

In line 3 of GHMAC_2K:
hash_words_padded (concatToList k_out h_in

GNMAC? *)

  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  (* constant-length padding. *)
  Variable fpad : Bvector p.

  Definition app_fpad (x : Bvector c) : Bvector b :=
    (Vector.append x fpad).
  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  (* TODO fix this *)
  Definition GNMAC k m :=
    let (k_Out, k_In) := splitVector c c k in
    h k_Out (h_star_pad k_In m). (* could take head of list *)

  Check GNMAC.
  (* Vector.t bool (c + c) -> list (Bvector b) -> Bvector c *)
  Check h.

Check hash_words.

  (* The "two-key" version of GHMAC and HMAC. *)
  (* Concatenate (K xor opad) and (K xor ipad) *)
  Definition GHMAC_2K (k : Bvector (b + b)) m :=
    let (k_Out, k_In) := splitVector b b k in (* concat earlier, then split *)
      let h_in := (hash_words (k_In :: m)) in
        hash_words_padded (concatToList k_Out h_in).

SearchAbout Bvector.

  Definition HMAC_2K (k : Bvector (b + b)) (m : Blist) :=
    GHMAC_2K k (splitAndPad m).

Check HMAC_2K.
(* HMAC_2K
     : Bvector (b + b) -> Blist -> Bvector c *)

(* opad and ipad are constants defined in the HMAC spec. *)
Variable opad ipad : Bvector b.
Definition GHMAC (k : Bvector b) :=
  GHMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

Print BVxor.

Definition HMAC (k : Bvector b) :=
  HMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

Check HMAC.                     (*  : Bvector b -> Blist -> Bvector c *)

End HMAC.

(* ----------------------------------------------------------- Theorem definitions *)

Check HMAC_SHA256.HMAC.            (* list Z -> list Z -> list Z *)

  (* Bvector is little-endian (least significant bit at head; list Z are just translated
from the string (ascii -> nat -> Z); but Int are packed big-endian (with 4 Z -> 1 Int)

each Z is one byte (8 bits) *)

(* TODO: add isbyteZ (from SHA256.v), 0 <= i <= 256 *)

(* *************** byte/bit computational *)

Lemma add_1_r_S : forall (n : nat), (n + 1)%nat = S n.
Proof.
  induction n.
    reflexivity.
    simpl. rewrite -> IHn. reflexivity.
Defined.

(* TODO step through this *)
Locate leb. Check negb.
(* little-endian *)
Fixpoint iterate (n : nat) (byte : nat) : Bvector n.
Proof.
  destruct n.
     apply (Vector.nil bool).
  remember ((byte - NPeano.pow 2 n)%nat) as byte_subtract.
  remember (negb (leb byte_subtract 0)) as bool_digit. (* changed from leb: gt now *)
  remember (if bool_digit then byte_subtract else byte) as num_new.
  rewrite <- add_1_r_S.
  apply (Vector.append (iterate n num_new) [bool_digit]). (* n' *)
Defined.

Print iterate.
Eval compute in iterate 1 255.
Check eq_rec. Print eq_rec. Print eq_rect. Check eq_rect.
Print NPeano.Nat.add_1_r.

(* TODO: fix the latter + 1 *)
Fixpoint byte_to_bits (byte : Z) : Bvector 8 :=
  let max_pow_two := 7%nat in
  iterate (max_pow_two + 1) (nat_of_Z byte + 1).

  Print add_1_r_S.
Eval compute in iterate 8 2.
Eval compute in byte_to_bits 0.
Eval compute in byte_to_bits 1.
Eval compute in byte_to_bits 2.

Eval compute in byte_to_bits 127.
Eval compute in byte_to_bits 128.
Eval compute in byte_to_bits 129.
Eval compute in byte_to_bits 200.
Eval compute in byte_to_bits 255.
Eval compute in byte_to_bits 256. (* not valid *)

(* Or: concatMap byte_to_bit bytes *)

Fixpoint bytes_to_bits (bytes : list Z) : Bvector (length bytes * 8) :=
  match bytes as x return Bvector (length x * 8) with (* CPDT *)
    | nil => Vector.nil bool
    | x :: xs => Vector.append (byte_to_bits x) (bytes_to_bits xs)
  end.

(* ************* inductive defs *)

Definition asZ (x : bool) : Z := if x then 1 else 0.

(* TODO: maybe prefer b : byte, with Byte.repr? *)
Definition convertByteBits (b : Z) (B : Bvector 8) : Prop :=
  exists (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
   B = [b0; b1; b2; b3; b4; b5; b6; b7] /\
   b =  (1 * (asZ b0) + 2 * (asZ b1) + 4 * (asZ b2) + 8 * (asZ b3)
         + 16 * (asZ b4) + 32 * (asZ b5) + 64 * (asZ b6) + 128 * (asZ b7)).

(* *** *)

(* relating list Z to Blist
bytes_to_bits m = length M

TODO: big-endian, little-endian?
*)
Inductive bytes_bits_lists : list Z -> Blist -> Prop :=
  | eq_empty : bytes_bits_lists nil nil
  | eq_cons : forall (bytes : list Z) (bits : Blist)
                     (byte : Z) (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
                bytes_bits_lists bytes bits ->
                convertByteBits byte [b0; b1; b2; b3; b4; b5; b6; b7] ->
                bytes_bits_lists (byte :: bytes)
                                (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: bits).

(* *** *)

Lemma list_cons_len {A : Type} :
      forall (x : A) (xs : list A), length (x :: xs) = (1 + length xs)%nat.
Proof. intros. reflexivity. Defined.

Lemma mul_dist : forall (n m : nat), (n * (1 + m))%nat = (n + n * m)%nat.
Proof.
  intros. simpl.
  rewrite -> mult_succ_r. rewrite -> plus_comm. reflexivity.
Defined.

Print mult_succ_r.
Print plus_comm.

Fixpoint squash_list_vector
         (bits_list : list (Bvector 8)) : Bvector (8 * length bits_list).
Proof.
  destruct bits_list.
    apply (Vector.nil bool).
    rewrite -> list_cons_len.
    rewrite -> mul_dist.
    (* TODO watch out for endianness *)
  apply (Vector.append b0 (squash_list_vector bits_list)).
Defined.

SearchAbout Vector.cons.
Check Vector.cons.
Check Vector.cons bool true 1 [false].

(* TODO: how to write a better dependent pattern match? doesn't use the equality of their len
writing it as a proof and destructing n or b1/b2 doesn't work
*)
Fixpoint bvector_eq (n : nat) (m : nat) (b1 : Bvector n) (b2 : Bvector m) : bool :=
  match b1, b2 with             (*  match n as n0 return (Bvector n0) with *)
    | Vector.nil, Vector.nil => true
    | Vector.cons x1 _ xs1, Vector.cons x2 _ xs2 =>
      eqb x1 x2 && bvector_eq xs1 xs2
    | _, _ => false
  end.

(* TODO watch out for endianness *)

Definition bytes_bits_vector_comp
         (n : nat) (bytes : list Z) (bits : Bvector n) : bool.
Proof.
  remember (map byte_to_bits bytes) as bits_list_vector.
  remember (squash_list_vector bits_list_vector) as bvector.
  apply (bvector_eq bvector bits).
Defined.

Print bytes_bits_vector_comp.
(* Seems hard to use in a proof... *)

(* TODO: get this to be required *)
Eval compute in
    bytes_bits_vector_comp (0 :: nil) [true; true; true; true; true; true; true; true].

Lemma bytes_bits_vector_comp_len : forall (n : nat) (bytes : list Z) (bits : Bvector n),
                                     bytes_bits_vector_comp bytes bits = true
                                     -> n = (8 * length bytes)%nat.
Proof.
  (* TODO: bvector_eq is true iff the vectors are the same length *)
Admitted.

(* --------------------- *)

(* Lennart's definitions: *)

Definition bveqF :=
fix bveqF (n : nat) (b1 b2 : Bvector n) {struct n} : bool :=
  match n as n0 return (Bvector n0 -> Bvector n0 -> bool) with
  | 0%nat => fun _ _ : Bvector 0 => true
  | S n0 =>
      fun b3 b4 : Bvector (S n0) =>
      eqb (Vector.hd b3) (Vector.hd b4) &&
      bveqF n0 (Vector.tl b3) (Vector.tl b4)
  end b1 b2.

Fixpoint bveq (n:nat) (b1 b2:Bvector n): bool.
destruct n; intros. apply true. remember (S n) as m.
destruct b1. inversion Heqm. inversion Heqm. subst.  inversion b2. subst.
apply (eqb h h0 && bveq _ b1 H0).
(*  apply (eqb (Vector.hd b1) (Vector.hd b2) && (bveq _ (Vector.tl b1) (Vector.tl b2))).*)
Defined.

Print bveq.

Definition bveq1 (n:nat) (b1 b2:Bvector n): bool.
  induction n; intros. apply true.
  apply (eqb (Vector.hd b1) (Vector.hd b2) && (IHn (Vector.tl b1) (Vector.tl b2))).
Defined.

Definition bveqD :=
fun (n : nat) (b1 b2 : Bvector n) =>
nat_rec (fun n0 : nat => Bvector n0 -> Bvector n0 -> bool)
  (fun _ _ : Bvector 0 => true)
  (fun (n0 : nat) (IHn : Bvector n0 -> Bvector n0 -> bool)
     (b3 b4 : Bvector (S n0)) =>
   eqb (Vector.hd b3) (Vector.hd b4) && IHn (Vector.tl b3) (Vector.tl b4)) n
  b1 b2.

Eval compute in (bveqD [true; true; false] [true; true; false]).

(* TODO watch out for endianness *)

Definition bytes_bits_vector_comp'
         (bytes : list Z) (bits : Bvector (8 * length bytes)) : bool.
Proof.
  remember (map byte_to_bits bytes) as bits_list_vector.
  remember (squash_list_vector bits_list_vector) as bvector.
  assert (len_eq: length bytes = length bits_list_vector).
    rewrite -> Heqbits_list_vector.
    rewrite -> list_length_map.
    reflexivity.
  rewrite -> len_eq in bits.
  apply (bvector_eq bvector bits).
Defined.

(* *** *)

Inductive bytes_bits_vector : forall n
         (bytes : list Z) (bits : Bvector n), Prop :=
| bvv_nil: bytes_bits_vector nil []
| bvv_cons: forall n bytes1 bits1
                   (bt : Z) (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
              @bytes_bits_vector n bytes1 bits1 ->
              convertByteBits bt [b0; b1; b2; b3; b4; b5; b6; b7] ->
              @bytes_bits_vector (8 + n) (bt :: bytes1)
                                     (* TODO: is this the right endianness? *)
                                     (Vector.append [b0; b1; b2; b3; b4; b5; b6; b7] bits1).

(* ---------------------------------------------------------------- *)
(* Some more computational bytes/bits conversion definitions *)
(* TODO: plural or singular? e.g. bit to byte *)

(* Bytes to bits *)

(* Bits to bytes *)

(* Bytes to bits to bytes *)

(* Bits to bytes to bits *)

(* ----------------------------------------- Theorem and parameters *)

Check HMAC_SHA256.HMAC.
Check HMAC.
(* HMAC
     : forall c p : nat,
       (Bvector c -> Bvector (b c p) -> Bvector c) ->   // compression function h
       Bvector c ->                          // iv, h's initialization vector
       (Blist -> list (Bvector (b c p))) ->  // splitAndPad (e.g. generate_and_pad)
       Bvector (b c p) ->                    // opad
       Bvector (b c p) ->                    // ipad

^ Note: this has to do with the internals of SHA256 and HMAC too
SHA's compression function, iv, generate_and_pad (with block vectors),
HMAC's key padding function, HMAC's opad and ipad.
How to convert?

       Bvector (b c p) -> Blist -> Bvector c        // key, message, outputted hash

k is of length b
b = block size
c = output size
p = padding = b - c

for h: convert iv and chunk from bits to bytes, run SHA h, convert result from bytes to bits
for iv: SHA uses a list of 64 ints (block size), but here, we want 512 bits.
   normal bytes to bits conversion should work
for splitAndPad: convert msg from bits to bytes, run SHA generate_and_pad',
   convert to bits, split into list of block-size chunks (with proof that this is possible)
 *)

(* ------------------------------------- *)
Module Equiv.

Definition c:nat := (SHA256_.DigestLength * 8)%nat.

Definition p:=(32 * 8)%nat.

Parameter sha_iv : Bvector (SHA256_.DigestLength * 8).

(* Definition sha_h : list Z -> list Z := SHA256_.Hash. *)
Parameter sha_h : Bvector c -> Bvector (c + p) -> Bvector c.

Parameter sha_splitandpad_vector :
  Blist -> list (Bvector (SHA256_.DigestLength * 8 + p)).

(* Parameter fpad : Bvector p. *)

Definition bytes_bits_conv_vector
           (byte_pad : byte) (bits_pad : Bvector (c + p)) : Prop :=
  let bytes_pad := map Byte.unsigned (HMAC_SHA256.sixtyfour byte_pad) in
  bytes_bits_vector bytes_pad bits_pad.

(*
TODO define computational version

Definition bytes_bits_conv_vector'
           (byte_pad : byte) -> Bvector (c + p)) :=
  let bytes_pad := map Byte.unsigned (HMAC_SHA256.sixtyfour byte_pad) in
  bytes_bits_vector bytes_pad bits_pad.
*)

(* -------------- *)
(* Theorem lemmas *)

(*  (let (k_Out, k_In) :=
                       splitVector (b 256 256) (b 256 256)
                         (Vector.append (BVxor (b 256 256) K OP)
                            (BVxor (b 256 256) K IP)) in
Possibly try n = m -> splitVector n m...
*)

SearchAbout Bvector.

Lemma empty_vector : forall (v : Bvector 0),
                       v = [].
Proof.
  intros v.
  (* destruct v. *)

Admitted.

Lemma split_append_id : forall (len : nat) (v1 v2 : Bvector len),
                          splitVector len len (Vector.append v1 v2) = (v1, v2).
Proof.
  induction len; intros v1 v2.
  (* Case len = 0 *)
    (* simpl. rewrite -> empty_vector. *)

    Admitted.

(* Is this the theorem we want? Is it useful for the rest of the proofs?
Should it be more abstract? *)

(* TODO: 10/25/14

- fill in parameters: sha_h, sha_iv, sha_splitandpad_vector, (fpad) **
   - write bits to bytes function
   - rewrite bytes to bits
   - replace inductive defs with computational?
   - functional_prog.generate_and_pad' has type list Z -> Z -> list int... rewrite it?
   - g_a_p has type list Z -> list int
   - Zlist_to_intlist?
   - using new fpad version: prove equivalence
   - prove SHA256.hash_blocks equivalence with fold
   - need inner lemmas, gradually build up to full theorem + composition lemmas
- step through theorem
  - figure out how to use relations in theorem: compositional? f property? **
- add lemma for xor **
   - lennart: B2b (Byte.xor B1 B2) = Vector.map2 xorb (B2b B1) (B2b B2)

- clean up file
- look at ASCII library
   - rewrite iterate to emulate their conversion
- check bytes_bits_vector' fixpoint
   - look at new definitions, inductive?
   - see if induction works with it
- figure out how to get split lemmas to work

- skim Bellare proof and Adam's proof
- read Adam's papers on FCF, etc.
- some other paper with a good approach?
- generalize technique for crypto
 *)

(* Options:
bytes_bits_vector (inductive, returns prop)
bytes_bits_vector_comp (returns bool)
bytes_bits_vector_comp' (returns bool) *)

  (*  (hash_words 256 sha_h sha_iv
                          (BVxor 512 K IP :: sha_splitandpad_vector M))

HMAC_SHA256.INNER op
                       (map Byte.repr (HMAC_SHA256.mkKey k)) m

Bvector c vs. list Z
 *)

Theorem HMAC_inner_equiv : forall
                             (k m : list Z)
                             (K : Bvector (plus c p)) (M : Blist)
                             (bits_inner : Bvector c) (bytes_inner : list Z)
                             (ip : byte) (IP : Bvector (plus c p)),
 ((length k) * 8)%nat = (c + p)%nat ->
  bytes_bits_vector k K ->
  bytes_bits_lists m M ->
  bytes_bits_conv_vector ip IP ->

  (* or-- hash_words_padded? *)
  hash_words 256 sha_h sha_iv
             (BVxor 512 K IP :: sha_splitandpad_vector M) = bits_inner ->

  HMAC_SHA256.INNER ip
                    (map Byte.repr (HMAC_SHA256.mkKey k)) m = bytes_inner ->

  bytes_bits_vector bytes_inner bits_inner.
Proof.
  intros k m K M bits_inner bytes_inner ip IP.
  intros padded_key_len padded_keys_eq msgs_eq ips_eq.
  intros HMAC_abs HMAC_con.

Admitted.

(* ------------------ *)

Lemma comp : forall {A B C : Type} (f : B -> C) (g : A -> B) (x : A),
               (f @ g) x = f (g x).
Proof. intros.  reflexivity. Qed.

(*
Theorem equiv : forall {t T : Type}
                  (tT : t -> T) (Tt : T -> t)
                  (f : t -> t) (F : T -> T)
                  (x : t) (X : T),
                  x = Tt X      (* x ~ X *)
                  -> F = (tT @ f @ Tt) (* f = Tt @ F @ tT *)
                  -> f (Tt X) = Tt (tT (f (Tt X)))
                  -> f x = Tt (F X).
Proof.
  intros t T tT Tt f F x X.
  intros relation composition roundtrip.
  (* x ~ y := x = Tt y *)
  rewrite composition.
  rewrite relation.
  repeat rewrite -> comp.
  apply roundtrip.              (* specific to input-roundtrip-preserving property of f *)
Qed.
*)

(* TODO look in Algebra lib *)
(* x ~ y -> f x ~ f y  , x y : a  *)

Theorem equiv' : forall {t T : Type} (* t = bits, T = bytes --
                                        list Z or list byte, Bvector Blist *)
                  (tT : t -> T) (Tt : T -> t)
                  (f : t -> t) (F : T -> T)
                  (x : t) (X : T),
                  x = Tt X      (* x ~ X *)
                  -> f = (Tt @ F @ tT)
                  -> (tT @ Tt) = id (* @ - comp *)
                  -> f x = Tt (F X). (* f x ~ F X -- byte_bits_vector *)
(* HMAC_abs (bytes_to_bytes m1) = bytes_to_bits (HMAC_CONCRETE m1) *)

(* TODO: start a section parametrized by ~, axioms about ~ *)
Proof.
  intros t T tT Tt f F x X.
  intros relation composition roundtrip.
  (* x ~ y := x = Tt y *)
  rewrite composition.
  rewrite relation.
  repeat rewrite -> comp.
  change (tT (Tt X)) with ((tT @ Tt) X).
  rewrite roundtrip.
  unfold id.
  reflexivity.
Qed.
  (* apply roundtrip.              (* specific to input-roundtrip-preserving property of f *) *)

Require Import JMeq.

Theorem equiv_JM : forall {t T : Type} (* t = bits, T = bytes --
                                        list Z or list byte, Bvector Blist *)
                  (tT : t -> T) (Tt : T -> t)
                  (f : t -> t) (F : T -> T)
                  (x : t) (X : T),
                  JMeq x X      (* x ~ X *)
                  -> JMeq f (Tt @ F @ tT)
                  -> (tT @ Tt) = id
                  -> JMeq (f x) (F X). (* f x ~ F X -- byte_bits_vector *)

(* TODO: start a section parametrized by ~, axioms about ~ *)
Proof.
  intros t T tT Tt f F x X.
  intros relation composition roundtrip.
  (* x ~ y := x = Tt y *)
  rewrite composition.
  apply eq_dep_id_JMeq.

  SearchAbout EqdepFacts.eq_dep.
  SearchAbout JMeq.
Abort.
(*
  rewrite relation.
    repeat rewrite -> comp.
  change (tT (Tt X)) with ((tT @ Tt) X).
  rewrite roundtrip.
  unfold id.
  reflexivity.
Qed.
*)

Theorem equiv_comp : forall {t T : Type}
                  (tT : t -> T) (Tt : T -> t)
                  (f : t -> t) (F : T -> T) (g : t -> t) (G : T -> T)
                  (x : t) (X : T),
                  x = Tt X
                  -> f = (Tt @ F @ tT)
                  -> f x = Tt (F X) (* inner composition *)

                  -> g = (Tt @ G @ tT) (* not sure if true *)
                  -> (tT @ Tt) = id
                  -> g (f x) = Tt (G (F X)).
Proof.
  intros t T tT Tt f F g G x X.
  intros relation composition_f inner composition_g roundtrip.
  apply equiv' with tT.
  (* Assump 1 *)
    apply inner.
  (* Assump 2 *)
    apply composition_g.
  (* Assump 3  *)
    apply roundtrip.
Qed.

(* needs to be computational due to function composition? *)
Theorem equiv_prop : forall {t T : Type}
                  (tT : t -> T) (Tt : T -> t)
                  (* (Tt_prop : T -> t -> Prop) *)
                  (tT_prop : t -> T -> Prop)
                  (f : t -> t) (F : T -> T)
                  (x : t) (X : T),
                  tT_prop x X
                  -> f = (Tt @ F @ tT)
                  -> tT_prop (f x) (F X).
Proof.
  intros t T tT Tt tT_prop f F x X.
  intros relation composition.
  rewrite composition.
  (* rewrite relation. *)
  (* x = Tt X  <- bytes_to_bits *)

  repeat rewrite -> comp.

Admitted.

Parameter bB : forall m, Bvector m -> list Z.
Check bytes_to_bits.
Print bytes_bits_vector.

Theorem equiv_prop' : forall (m : nat)
                  (f : (forall n, Bvector n -> Bvector n)) (F : list Z -> list Z)
                  (x : Bvector m) (X : list Z),
                  bytes_bits_vector X x
                  -> F X = bB (f (length X * 8)%nat (bytes_to_bits X))
                  -> bytes_bits_vector (bB (f (length X * 8)%nat (bytes_to_bits X)))
                                       (f (length X * 8)%nat (bytes_to_bits X))
                  -> bytes_bits_vector (F X) (f m x).
Proof.
  intros m f F x X.
  intros relation composition roundtrip.
  (* rewrite composition. repeat rewrite -> comp. *)
  induction relation.
  (* Case nil *)
    assert (H1: F nil = nil). admit.
    assert (H2: f 0%nat [] = []). admit.
    rewrite -> H1. rewrite -> H2.
    apply bvv_nil.
  (* Case ind *)
    (* Vector.append is a problem *)
    rewrite -> composition.
    Print bytes_bits_vector.

Admitted.

  (* true if

   bytes_to_bits bits_to_bytes x = x iff len x is divisible by 8
   (x : Bvector n)

   f (x : Bvector n * 8) : Bvector n' * 8 -- when?

   plus, how does the composition work?

       (hash_words_padded 256 sha_h sha_iv sha_splitandpad_vector
        (concatToList (BVxor 512 K OP)
           (hash_words 256 sha_h sha_iv
              (BVxor 512 K IP :: sha_splitandpad_vector M))))

 (hash_words_padded 256 sha_h sha_iv sha_splitandpad_vector
        (concatToList (BVxor 512 K OP) bits_inner)
 )

   *)

(* ------------------ *)

Require Import JMeq.

(* Parameter bbv (bytes : list Z) -> Bvector (length bytes). *)
Parameter bbl : (list Z -> Blist).
Parameter bbv_byte : forall n, (byte -> Bvector n).
Check JMeq.
Print JMeq.

(* TODO *)
Definition conv : forall (m n : nat) (e : Bvector n) (E : m = n), Bvector m.
Proof.
  intros m n h1 h2.
  rewrite -> h2.
  apply h1.
Defined.

Lemma sn_eq : forall (n : nat), (n + 1)%nat = S n. Proof. Admitted.

Lemma test' : forall (n : nat) (b1 : Bvector (S n)) (b2 : Bvector (n + 1)),
               conv b1 (sn_eq n) = b2.
Proof.
Abort.

(*
Doesn't typecheck, whereas the above does
Lemma test : forall (n : nat) (b1 : Bvector (S n)) (b2 : Bvector (n + 1)),
               b1 = b2.
Proof.
  *)

Theorem HMAC_spec_equiv : forall
                            (k m h : list Z)
                            (K : Bvector (c + p)) (M : Blist) (H : Bvector c)
                            (op ip : byte) (OP IP : Bvector (plus c p))
                          (bits_inner : Bvector c) (bytes_inner : list Z),
  ((length k) * 8)%nat = (c + p)%nat ->
  (* bytes_to_bits k = K -> *)
  JMeq (bytes_to_bits k) K ->                  (* vector *)
  (* TODO: dependent equality / John Major
     to substitute K for k, need theorems about JM equality?
     finish specifying theorem, intro and elim JMeq
   *)
  (* bbl m = M ->                  (* list *) *)
  (* bbv_byte op = OP -> *)
  (* bbv_byte ip = IP -> *)
  True -> True -> True ->
  HMAC p sha_h sha_iv sha_splitandpad_vector OP IP K M = H ->
  HMAC_SHA256.HMAC ip op m k = h -> (* m k, not k m *)
  (* bytes_to_bits h = H. *)
  JMeq (bytes_to_bits h) H.     (* H ~ h <- bytes_to_bits_vector, inductive def *)
(* computational CONVERTS bytes to bits *)

  (* inductive works because it defers the type-level computation,
     but function composition is computational... *)
Proof.
  intros k m h K M H op ip OP IP bits_inner bytes_inner.
  intros padded_key_len padded_keys_eq msgs_eq ops_eq ips_eq.
  intros HMAC_abstract HMAC_concrete.
  Check bytes_to_bits.
  Print c.
  (* apply equiv. *) (* TODO *)

SearchAbout JMeq.

  unfold p, c in *.
  simpl in *.

  unfold HMAC in *. simpl in *.
  unfold HMAC_SHA256.HMAC in *.

  unfold HMAC_2K in *. unfold GHMAC_2K in *. (* unfold splitVector in *. *)
  (* Still abstract: sha_h, sha_splitandpad_vector *)
  Check sha_h.
  rewrite -> split_append_id in HMAC_abstract.

Check (hash_words 256 sha_h sha_iv
                          (BVxor 512 K IP :: sha_splitandpad_vector M)).

Check HMAC_SHA256.INNER ip
                       (map Byte.repr (HMAC_SHA256.mkKey k)) m.

  unfold HMAC_SHA256.OUTER in *. unfold HMAC_SHA256.INNER in *.
  pose proof HMAC_inner_equiv as inner_equiv.
  specialize inner_equiv with k m K M bits_inner bytes_inner ip IP.
  rewrite <- HMAC_abstract. rewrite <- HMAC_concrete.
Abort.
  (* apply equiv. *)

(*
  Show: x ~ X -> f x ~ F X
  or: x ~ X -> y ~ Y -> f x y ~ F X Y
  or: f : b -> b, F -> B -> B

      SHOW: x:b ~ X:B -> F = bB . f . Bb ->  f x ~ F X
      f x ~ (bB . f . Bb) X
      f x ~ bB (f (Bb X))

      x ~ X means that x = Bb X
      so I need to show that f x = Bb (bB (f (Bb X))), given that x = Bb X

      or: f x = bytes_to_bits bits_to_bytes f bytes_to_bits X
          f bytes_to_bits x = bytes_to_bits bits_to_bytes f bytes_to_bits x
          bytes_to_bits bits_to_bytes = id ON f bytes_to_bits x
          this depends on a property of f

question: how is bits_to_bytes defined? TODO

bytes = list Z (of length n)
  bytes to bits: convert each Z to Bvector 8; concat (maybe reversing for endianness)
    into Bvector 8 * n
bits = Bvector m
  bits to bytes:
   0100010101110 : pad with front zeroes until multiple of 8? (possibly reverse and pad)
     OR throw away the rest of the bits
     OR return nothing
   e.g. 100 to a byte = 00000100 to a byte = 4 (as Z)

->
 *)

Theorem HMAC_spec_equiv' : forall
                            (k m h : list Z)
                            (K : Bvector (plus c p)) (M : Blist) (H : Bvector c)
                            (op ip : byte) (OP IP : Bvector (plus c p)),
  ((length k) * 8)%nat = (c + p)%nat ->
  bytes_bits_vector k K ->
  bytes_bits_lists m M ->
  bytes_bits_conv_vector op OP ->
  bytes_bits_conv_vector ip IP ->
  HMAC c sha_h sha_iv sha_splitandpad_vector OP IP K M = H -> (* bits: h <- conversion . byte_h *)
  HMAC_SHA256.HMAC ip op m k = h -> (* m k, not k m *) (* bytes *)
  bytes_bits_vector h H.            (* TODO reverse capital/lowercase *)
Proof.
  intros k m h K M H op ip OP IP.
  intros padded_key_len padded_keys_eq msgs_eq ops_eq ips_eq.
  intros HMAC_abstract HMAC_concrete.

subst h.
subst H.
induction msgs_eq.
Focus 2.
(*
  + admit.
    +*)
(*
  remember K as K'.
  assert (JMeq K K') by (subst; reflexivity).
  clear HeqK'.
  rewrite <- H0 in HMAC_abstract.

  unfold bytes_bits_conv_vector in ops_eq, ips_eq.
  pose (c + p)%nat as n0.
  assert (c + p = n0)%nat by auto.
  clearbody n0.
  revert OP IP padded_key_len K' padded_keys_eq ops_eq ips_eq H.

  Print bytes_bits_vector.
  Print HMAC.
  Print Vector.t.
  Print bytes_bits_lists.

  Set Printing All.
+
Check HMAC.
Print bytes_bits_conv_vector.
  remember (c + p)%nat as n0.
  revert HMAC_abstract.
Check @HMAC.
  + induction padded_keys_eq.

  induction h.                  (* TODO:  h nil -> H nil *)
  (* or -- induction on m *)
    + admit.                      (* use bullets *)
    +                             (* a :: h <-> H1 :: H@ .... H8 ... :: H *)
      rewrite <- HMAC_concrete.
      rewrite <- HMAC_abstract.
*)
  intros.
  unfold p, c in *.
  simpl in *.

  (*  *)
  unfold HMAC in *. simpl in *.
  unfold HMAC_SHA256.HMAC in *.

  Check equiv'.
  Print bytes_bits_vector.

(* TODO: relate first byte of input with first byte of output?
        but the output is fixed length?
        f (x :: xs) = ? ... f xs

f x = g (h x)
h (x :: xs) = H x (h xs)

 *)

  unfold HMAC_2K in *. unfold GHMAC_2K in *. (* unfold splitVector in *. *)

Print HMAC_SHA256.OUTER.
(*
  apply IHmsgs_eq.
  (* Still abstract: sha_h, sha_splitandpad_vector *)
  Check sha_h.  *)

  rewrite -> split_append_id.

Print bytes_bits_conv_vector.

(* Check (hash_words 256 sha_h sha_iv *)
                          (* (BVxor 512 K IP :: sha_splitandpad_vector M)). *)

(* Check HMAC_SHA256.INNER ip *)
                       (* (map Byte.repr (HMAC_SHA256.mkKey k)) m. *)

  unfold HMAC_SHA256.OUTER in *. unfold HMAC_SHA256.INNER in *.

    unfold SHA256_.Hash in *.

    (* -- *)

    unfold HMAC_SHA256.innerArg. unfold HMAC_SHA256.mkArgZ. unfold HMAC_SHA256.mkArg.

    (* -- *)

    rewrite -> functional_prog.SHA_256'_eq in *.
    unfold SHA256.SHA_256 in *.
    repeat rewrite <- sha_padding_lemmas.pad_compose_equal in *.
    unfold sha_padding_lemmas.generate_and_pad' in *.

    unfold hash_words_padded in *.
    unfold hash_words in *.
    unfold compose in *.
    (* hash_words_padded 256 sha_h sha_iv sha_splitandpad_vector
        ~ SHA256.hash_blocks SHA256.init_registers *)
    Check h_star 256 sha_h sha_iv. Check SHA256.hash_blocks SHA256.init_registers.
    Check hash_words_padded 256 sha_h sha_iv sha_splitandpad_vector.
    Print SHA256.registers.
    (* Blist -> Bvector c vs.
       list int -> SHA256.registers = list int *)
    (* unfold h_star in *. *)
    (* pad : list Z -> list Z *)

    (* unfold SHA256.hash_blocks in *. *)

    unfold HMAC_SHA256.outerArg in *. unfold HMAC_SHA256.innerArg in *.
    unfold HMAC_SHA256.mkArgZ in *. unfold HMAC_SHA256.mkArg in *.

  unfold BVxor in *. unfold xorb in *. (* unfold Vector.map2 in *. *)
  unfold Byte.xor in *. unfold Z.lxor in *.

  (* Lemma:

BVxor (b 256 256) K OP = Vector.map2 xorb K OP (can unfold xorb)
     ~
                          (map
                          (fun p0 : byte * byte => Byte.xor (fst p0) (snd p0))
                          (combine (map Byte.repr (HMAC_SHA256.mkKey k))
                             (HMAC_SHA256.sixtyfour ip)))

probably want a meta-lemma for composition of relations
r1 x X -> r2 y Y -> ?f ? -> f x y ~ F X Y

try with smaller examples first

figure out how to approach proof: avoid 4-way induction
 *)

Abort.

    (* just try on hash function?
       bytes_bits_vector (SHA (byte :: bytes))
                          (bytes_to_bits . SHA . bits_to_bytes) (b0 :: ... :: b7 :: bits))

just try on concatenation?

msgs_eq:
c ++ m_bytes = c' ++' m_bits
induction

c ++ (byte :: bytes) = c' ++' (b0 :: ... :: b7 :: bits)
(it's actually c' :: sha_splitandpad_vector (b0 :: ... :: b7 :: bits) -- try later)
given: c' = bytes_to_bits c (need to prove)
       ++' = Vector.append (or list cons)

TODO: HMAC_lemmas proof techniques?
maybe i should prove that it's impossible to prove equiv

     *)
Check Byte.unsigned.

Lemma xor_equiv : forall (ip : byte) (k : list Z) (r_bytes : list Z)
                  (IP : Bvector (c + p)) (K : Bvector (c + p)) (r_bits : Bvector (c + p)),
                    (length k * 8)%nat = (c + p) %nat ->
                    bytes_bits_conv_vector ip IP ->
                    bytes_bits_vector k K ->
                    map Byte.unsigned (
                          map
                            (fun p0 : Integers.byte * Integers.byte =>
                               Byte.xor (fst p0) (snd p0))
                            (combine (map Byte.repr (HMAC_SHA256.mkKey k))
                                     (HMAC_SHA256.sixtyfour ip))) = r_bytes ->
                    BVxor 512 K IP = r_bits ->
                    bytes_bits_vector r_bytes r_bits.
Proof.
  intros ip k r_bytes IP K r_bits.
  intros ips_eq keys_eq bytes_xor bits_xor.
  subst. unfold bytes_bits_conv_vector in *.
  unfold BVxor. SearchAbout Vector.map2.
(* problem: k and ip are both fixed length -- might want to do computationally *)
  (* induction keys_eq. *)

Admitted.

(* Lemma xor_equiv_comp : forall (ip : byte) (k : list Z) (r_bytes : list Z) *)
(*                   (IP : Bvector (c + p)) (K : Bvector (c + p)) (r_bits : Bvector (c + p)), *)
(*                     (length k * 8)%nat = (c + p) %nat -> *)

Lemma concat_equiv :
  forall (l1 : list Z) (l2 : Blist) (m1 : list Z) (m2 : Blist),
    bytes_bits_lists l1 l2
    -> bytes_bits_lists m1 m2
    -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2).
(* bytes_bits_lists l1 l2 -> bytes_bits_lists m1 m2 -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2) *)
Proof.
  intros l1 l2 m1 m2.
  intros fst_eq snd_eq.
  generalize dependent m1. generalize dependent m2.
  induction fst_eq; intros.
  - repeat rewrite app_nil_l.
    apply snd_eq.
  - simpl.
    apply eq_cons.
    + apply IHfst_eq.
      apply snd_eq.
    + apply H.
Qed.

(* If inducting on the second param
TODO: try proving this without inducting on the first param...? or bytes_bits_vector firs param
*)
Lemma concat_equiv_snd :
  forall (l1 : list Z) (l2 : Blist) (m1 : list Z) (m2 : Blist),
    bytes_bits_lists l1 l2
    -> bytes_bits_lists m1 m2
    -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2).
(* bytes_bits_lists l1 l2 -> bytes_bits_lists m1 m2 -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2) *)
Proof.
  intros l1 l2 m1 m2.
  intros fst_eq snd_eq.
  generalize dependent l1. generalize dependent l2.
  induction snd_eq; intros.
    + repeat rewrite app_nil_r.
      apply fst_eq.
    + induction fst_eq.           (* might need to generalize *)
      * repeat rewrite app_nil_l in *.
        apply eq_cons.
        apply snd_eq.
        - apply H.
      * simpl.
        apply eq_cons.
        apply IHfst_eq.
        - apply H0.
Qed.

Lemma concat_equiv_snd_vec :
  forall (n: nat) (l1 : list Z) (l2 : Bvector n) (m1 : list Z) (m2 : Blist),
    bytes_bits_vector l1 l2
    -> bytes_bits_lists m1 m2
    -> bytes_bits_lists (l1 ++ m1) (Vectorl2 ++ m2).
(* bytes_bits_lists l1 l2 -> bytes_bits_lists m1 m2 -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2) *)
Proof.
  intros l1 l2 m1 m2.
  intros fst_eq snd_eq.
  generalize dependent l1. generalize dependent l2.
  induction snd_eq; intros.
    + repeat rewrite app_nil_r.
      apply fst_eq.
    + induction fst_eq.           (* might need to generalize *)
      * repeat rewrite app_nil_l in *.
        apply eq_cons.
        apply snd_eq.
        - apply H.
      * simpl.
        apply eq_cons.
        apply IHfst_eq.
        - apply H0.
Qed.