Require Import Coq.Vectors.Vector.
Require Import QArith.
Require Import Setoid.

(*******************************************************************************************
    Helpful definitions and proofs about Rationals (Q)
 *******************************************************************************************)
Definition Qge_bool (a b : Q) : bool := Qle_bool b a.
Definition Qlt_bool (a b : Q) : bool := andb (Qle_bool a b) (negb (Qeq_bool a b)).
Definition Qgt_bool (a b : Q) : bool := Qlt_bool b a.

Lemma Qsquare_nonneg : forall (a : Q),
 0 <= a * a.
Proof.
  intros a. unfold Qle. simpl. rewrite Zmult_1_r. apply Z.square_nonneg. Qed.

Lemma Qsquare_gt_0 : forall (a : Q),
  (~a == 0) -> (a*a) > 0.
Proof.
  intros. destruct a. unfold Qlt. simpl. rewrite Z.mul_1_r. unfold Qeq in H.
  simpl in H. rewrite Z.mul_1_r in H. destruct Qnum. exfalso. apply H. reflexivity.
  apply Z.mul_pos_pos; reflexivity. apply Z.mul_neg_neg; reflexivity. Qed.

Lemma Qopp_mult_distr_l : forall (a b : Q),
  Qopp (a * b) == (Qopp a) * b.
Proof.
  intros. unfold Qmult. simpl. unfold Qeq. simpl.
  rewrite <- (Zopp_mult_distr_l (Qnum a) (Qnum b)). reflexivity.
Qed.

Lemma Qopp_mult_distr_r : forall (a b : Q),
  Qopp (a * b) == a * (Qopp b).
Proof.
  intros. unfold Qmult. simpl. unfold Qeq. simpl.
  rewrite <- (Zopp_mult_distr_r (Qnum a) (Qnum b)). reflexivity.
Qed.

Lemma Qplus_diag_eq_mult_2 : forall (a : Q),
  Qplus a a == Qmult (2#1) a.
Proof.
  intros. unfold Qeq, Qmult, Qplus. simpl.
  rewrite Zplus_diag_eq_mult_2. repeat rewrite <- Zmult_assoc.
  rewrite (Zmult_assoc _ 2 _). rewrite (Zmult_comm _ 2).
  repeat rewrite Zmult_assoc. rewrite (Zmult_comm _ 2).
  repeat rewrite <- Zmult_assoc. rewrite (Zmult_assoc 2 _ _).
  simpl. reflexivity. Qed.

Lemma Qle_neq_lt : forall (a b : Q),
  a <= b -> ~ a == b -> a < b.
Proof.
  intros. apply Qle_lteq in H. inversion H.
  apply H1. exfalso. apply H0. apply H1. Qed.

(*****************************************************************************************
    Definitions and Fixpoints for operations on Qvecs
    (Also includes Fixpoints/Computation on Training Data: list ((Qvec n)*bool))
 *****************************************************************************************)

(** Hacking this to avoid changing everything. Always normalize/reduce after plus and mult **)
Definition Qplus (a b : Q) : Q := Qred (Qplus a b).
Infix "+" := Qplus : Q_scope.
Definition Qmult (a b : Q) : Q := Qred (Qmult a b).
Infix "*" := Qmult : Q_scope.

Definition Qvec := Vector.t Q.
Definition Qvec_plus {n:nat} (v1 v2 : Qvec n) := map2 Qplus v1 v2.
Definition Qvec_dot {n:nat} (v1 v2 : Qvec n) := fold_left Qplus 0 (map2 Qmult v1 v2).
Definition Qvec_normsq {n:nat} (v1 : Qvec n) := Qvec_dot v1 v1.
Definition Qvec_zero (n : nat) : Qvec n := const 0 n.

Definition class (i : Q) : bool := Qle_bool 0 i.
Definition correct_class (i : Q) (l : bool) : bool :=
  andb (Bool.eqb l (class i)) (negb (Qeq_bool i 0)).
Definition Qvec_mult_class {n:nat} (l :bool) (f : Qvec n) :=
  if l then f else map (Qmult (-1%Z#1)) f.
Definition Qvec_mult_scalar {n : nat} (s : Q) (f : Qvec n) := map (Qmult s) f.
Definition consb {n : nat} (v : Qvec n) := cons _ 1 _ v.

Fixpoint Qvec_sum_class {n : nat} (w : Qvec (S n)) (M : list ((Qvec n)*bool)) : Qvec (S n) :=
  match M with
  | List.nil => w
  | List.cons (f, l) M' => Qvec_sum_class (Qvec_plus w (Qvec_mult_class l (consb f))) M'
  end.

Fixpoint Qvec_sum {n : nat} (M : list ((Qvec n)*bool)) : Qvec (S n) :=
  match M with
  | List.nil => Qvec_zero (S n)
  | List.cons (f, l) M' => Qvec_plus (Qvec_mult_class l (consb f)) (Qvec_sum M')
  end.

Fixpoint min_element_product {n : nat} (w : Qvec (S n)) (T: list ((Qvec n)*bool)) : Q :=
  match T with
  | List.nil => 1 (* avoid divide by zero *)
  | List.cons (f, l) List.nil => Qvec_dot w (Qvec_mult_class l (consb f))
  | List.cons (f, l) T' =>
      if (Qle_bool (Qvec_dot w (Qvec_mult_class l (consb f))) (min_element_product w T'))
      then (Qvec_dot w (Qvec_mult_class l (consb f)))
      else (min_element_product w T')
  end.

Fixpoint max_element_normsq {n : nat} (T: list ((Qvec n)*bool)) : Q :=
  match T with
  | List.nil => 1
  | List.cons (f, l) List.nil => (Qvec_normsq (consb f))
  | List.cons (f, l) T' =>
      if (Qge_bool (Qvec_normsq (consb f)) (max_element_normsq T'))
      then (Qvec_normsq (consb f))
      else (max_element_normsq T')
  end.

Fixpoint Qvec_sum_normsq {n:nat} (L: list ((Qvec n)*bool)) : Q :=
  match L with
  | List.nil => 0
  | List.cons (f, l) L' => Qplus (Qvec_normsq (consb f)) (Qvec_sum_normsq L')
  end.

Fixpoint Qvec_sum_dot {n:nat} (w : Qvec (S n)) (L: list ((Qvec n)*bool)) : Q :=
  match L with
  | List.nil => 0
  | List.cons (f, l) L' => Qplus (Qvec_dot w (Qvec_mult_class l (consb f))) (Qvec_sum_dot w L')
  end.

Fixpoint Qvec_foil {n:nat} (w : Qvec (S n)) (L: list ((Qvec n)*bool)) : Q :=
  match L with
  | List.nil => 0
  | List.cons (f, l) L' => Qplus (Qvec_dot w (Qvec_mult_class l (consb f)))
                                 (Qvec_foil (Qvec_plus w (Qvec_mult_class l (consb f))) L')
  end.

 (****************************************************************************************
    Case Analysis for Vectors + Induction Principles for multiple vectors.
  ****************************************************************************************)
Definition Vector_0_is_nil {A} (v : t A 0) : v = nil A :=
match v with
| nil _ => eq_refl
end.

Definition Vector_S_is_cons {A} {n} (v: t A (S n)) : exists a, exists v0, v = cons A a n v0 :=
match v as v' in t _ n1
  return match n1 return t A n1 -> Prop with
  |O => fun _ => True
  |S n => fun v => exists a, exists v0, v = cons A a n v0 end v' with
| nil _ => I
| cons _ a _ v0 => ex_intro _ a (ex_intro _ v0 (refl_equal _))
end.

Lemma Vector_S_is_cons' : forall {A : Type} {n : nat} (v : t A (S n)),
  v = cons A (hd v) n (tl v).
Proof.
  intros. assert (H := Vector_S_is_cons v). destruct H as [a [v' H]].
  rewrite H. simpl. reflexivity. Qed.

Lemma mutual_induction : forall {A B: Type} (P : forall {n : nat}, t A n -> t B n -> Prop),
  (P (nil A) (nil B)) -> (forall (h1 : A) (h2 : B) {n : nat} (t1 : t A n) (t2 : t B n),
  (P t1 t2) -> (P (cons A h1 n t1) (cons B h2 n t2))) ->
  forall {n : nat} (v1 : t A n) (v2 : t B n), P v1 v2.
Proof.
  intros. induction n. rewrite (Vector_0_is_nil v1).
  rewrite (Vector_0_is_nil v2). apply H.
  assert (H1 := Vector_S_is_cons v1). assert (H2 := Vector_S_is_cons v2).
  destruct H1 as [a [v1' H1]]. destruct H2 as [b [v2' H2]]. rewrite H1.
  rewrite H2. apply H0. apply IHn. Qed.

Lemma triple_induction : forall {A B C: Type} (P : forall {n : nat}, t A n -> t B n -> t C n-> Prop),
  (P (nil A) (nil B) (nil C)) ->
  (forall (h1 : A) (h2 : B) (h3 : C) {n : nat} (t1 : t A n) (t2 : t B n) ( t3 : t C n),
  (P t1 t2 t3) -> (P (cons A h1 n t1) (cons B h2 n t2) (cons C h3 n t3))) ->
  forall {n : nat} (v1 : t A n) (v2 : t B n) (v3 : t C n), P v1 v2 v3.
Proof.
  intros. induction n. rewrite (Vector_0_is_nil v1). rewrite (Vector_0_is_nil v2).
  rewrite (Vector_0_is_nil v3). apply H. assert (H1 := Vector_S_is_cons v1).
  assert (H2 := Vector_S_is_cons v2). assert (H3 := Vector_S_is_cons v3).
  destruct H1 as [a [v1' H1]]. destruct H2 as [b [v2' H2]].
  destruct H3 as [c [v3' H3]]. rewrite H1. rewrite H2. rewrite H3.
  apply H0. apply IHn. Qed.

(*****************************************************************************************
                     Qvec_Eq. Rational Equality of Qvecs.
 *****************************************************************************************)
Inductive Qvec_Eq : forall {n : nat},(Qvec n)->(Qvec n)->Prop :=
| QNil : Qvec_Eq (nil Q) (nil Q)
| QCons: forall {n : nat} (v1 v2 : Qvec n) (h1 h2 : Q),
         Qvec_Eq v1 v2 -> h1 == h2 -> Qvec_Eq (cons Q h1 n v1) (cons Q h2 n v2).
Notation "a === b" := (Qvec_Eq a b) (at level 70).

Lemma Qvec_Eq_refl : forall {n : nat} (v : Qvec n),
  v === v.
Proof.
  intros. induction v. apply QNil.
  apply (QCons _ _ _ _ IHv eq_refl). Qed.

Lemma Qvec_Eq_symm : forall {n : nat} (v1 v2 : Qvec n),
  v1 === v2 -> v2 === v1.
Proof.
  intros n v1 v2. set (P := fun {n : nat} (v1 v2 : Qvec n) => v1 === v2 -> v2 === v1).
  change (P n v1 v2). apply mutual_induction; unfold P; clear P; intros.
  apply QNil. inversion H0; subst. apply Eqdep_dec.inj_pair2_eq_dec in H3.
  apply Eqdep_dec.inj_pair2_eq_dec in H6. subst. apply H in H5.
  apply QCons. apply H5. symmetry. apply H7. apply eq_nat_dec. apply eq_nat_dec. Qed.

Lemma Qvec_Eq_trans : forall {n : nat} (v1 v2 v3 : Qvec n),
  v1 === v2 -> v2 === v3 -> v1 === v3.
Proof.
  intros n v1 v2 v3. set (P := fun {n : nat} (v1 v2 v3 : Qvec n) =>
    v1 === v2 -> v2 === v3 -> v1 === v3). change (P n v1 v2 v3).
  apply triple_induction; unfold P; clear P; intros; simpl. apply QNil.
  inversion H0; subst. apply Eqdep_dec.inj_pair2_eq_dec in H4.
  apply Eqdep_dec.inj_pair2_eq_dec in H7. subst. inversion H1; subst.
  apply Eqdep_dec.inj_pair2_eq_dec in H4. apply Eqdep_dec.inj_pair2_eq_dec in H9.
  subst. apply QCons. apply H in H6. apply H6. apply H7.
  apply (Qeq_trans h1 h2 h3 H8 H10). apply eq_nat_dec. apply eq_nat_dec.
  apply eq_nat_dec. apply eq_nat_dec. Qed.

Instance Qvec_Setoid : forall {n : nat},
  Equivalence (Qvec_Eq (n := n)).
Proof.
  intros. split; red. apply Qvec_Eq_refl.
  apply Qvec_Eq_symm. apply Qvec_Eq_trans. Qed.

Theorem Qvec_Eq_dec : forall {n : nat} (v1 v2 : Qvec n),
  {v1 === v2} + {~ v1 === v2}.
Proof.
  intros. induction v1. rewrite (Vector_0_is_nil v2). left. apply QNil.
  assert (H := Vector_S_is_cons' v2). rewrite H. assert (H0 := IHv1 (tl v2)).
  inversion H0. assert (H2 := Qeq_dec h (hd v2)). inversion H2.
  left. apply (QCons _ _ _ _ H1 H3). right. unfold not. intros.
  apply H3. inversion H4. apply H11. right. unfold not. intros.
  apply H1. inversion H2. apply Eqdep_dec.inj_pair2_eq_dec in H5. rewrite <- H5.
  apply Eqdep_dec.inj_pair2_eq_dec in H8. rewrite <- H8. apply H7.
  apply eq_nat_dec. apply eq_nat_dec. Qed.

Theorem Qvec_not_eq_symm : forall {n : nat} (v1 v2 : Qvec n),
  ~ v1 === v2 -> ~ v2 === v1.
Proof.
  intros. unfold not. intros. apply H. apply (Qvec_Eq_symm _ _ H0). Qed.

(***************** Setoid Compatibility Results *****************)
Instance Qvec_plus_comp : forall {n : nat},
  Proper (Qvec_Eq==>Qvec_Eq==>Qvec_Eq) (Qvec_plus (n := n)).
Proof.
  intros. unfold Proper; unfold respectful. induction n; intros.
  rewrite(Vector_0_is_nil x). rewrite (Vector_0_is_nil x0).
  rewrite(Vector_0_is_nil y). rewrite (Vector_0_is_nil y0). reflexivity.
  assert (Hx := Vector_S_is_cons x). assert (Hx0 := Vector_S_is_cons x0).
  assert (Hy := Vector_S_is_cons y). assert (Hy0 := Vector_S_is_cons y0).
  destruct Hx as [hx [x' Hx]]. destruct Hx0 as [hx0 [x0' Hx0]].
  destruct Hy as [hy [y' Hy]]. destruct Hy0 as [hy0 [y0' Hy0]]. subst.
  inversion H0. inversion H. subst. apply Eqdep_dec.inj_pair2_eq_dec in H3.
  apply Eqdep_dec.inj_pair2_eq_dec in H6. apply Eqdep_dec.inj_pair2_eq_dec in H10.
  apply Eqdep_dec.inj_pair2_eq_dec in H13. subst. assert (HH := IHn _ _ H12 _ _ H5).
  simpl. apply QCons. apply HH. rewrite H14. rewrite H7. reflexivity.
  apply eq_nat_dec. apply eq_nat_dec. apply eq_nat_dec. apply eq_nat_dec. Qed.

Lemma fold_left_add_unfold : forall {n : nat} (v1 v2 : Qvec n) (A : Q),
 (fold_left Qplus A (map2 Qmult v1 v2)) == (Qplus A (fold_left Qplus 0 (map2 Qmult v1 v2))).
Proof.
  intros n v1 v2. set (P := fun {n : nat} (v1 v2 : Qvec n) => forall A : Q,
  Qeq (fold_left Qplus A (map2 Qmult v1 v2)) (Qplus A (fold_left Qplus 0 (map2 Qmult v1 v2)))).
  change (P n v1 v2). apply mutual_induction; unfold P; intros; clear P.
  simpl. unfold Qplus; rewrite Qplus_0_r. symmetry. apply Qred_correct.
  simpl. rewrite (H (A + h1 * h2)). rewrite (H (0 + h1*h2)).
  unfold Qplus. rewrite Qplus_0_l. repeat rewrite Qred_correct. rewrite Qplus_assoc.
  reflexivity. Qed.

Instance Qvec_dot_comp : forall {n : nat},
  Proper (Qvec_Eq==>Qvec_Eq==>Qeq) (Qvec_dot (n := n)).
Proof.
  intros. unfold Proper, respectful; intros. induction n.
  rewrite (Vector_0_is_nil x). rewrite (Vector_0_is_nil x0).
  rewrite (Vector_0_is_nil y). rewrite (Vector_0_is_nil y0). reflexivity.
  assert (Hx := Vector_S_is_cons x). assert (Hx0 := Vector_S_is_cons x0).
  assert (Hy := Vector_S_is_cons y). assert (Hy0 := Vector_S_is_cons y0).
  destruct Hx as [hx [x' Hx]]. destruct Hx0 as [hx0 [x0' Hx0]].
  destruct Hy as [hy [y' Hy]]. destruct Hy0 as [hy0 [y0' Hy0]]. subst.
  unfold Qvec_dot. simpl. rewrite fold_left_add_unfold. fold (Qvec_dot x' x0').
  rewrite fold_left_add_unfold. fold (Qvec_dot y' y0'). repeat rewrite Qplus_0_l.
  inversion H0. inversion H. subst. apply Eqdep_dec.inj_pair2_eq_dec in H3.
  apply Eqdep_dec.inj_pair2_eq_dec in H6. apply Eqdep_dec.inj_pair2_eq_dec in H10.
  apply Eqdep_dec.inj_pair2_eq_dec in H13. subst.
  assert (HH := IHn _ _ H12 _ _ H5). rewrite H7. rewrite H14. rewrite HH. reflexivity.
  apply eq_nat_dec. apply eq_nat_dec. apply eq_nat_dec. apply eq_nat_dec. Qed.

Instance Qvec_normsq_comp : forall {n : nat},
  Proper (Qvec_Eq==>Qeq) (Qvec_normsq (n := n)).
Proof.
  intros. unfold Proper, respectful, Qvec_normsq; intros.
  rewrite H. reflexivity. Qed.

Instance Qvec_mult_class_comp : forall {n : nat},
  Proper (eq==>Qvec_Eq==>Qvec_Eq) (Qvec_mult_class (n := n)).
Proof.
  intros. unfold Proper, respectful. intros x y Hxy v1 v2.
  set (P := fun {n : nat} (v1 v2 : Qvec n) => v1 === v2 ->
  Qvec_mult_class x v1 === Qvec_mult_class y v2). change (P n v1 v2). apply mutual_induction;
  unfold P; clear P; intros. rewrite Hxy. reflexivity. rewrite Hxy.
  inversion H0; subst. apply Eqdep_dec.inj_pair2_eq_dec in H3.
  apply Eqdep_dec.inj_pair2_eq_dec in H6. subst. apply H in H5. unfold Qvec_mult_class.
  destruct y. apply H0. simpl. simpl in H5. apply QCons. apply H5. rewrite H7. reflexivity.
  apply eq_nat_dec. apply eq_nat_dec. Qed.

Instance consb_comp : forall {n : nat},
  Proper (Qvec_Eq==>Qvec_Eq) (consb (n := n)).
Proof.
  intros. unfold Proper, respectful; intros. unfold consb.
  apply (QCons _ _ _ _ H eq_refl). Qed.

Instance Qvec_sum_class_comp : forall {n : nat},
  Proper (Qvec_Eq==>eq==>Qvec_Eq) (Qvec_sum_class (n := n)).
Proof.
  intros. unfold Proper, respectful; intros x y Hxy a L HL; subst.
  generalize dependent y. generalize dependent x. induction L; intros.
  simpl. apply Hxy. destruct a as [f l]. simpl.
  assert (H := Qvec_Eq_refl (Qvec_mult_class l (consb f))).
  apply (Qvec_plus_comp x y Hxy) in H. apply (IHL _ _ H). Qed.

Instance min_element_product_comp : forall {n : nat},
  Proper (Qvec_Eq==>eq==>Qeq) (min_element_product (n := n)).
Proof.
  intros. unfold Proper, respectful; intros x y Hxy a L HL; subst.
  generalize dependent y. generalize dependent x. induction L; intros.
  reflexivity. destruct a as [f l]. destruct L. simpl. rewrite Hxy.
  reflexivity. unfold min_element_product. fold (min_element_product y (p :: L)).
  fold (min_element_product x (p :: L)). assert (IHxy := IHL _ _ Hxy).
  repeat rewrite IHxy. repeat rewrite Hxy.
  destruct (Qle_bool (Qvec_dot y (Qvec_mult_class l (consb f))) (min_element_product y (p :: L))).
  rewrite Hxy. reflexivity. apply IHxy. Qed.

Instance Qvec_sum_dot_comp : forall {n : nat},
  Proper (Qvec_Eq==>eq==>Qeq) (Qvec_sum_dot (n := n)).
Proof.
  intros. unfold Proper, respectful; intros x y Hxy a L HL; subst; induction L; intros.
  reflexivity. destruct a as [f l]. simpl. rewrite IHL. rewrite Hxy. reflexivity. Qed.

Instance Qvec_foil_comp : forall {n : nat},
  Proper (Qvec_Eq==>eq==>Qeq) (Qvec_foil (n := n)).
Proof.
  intros. unfold Proper, respectful. intros x y H l L HL; subst. generalize dependent y.
  generalize dependent x. induction L; intros. reflexivity. destruct a as [f l].
  simpl. assert (H0 := Qvec_Eq_refl (Qvec_mult_class l (consb f))).
  apply (Qvec_plus_comp x y H) in H0. apply IHL in H0. rewrite H0.
  rewrite H. reflexivity. Qed.

(****************************************************************************************
    Proofs about Arithmetic on Qvec, Fixpoints/Computations on Qvecs / Training Data.
 ****************************************************************************************)
Lemma Qvec_normsq_nonneg : forall {n : nat} (f : Qvec n),
 0 <= (Qvec_normsq f).
Proof.
  intros. induction f; unfold Qvec_normsq, Qvec_dot. unfold Qle. reflexivity.
  simpl. rewrite fold_left_add_unfold. fold (Qvec_dot f f). fold (Qvec_normsq f).
  unfold Qplus, Qmult; repeat rewrite Qred_correct. rewrite Qplus_0_l.
  apply (Qplus_le_compat 0 _ 0). apply Qsquare_nonneg. apply IHf. Qed.

Lemma Qvec_consb_gt_0 : forall {n : nat} (f : Qvec n),
 Qvec_normsq (consb f) > 0.
Proof.
  intros n f. unfold Qvec_normsq. unfold Qvec_dot. unfold consb. simpl.
  rewrite fold_left_add_unfold. assert (0 + 1 * 1 == 1). unfold Qmult, Qplus;
  rewrite Qred_correct. simpl. apply Qplus_0_l. rewrite H; clear H.
  fold (Qvec_dot f f). fold (Qvec_normsq f). rewrite <- Qplus_0_r.
  unfold Qplus; rewrite Qred_correct. apply (Qplus_lt_le_compat 0 _ 0). reflexivity.
  apply Qvec_normsq_nonneg. Qed.

Lemma Qvec_sum_normsq_nonneg : forall {n : nat} (L : list ((Qvec n)*bool)),
  0 <= (Qvec_sum_normsq L).
Proof.
  intros. induction L. unfold Qle. reflexivity.
  destruct a as [f l]. simpl. assert (H := Qvec_normsq_nonneg (consb f)).
  unfold Qplus; rewrite Qred_correct. apply (Qplus_le_compat 0 _ 0 _ H IHL). Qed.

Lemma Qvec_normsq_Qvec_0 : forall (n : nat),
 Qvec_normsq (Qvec_zero n) == 0.
Proof.
  intros n. induction n; unfold Qvec_zero, Qvec_normsq, Qvec_dot. reflexivity.
  simpl. apply IHn. Qed.

Lemma normsq_mult_neg_1_same : forall {n : nat} (f : Qvec n),
  Qvec_normsq f == Qvec_normsq (map (Qmult (-1#1)) f).
Proof.
  intros. induction f. simpl. reflexivity.
  unfold Qvec_normsq, Qvec_dot. simpl. rewrite fold_left_add_unfold.
  rewrite (fold_left_add_unfold _ _ (0 + _)). fold (Qvec_dot f f). fold (Qvec_normsq f).
  fold (Qvec_dot (map (Qmult (-1#1)) f) (map (Qmult (-1#1)) f)).
  fold (Qvec_normsq (map (Qmult (-1#1)) f)). repeat rewrite Qplus_0_l.
  assert (Qopp 1 = (-1#1)). reflexivity. repeat rewrite <- H.
  unfold Qmult, Qplus; repeat rewrite Qred_correct.
  rewrite <- Qopp_mult_distr_l. repeat rewrite Qmult_1_l.
  rewrite <- Qopp_mult_distr_l. rewrite <- Qopp_mult_distr_r. rewrite Qopp_involutive.
  rewrite IHf. rewrite <- H. reflexivity. Qed.

Lemma Qvec_dot_mult_neg_1 : forall {n:nat} (v1 v2 : Qvec n),
  Qvec_dot v1 (map (Qmult (-1#1)) v2) == Qmult (-1#1) (Qvec_dot v1 v2).
Proof.
  intros n v1 v2. set (P := fun (n : nat) (v1 v2 : t Q n) =>
  Qvec_dot v1 (map (Qmult (-1#1)) v2) == Qmult (-1#1) (Qvec_dot v1 v2)).
  change (P n v1 v2). apply mutual_induction; unfold P; clear P.
  { unfold Qvec_dot, Qmult, Qplus. simpl. reflexivity. }
  intros. unfold Qvec_dot. simpl. rewrite fold_left_add_unfold.
  rewrite (fold_left_add_unfold t1 t2 _). fold (Qvec_dot t1 t2).
  unfold Qplus, Qmult; repeat rewrite Qred_correct. rewrite Qplus_0_l.
  rewrite Qplus_0_l. assert (-1#1 = Qopp 1). reflexivity. rewrite H0.
  rewrite <- Qopp_mult_distr_l. rewrite <- Qopp_mult_distr_r. rewrite Qmult_1_l.
  rewrite <- Qopp_mult_distr_l. rewrite Qmult_1_l. rewrite Qopp_plus.
  rewrite H0 in H. unfold Qmult, Qplus in H. repeat rewrite Qred_correct in H.
  rewrite <- Qopp_mult_distr_l in H. rewrite Qmult_1_l in H.
  rewrite <- H. unfold Qvec_dot. reflexivity. Qed.

Lemma Qvec_dot_add_sub_mult_eq : forall {n : nat} (v1 v2 v3 : Qvec n),
  Qvec_dot v1 v2 == Qminus (Qvec_dot (Qvec_plus v1 v3) v2) (Qvec_dot v3 v2).
Proof.
  intros. set (P := fun {n} (v1 v2 v3 : Qvec n) => Qvec_dot v1 v2 ==
  Qminus (Qvec_dot (Qvec_plus v1 v3) v2) (Qvec_dot v3 v2)). change (P n v1 v2 v3).
  apply triple_induction; unfold P; clear P; intros; unfold Qvec_dot.
  { reflexivity. }
  simpl. rewrite fold_left_add_unfold. fold (Qvec_dot t1 t2).
  unfold Qplus, Qmult; repeat rewrite Qred_correct. rewrite Qplus_0_l.
  rewrite fold_left_add_unfold. fold (Qvec_dot (Qvec_plus t1 t3) t2).
  rewrite Qplus_0_l. rewrite fold_left_add_unfold. fold (Qvec_dot t3 t2).
  rewrite Qplus_0_l. unfold Qminus, Qplus. repeat rewrite Qred_correct.
  rewrite Qopp_plus. rewrite <- Qplus_assoc. rewrite (Qplus_comm (Qopp _) (Qopp _)).
  rewrite (Qplus_assoc (Qvec_dot _ _) (Qopp _) (Qopp _)).
  rewrite (Qplus_comm (_ _ _) (Qopp _)).
  fold (Qminus (Qvec_dot (Qvec_plus t1 t3) t2) (Qvec_dot t3 t2)).
  rewrite <- H. rewrite Qplus_assoc. rewrite Qmult_plus_distr_l.
  repeat rewrite <- Qplus_assoc. rewrite (Qplus_assoc (_ h3 h2) _ _).
  rewrite Qplus_opp_r. rewrite Qplus_0_l. reflexivity. Qed.

Lemma Qvec_normsq_cons : forall {n : nat} (h : Q) (t : Qvec n),
  Qvec_normsq (cons Q h n t) == Qplus (Qmult h h) (Qvec_normsq t).
Proof.
  intros. unfold Qvec_normsq, Qvec_dot. simpl. rewrite fold_left_add_unfold.
  unfold Qplus, Qmult; repeat rewrite Qred_correct. rewrite Qplus_0_l. reflexivity. Qed.

Lemma Qvec_dot_cons : forall {n : nat} (h1 h2 : Q) (t1 t2 : Qvec n),
  Qvec_dot (cons Q h1 n t1) (cons Q h2 n t2) == Qplus (Qmult h1 h2) (Qvec_dot t1 t2).
Proof.
  intros. unfold Qvec_dot. simpl. rewrite fold_left_add_unfold.
  unfold Qplus, Qmult; repeat rewrite Qred_correct. rewrite Qplus_0_l. reflexivity. Qed.

Lemma Qvec_normsq_plus : forall {n: nat} (v1 v2 : Qvec n),
  Qvec_normsq (Qvec_plus v1 v2) == Qplus (Qplus (Qvec_normsq v1) (Qmult (2#1) (Qvec_dot v1 v2))) (Qvec_normsq v2).
Proof.
  intros.  set (P := fun {n} (v1 v2 : Qvec n) => Qvec_normsq (Qvec_plus v1 v2) ==
  Qplus (Qplus (Qvec_normsq v1) (Qmult (2#1) (Qvec_dot v1 v2))) (Qvec_normsq v2)).
  change (P n v1 v2). apply mutual_induction; unfold P; intros. reflexivity.
  unfold Qvec_plus. simpl. repeat rewrite Qvec_normsq_cons. rewrite Qvec_dot_cons.
  fold (Qvec_plus t1 t2). unfold Qplus, Qmult; repeat rewrite Qred_correct.
  rewrite (Qmult_plus_distr_r (2#1)). repeat rewrite <- Qplus_assoc.
  rewrite (Qplus_assoc _  _ (Qvec_normsq t2)). rewrite (Qplus_comm (_ (2#1) (Qvec_dot t1 t2))).
  rewrite (Qplus_assoc (Qvec_normsq t1)). rewrite (Qplus_comm (Qvec_normsq t1) _).
  rewrite <- Qplus_assoc. repeat rewrite (Qplus_assoc (Qvec_normsq t1) _ _).
  rewrite (Qplus_comm (Qvec_normsq t1)). repeat rewrite <- Qplus_assoc.
  rewrite (Qplus_assoc (Qvec_normsq t1) _ _). unfold Qplus, Qmult in H;
  repeat rewrite Qred_correct in H; rewrite <- H. repeat rewrite Qplus_assoc.
  rewrite Qmult_plus_distr_l. repeat rewrite Qmult_plus_distr_r.
  rewrite (Qmult_comm h2 h1). rewrite <- Qplus_diag_eq_mult_2.
  repeat rewrite Qplus_assoc. reflexivity. Qed.

Lemma Qvec_dot_Qvec_zero_l : forall {n : nat} (v : Qvec n),
  Qvec_dot (Qvec_zero n) v == 0.
Proof.
  intros. induction v; unfold Qvec_dot. reflexivity.
  simpl. rewrite fold_left_add_unfold. unfold Qplus, Qmult;
  repeat rewrite Qred_correct; rewrite Qplus_0_l.
  rewrite Qmult_0_l. rewrite Qplus_0_l. apply IHv. Qed.

Lemma Qvec_dot_Qvec_zero_r : forall {n : nat} (v : Qvec n),
  Qvec_dot v (Qvec_zero n) == 0.
Proof.
  intros. induction v; unfold Qvec_dot. reflexivity.
  simpl. rewrite fold_left_add_unfold. unfold Qplus, Qmult;
  repeat rewrite Qred_correct; rewrite Qplus_0_l.
  rewrite Qmult_0_r. rewrite Qplus_0_l. apply IHv. Qed.

Lemma Qvec_plus_Qvec_zero : forall {n : nat} (v : Qvec n),
  Qvec_plus (Qvec_zero n) v === v.
Proof.
  intros. induction v; unfold Qvec_plus. reflexivity.
  simpl. fold (Qvec_zero n). fold (Qvec_plus (Qvec_zero n) v).
  apply QCons. apply IHv. unfold Qplus; rewrite Qred_correct;
  apply Qplus_0_l. Qed.

Lemma Qvec_plus_Qvec_zero_r : forall {n : nat} (v : Qvec n),
  Qvec_plus v (Qvec_zero n) === v.
Proof.
  intros. induction v; unfold Qvec_plus. reflexivity.
  simpl. fold (Qvec_zero n). fold (Qvec_plus v (Qvec_zero n)).
  apply QCons. apply IHv. unfold Qplus; rewrite Qred_correct;
  apply Qplus_0_r. Qed.

Lemma Qvec_dot_dist_l : forall {n : nat} (v1 v2 v3 : Qvec n),
  Qvec_dot (Qvec_plus v1 v2) v3 == Qplus (Qvec_dot v1 v3) (Qvec_dot v2 v3).
Proof.
  intros. set (P := fun {n} (v1 v2 v3 : Qvec n) =>
  Qvec_dot (Qvec_plus v1 v2) v3 == Qplus (Qvec_dot v1 v3) (Qvec_dot v2 v3)).
  change (P n v1 v2 v3). apply triple_induction; unfold P; intros. reflexivity.
  simpl. repeat rewrite Qvec_dot_cons. rewrite H. unfold Qplus, Qmult;
  repeat rewrite Qred_correct; rewrite Qmult_plus_distr_l.
  repeat rewrite <- Qplus_assoc. rewrite (Qplus_assoc (Qvec_dot t1 t3) _ _).
  rewrite (Qplus_comm (Qvec_dot t1 t3) (QArith_base.Qmult h2 h3)).
  repeat rewrite Qplus_assoc. reflexivity. Qed.

Lemma Qvec_dot_dist_r : forall {n : nat} (v1 v2 v3 : Qvec n),
  Qvec_dot v1 (Qvec_plus v2 v3) == Qplus (Qvec_dot v1 v2) (Qvec_dot v1 v3).
Proof.
  intros. set (P := fun {n} (v1 v2 v3 : Qvec n) =>
  Qvec_dot v1 (Qvec_plus v2 v3) == Qplus (Qvec_dot v1 v2) (Qvec_dot v1 v3)).
  change (P n v1 v2 v3). apply triple_induction; unfold P; clear P; intros. reflexivity.
  simpl. repeat rewrite Qvec_dot_cons. rewrite H. unfold Qplus, Qmult; repeat rewrite Qred_correct;
  rewrite Qmult_plus_distr_r. repeat rewrite <- Qplus_assoc.
  rewrite (Qplus_assoc (Qvec_dot t1 t2) _ _). rewrite (Qplus_comm (Qvec_dot t1 t2)
  (QArith_base.Qmult h1 h3)). repeat rewrite Qplus_assoc. reflexivity. Qed.

Lemma Qvec_plus_shuffle : forall {n: nat} (v1 v2 v3 : Qvec n),
  Qvec_plus (Qvec_plus v1 v2) v3 === Qvec_plus (Qvec_plus v1 v3) v2.
Proof.
  intros. set (P := fun n (v1 v2 v3 : Qvec n) =>
  Qvec_plus (Qvec_plus v1 v2) v3 === Qvec_plus (Qvec_plus v1 v3) v2). change (P n v1 v2 v3).
  apply triple_induction; unfold P; clear P; intros; simpl. apply QNil.
  apply QCons. apply H. unfold Qplus; repeat rewrite Qred_correct;
  rewrite <- Qplus_assoc. rewrite (Qplus_comm h2 h3). apply Qplus_assoc. Qed.

Lemma Qvec_plus_comm : forall {n : nat} (v1 v2 : Qvec n),
  Qvec_plus v1 v2 === Qvec_plus v2 v1.
Proof.
  intros. set (P := fun {n : nat} (v1 v2 : Qvec n) => Qvec_plus v1 v2 === Qvec_plus v2 v1).
  change (P n v1 v2). apply mutual_induction; unfold P; clear P; intros; simpl. apply QNil.
  apply QCons. apply H. unfold Qplus. rewrite Qplus_comm. reflexivity. Qed.

Lemma Qvec_foil_w_0 : forall {n : nat} (v1 v2 : Qvec (S n)) (L : list ((Qvec n)*bool)),
  Qplus (Qvec_dot v1 (Qvec_sum L)) (Qvec_foil v2 L) == Qvec_foil (Qvec_plus v2 v1) L.
Proof.
  intros; generalize dependent v1; generalize dependent v2; induction L; intros.
  simpl. rewrite Qvec_dot_Qvec_zero_r. reflexivity. destruct a as [f l].
  unfold Qvec_sum. fold (Qvec_sum L). unfold Qvec_foil.
  fold (Qvec_foil (Qvec_plus v2 (Qvec_mult_class l (consb f)))).
  fold (Qvec_foil (Qvec_plus (Qvec_plus v2 v1) (Qvec_mult_class l (consb f)))).
  rewrite Qvec_dot_dist_r. unfold Qplus; repeat rewrite Qred_correct.
  rewrite Qplus_assoc. assert (forall (A B C D : Q),
  QArith_base.Qplus (QArith_base.Qplus (QArith_base.Qplus A B) C) D ==
  QArith_base.Qplus (QArith_base.Qplus A C) (QArith_base.Qplus B D)). intros.
  repeat rewrite <- Qplus_assoc. rewrite (Qplus_assoc C B D). rewrite (Qplus_comm C B).
  repeat rewrite <- Qplus_assoc. reflexivity.
  rewrite H; clear H. assert (H := IHL (Qvec_plus v2 (Qvec_mult_class l (consb f))) v1).
  unfold Qplus in H; repeat rewrite Qred_correct in H. rewrite H.
  assert (H0 := Qvec_dot_dist_l v1 v2 (Qvec_mult_class l (consb f))).
  unfold Qplus in H0; rewrite Qred_correct in H0. rewrite <- H0.
  rewrite Qvec_plus_shuffle. rewrite Qvec_plus_comm. reflexivity. Qed.

Lemma Qvec_dot_sum_eq : forall {n : nat} (w : Qvec (S n)) (L : list ((Qvec n)*bool)),
  Qvec_dot w (Qvec_sum L) == Qvec_sum_dot w L.
Proof.
  intros. induction L. simpl.
  rewrite Qvec_dot_Qvec_zero_r. apply Qeq_refl.
  destruct a as [f l].
  simpl. rewrite Qvec_dot_dist_r. rewrite IHL. reflexivity. Qed.

Lemma Qvec_foil_0_w : forall {n : nat} (v1 v2 : Qvec (S n)) (L : list ((Qvec n)*bool)),
  Qvec_foil v1 L == Qminus (Qvec_foil (Qvec_plus v1 v2) L) (Qvec_sum_dot v2 L).
Proof.
  intros. assert (H := Qvec_foil_w_0 v2 v1 L). rewrite <- (Qplus_inj_r _ _ (Qvec_sum_dot v2 L)).
  unfold Qminus. rewrite <- Qplus_assoc. rewrite (Qplus_comm (Qopp _) _). rewrite Qplus_opp_r.
  rewrite Qplus_0_r. rewrite <- H. rewrite Qvec_dot_sum_eq. unfold Qplus; rewrite Qred_correct.
  apply Qplus_comm. Qed.

Lemma Qvec_normsq_eq_sum_normsq_foil : forall {n: nat} (L : list ((Qvec n)*bool)),
  Qvec_normsq (Qvec_sum L) == Qplus (Qvec_sum_normsq L) (Qmult (2#1) (Qvec_foil (Qvec_zero (S n)) L)).
Proof.
  intros. induction L. simpl. unfold Qplus, Qmult; rewrite Qred_correct.
  rewrite Qmult_0_r. rewrite Qplus_0_l. apply Qvec_normsq_Qvec_0.
  destruct a as [f l]. unfold Qvec_normsq, Qvec_sum. fold (Qvec_sum L).
  unfold Qvec_sum_normsq. fold (Qvec_sum_normsq L). unfold Qvec_foil.
  fold (Qvec_foil (Qvec_plus (Qvec_zero (S n)) (Qvec_mult_class l (consb f))) L).
  fold (Qvec_normsq (Qvec_plus (Qvec_mult_class l (consb f)) (Qvec_sum L))).
  rewrite Qvec_normsq_plus. assert (Qvec_normsq (Qvec_mult_class l (consb f)) == Qvec_normsq (consb f)).
  destruct l. reflexivity. unfold Qvec_mult_class. rewrite <- normsq_mult_neg_1_same. reflexivity.
  rewrite H; clear H. rewrite IHL. unfold Qplus, Qmult; repeat rewrite Qred_correct.
  rewrite <- Qplus_assoc. rewrite (Qplus_assoc (QArith_base.Qmult (2#1) _) (Qvec_sum_normsq L) _).
  rewrite (Qplus_comm (QArith_base.Qmult (2#1) _) (Qvec_sum_normsq L)). repeat rewrite <- Qplus_assoc.
  rewrite Qvec_dot_Qvec_zero_l. repeat rewrite Qplus_0_l. rewrite <- Qmult_plus_distr_r.
  assert (H := Qvec_foil_w_0 (Qvec_mult_class l (consb f)) (Qvec_zero (S n)) L).
  unfold Qplus in H; rewrite Qred_correct in H. rewrite H. reflexivity. Qed.

Lemma Qvec_plus_assoc : forall {n : nat} (v1 v2 v3 : Qvec n),
  Qvec_plus (Qvec_plus v1 v2) v3 === Qvec_plus v1 (Qvec_plus v2 v3).
Proof.
  intros. set (P := fun n (v1 v2 v3 : Qvec n) =>
  Qvec_plus (Qvec_plus v1 v2) v3 === Qvec_plus v1 (Qvec_plus v2 v3)). change (P n v1 v2 v3).
  apply triple_induction; unfold P; clear P; intros. reflexivity.
  simpl. apply QCons. apply H. symmetry. unfold Qplus; repeat rewrite Qred_correct;
  apply Qplus_assoc. Qed.

Lemma Qvec_foil_append : forall {n : nat} (L1 L2 : list ((Qvec n)*bool)) (v : Qvec (S n)),
  Qvec_foil v (List.app L1 L2) == Qplus (Qvec_foil v L1) (Qvec_foil (Qvec_plus v (Qvec_sum L1)) L2).
Proof.
  intros n L1. induction L1; intros. simpl. rewrite Qvec_plus_Qvec_zero_r. symmetry.
  unfold Qplus; rewrite Qplus_0_l; apply Qred_correct.
  destruct a as [f l]. simpl. rewrite IHL1. rewrite Qvec_plus_assoc.
  unfold Qplus; repeat rewrite Qred_correct; rewrite Qplus_assoc. reflexivity. Qed.

Lemma Qvec_sum_sum_class : forall {n : nat} (w : Qvec (S n)) (L : list ((Qvec n)*bool)),
  Qvec_plus w (Qvec_sum L) === Qvec_sum_class w L.
Proof.
  intros. generalize dependent w; induction L; intros. simpl.
  rewrite Qvec_plus_Qvec_zero_r. apply Qvec_Eq_refl.
  destruct a as [f l]. simpl. rewrite <- Qvec_plus_assoc. apply IHL. Qed.

Lemma Qvec_sum_class_append : forall {n : nat} (w0: Qvec (S n)) (M1 M2: (list ((Qvec n)*bool))),
  Qvec_sum_class (Qvec_sum_class w0 M1) M2 = Qvec_sum_class w0 (List.app M1 M2).
Proof.
  intros n w0 M1. generalize dependent w0. induction M1; intros.
  { reflexivity. } destruct a as [f l]. simpl. apply IHM1. Qed.

Lemma Qvec_dot_comm : forall {n : nat} (v1 v2 : Qvec n),
  Qvec_dot v1 v2 == Qvec_dot v2 v1.
Proof.
  intros. set (P := fun n (v1 v2 : Qvec n) => Qvec_dot v1 v2 == Qvec_dot v2 v1).
  change (P n v1 v2). apply mutual_induction; unfold P; clear P; intros. reflexivity.
  repeat (rewrite Zvec_dot_cons). repeat rewrite Qvec_dot_cons. rewrite H.
  unfold Qmult; rewrite Qmult_comm. reflexivity. Qed.

Lemma Qvec_dot_Not_Qvec_zero : forall {n : nat} (v1 v2 : Qvec n),
  (~ Qvec_dot v1 v2 == 0) -> (~ v1 === Qvec_zero n) /\ (~ v2 === Qvec_zero n).
Proof.
  intros. split. unfold not; intros. apply H. rewrite H0. apply Qvec_dot_Qvec_zero_l.
  unfold not; intros. apply H. rewrite H0. apply Qvec_dot_Qvec_zero_r. Qed.

Lemma Qvec_cons_Not_Qvec_zero : forall {n : nat} (v1 : Qvec n) (h : Q),
  (~ cons Q h n v1 === Qvec_zero (S n)) -> (~ h == 0) \/ (~ v1 === Qvec_zero n).
Proof.
  intros n v1; induction v1; intros. unfold Qvec_zero in H. simpl in H. left. unfold not.
  intros. apply H. apply (QCons _ _ _ _ QNil H0). assert (H0 := Qeq_dec h0 0). destruct H0.
  { right. unfold not. intros. apply H. unfold Qvec_zero, const. fold (const 0 (S n)).
  fold (Qvec_zero (S n)). apply QCons. apply H0. apply q. } left. apply n0. Qed.

Lemma Qvec_normsq_Not_Qvec_Zero : forall {n : nat} (v1 : Qvec n),
  (~ v1 === Qvec_zero n) -> Qvec_normsq v1 > 0.
Proof.
  intros. induction v1. exfalso. apply H. reflexivity.
  apply Qvec_cons_Not_Qvec_zero in H. inversion H. apply Qsquare_gt_0 in H0.
  unfold Qvec_normsq. rewrite Qvec_dot_cons. fold (Qvec_normsq v1).
  unfold Qplus, Qmult; repeat rewrite Qred_correct. rewrite <- Qplus_0_r.
  apply (Qplus_lt_le_compat 0 _ 0 _ H0). apply Qvec_normsq_nonneg.
  apply IHv1 in H0. unfold Qvec_normsq. rewrite Qvec_dot_cons.
  fold (Qvec_normsq v1). unfold Qplus, Qmult; repeat rewrite Qred_correct.
  rewrite Qplus_comm. apply (Qplus_lt_le_compat 0 _ 0 _ H0 (Qsquare_nonneg _)). Qed.

Lemma Qvec_sum_dot_append : forall {n : nat} (L1 L2 : list ((Qvec n)*bool)) (w : Qvec (S n)),
  Qvec_sum_dot w (List.app L1 L2) == Qplus (Qvec_sum_dot w L1) (Qvec_sum_dot w L2).
Proof.
  intros n L1; induction L1; intros. simpl. symmetry. unfold Qplus;
  rewrite Qplus_0_l; apply Qred_correct.
  destruct a as [f l]. simpl. rewrite IHL1. unfold Qplus; repeat rewrite Qred_correct.
  repeat (rewrite Qplus_assoc). reflexivity. Qed.

Lemma Qfoil : forall (A B C D : Q),
 (A + B) * (C + D) == (A * C) + (A * D) + (B * C) + (B * D).
Proof.
  intros. unfold Qplus, Qmult; repeat rewrite Qred_correct.
  rewrite Qmult_plus_distr_l. repeat (rewrite Qmult_plus_distr_r).
  apply Qplus_assoc. Qed.

Lemma CSHH : forall (A B : Q),
  (A * B) + (A * B) <= (A * A) + (B * B).
Proof.
  intros. assert ((A - B) * (A - B) == (QArith_base.Qplus (A * A) (B * B)) - (QArith_base.Qplus (A * B) (A * B))).
  unfold Qminus. assert (H := Qfoil A (Qopp B) A (Qopp B)).
  unfold Qplus in H; repeat rewrite Qred_correct in H. rewrite H. unfold Qmult; repeat rewrite Qred_correct.
  repeat rewrite <- Qopp_mult_distr_r. repeat rewrite <- Qopp_mult_distr_l.
  rewrite Qopp_involutive. repeat rewrite <- Qplus_assoc.
  rewrite (Qplus_comm _ (_ B B)). rewrite (Qplus_assoc _ (_ B B) _). rewrite (Qplus_comm _ (_ B B)).
  repeat rewrite <- Qplus_assoc. rewrite <- Qopp_plus. rewrite (Qmult_comm B A). reflexivity.
  assert (0 <= (A - B) * (A - B)). unfold Qmult; rewrite Qred_correct. apply Qsquare_nonneg.
  rewrite H in H0. apply (Qplus_le_l _ _ (A * B + A * B)) in H0. rewrite Qplus_0_l in H0.
  unfold Qminus in H0. rewrite <- Qplus_assoc in H0.
  rewrite (Qplus_comm _ (_ (A*B) (A*B))) in H0.
  unfold Qplus in H0 at 2. rewrite Qred_correct in H0. rewrite Qplus_opp_r in H0.
  rewrite Qplus_0_r in H0. unfold Qplus at 2. rewrite Qred_correct. apply H0. Qed.

(* This is trivialy true if the parity of negatives is odd *)
Lemma Cauchy_Schwarz_helper': forall (A B C D : Q),
  A*B*C*D + A*B*C*D <= A*A*D*D + B*B*C*C.
Proof.
  intros. assert (forall (A B C D : Q), A*B*C*D == A*D*(B*C)). intros.
  unfold Qplus, Qmult; repeat rewrite Qred_correct.
  rewrite (Qmult_comm B0 C0). rewrite <- Qmult_assoc. rewrite <- Qmult_assoc.
  rewrite (Qmult_comm B0 (_ C0 D0)). rewrite Qmult_assoc. rewrite (Qmult_comm C0 D0).
  repeat rewrite Qmult_assoc. reflexivity. repeat rewrite H. apply CSHH. Qed.

Lemma Cauchy_Schwarz_helper : forall {n : nat} (v1 v2 : Qvec n) (A B : Q),
  A*B*(Qvec_dot v1 v2) + A*B*(Qvec_dot v1 v2) <= A*A*(Qvec_normsq v2) + B*B*(Qvec_normsq v1).
Proof.
  intros n v1 v2. set (P := fun n (v1 v2 : Qvec n) => forall (A B : Q),
  A*B*(Qvec_dot v1 v2) + A*B*(Qvec_dot v1 v2) <= A*A*(Qvec_normsq v2) + B*B*(Qvec_normsq v1)).
  change (P n v1 v2). apply mutual_induction; unfold P; clear P; intros.
  unfold Qvec_normsq, Qvec_dot; simpl. unfold Qmult; repeat rewrite Qred_correct.
  repeat rewrite Qmult_0_r. apply Qle_refl. repeat (rewrite Qvec_dot_cons). repeat (rewrite Qvec_normsq_cons).
  unfold Qplus, Qmult; repeat rewrite Qred_correct.
  repeat (rewrite Qmult_plus_distr_r). repeat (rewrite Qplus_assoc). repeat (rewrite Qmult_assoc).
  assert (forall (A B C D : Q), (QArith_base.Qplus (QArith_base.Qplus (QArith_base.Qplus A B) C) D) ==
  (QArith_base.Qplus (QArith_base.Qplus A C) (QArith_base.Qplus B D))). intros.
  repeat rewrite <- Qplus_assoc. rewrite (Qplus_assoc B0 C D). rewrite (Qplus_comm B0 C).
  rewrite <- Qplus_assoc. reflexivity. unfold Qplus in H0. repeat rewrite H0; clear H0.
  assert (H0 := Cauchy_Schwarz_helper' A B h1 h2). apply Qplus_le_compat.
  unfold Qplus, Qmult in H0; repeat rewrite Qred_correct in H0; apply H0.
  assert (H1 := H A B). unfold Qplus, Qmult in H1; repeat rewrite Qred_correct in H1; apply H1. Qed.

Lemma Cauchy_Schwarz_inequality : forall {n : nat} (v1 v2 : Qvec n),
  (Qvec_dot v1 v2)*(Qvec_dot v1 v2) <= (Qvec_normsq v1)*(Qvec_normsq v2).
Proof.
  intros. set (P := fun n (v1 v2 : Qvec n) =>
  (Qvec_dot v1 v2)*(Qvec_dot v1 v2) <= (Qvec_normsq v1)*(Qvec_normsq v2)). change (P n v1 v2).
  apply mutual_induction; unfold P; clear P; intros. apply Qle_refl.
  repeat (rewrite Qvec_dot_cons). repeat (rewrite Qvec_normsq_cons). repeat (rewrite Qfoil).
  unfold Qplus, Qmult; repeat rewrite Qred_correct.
  rewrite <- Qmult_assoc. rewrite (Qmult_comm h2 (QArith_base.Qmult h1 h2)). repeat rewrite Qmult_assoc.
  repeat rewrite <- Qplus_assoc. apply Qplus_le_r.
  repeat rewrite Qplus_assoc. apply Qplus_le_compat.
  { repeat rewrite <- Qmult_assoc. rewrite (Qmult_comm _ (QArith_base.Qmult h1 h2)).
    rewrite (Qmult_comm _ (QArith_base.Qmult h2 h2)). repeat rewrite Qmult_assoc.
    assert (H0 := Cauchy_Schwarz_helper t1 t2 h1 h2). unfold Qplus, Qmult in H0;
    repeat rewrite Qred_correct in H0. apply H0.
  } unfold Qmult in H; repeat rewrite Qred_correct in H; apply H. Qed.


Require Import Coq.Relations.Relation_Operators.
Require Import Relation_Operators.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Wellfounded.Lexicographic_Product.
Require Import Coq.Classes.RelationClasses.
Require Import Omega.

Definition compose A (R S : relation A) : relation A :=
  fun x y => exists z, R x z /\ S z y.
(*Heavily based on the Lex proofs from the CoLoR library. The main difference is that I need the
  first relation to be on the second type in the tuple because of the order of the arguments in the
  Haskell functions*)
Section Lex.
  Variables (A B : Type) (ltA eqA : relation A) (ltB : relation B).
  Inductive lex : relation (B * A) :=
  | lex1 a a' b b' : ltA a a' -> lex (b,a) (b',a')
  | lex2 a a' b b' : eqA a a' -> ltB b b' -> lex (b,a) (b',a').
  Variables (WF_gtA : well_founded ltA) (WF_gtB : well_founded ltB)
    (eqA_trans : Transitive eqA) (Hcomp : forall x y : A, (exists z : A, eqA y z /\ ltA x z) -> ltA x y)
    (eqA_sym: Symmetric eqA).

   Lemma lex_Acc_eq : forall a b,
    Acc lex (b,a) -> forall a', eqA a a' -> Acc lex (b,a').

  Proof.
    intros a b SN_ab a' eqaa'. inversion SN_ab. apply Acc_intro.
    destruct y as (a'',b'). intro H'.
    inversion H'; subst a'0 b'0 a0 b0; apply H.
    apply lex1. apply Hcomp. exists a'. auto.
    apply lex2. assert (eqA a' b'). eapply eqA_sym. assumption.
    pose proof (eqA_trans _ _ _ eqaa' H0). apply eqA_sym. assumption. assumption.
  Qed.

  Lemma lex_Acc :
    forall a, Acc ltA a -> forall b, Acc ltB b -> Acc lex (b, a).

  Proof.
    induction 1 as [a Ha1 Ha2]. induction 1 as [b Hb1 Hb2]. apply Acc_intro.
    destruct y as (a'',b'). intro H. inversion H. subst a'' b'0. subst a0. subst a'. (* subst a'' b'0 a0 b0.*)
    (* gtA a a' *)
    apply Ha2. exact H1. apply WF_gtB.
    (* eqA a a' /\ gtB b b' *)
    apply (@lex_Acc_eq a).
    apply Hb2. assumption. apply eqA_sym. assumption.
  Qed.

  Lemma WF_lex : well_founded lex.

  Proof.
    unfold well_founded. destruct a as (a,b). apply lex_Acc. apply WF_gtA. apply WF_gtB.
  Qed.

End Lex.

Definition f_nat_lt {a} (f: a -> nat) x y := f x < f y.

Lemma f_nat_lt_acc: forall {a} (f: a -> nat) x n, f x <= n -> Acc (f_nat_lt f) x.
Proof.
  intros. generalize dependent x. induction n; auto.
  - intros. apply Acc_intro. intros. unfold f_nat_lt in *. omega.
  - unfold f_nat_lt in *. intros. apply Acc_intro. intros. apply IHn. omega.
Qed.

Lemma f_nat_lt_wf: forall {a} (f: a -> nat), well_founded (f_nat_lt f).
Proof.
  red. intro. intro. intro. eapply f_nat_lt_acc. eauto.
Qed.


From Coq Require Import
     Arith
     Lia
     List.

From ExtLib Require Import
     Monad
     Traversable
     Data.List.

From ITree Require Import
     ITree
     ITreeFacts
     Basics.Basics
     Basics.Category
     Basics.CategoryKleisli
     Basics.CategoryKleisliFacts.

Import Basics.Basics.Monads.
Import ListNotations.
Import ITreeNotations.
Local Open Scope itree_scope.

Section SYNTAX.

  Inductive typ :=
  | Base
  | Arr (s:typ) (t:typ).

  Variable V : typ -> Type.  (* PHOAS variables *)
  Inductive tm : typ -> Type :=
  | Lit (n:nat) : tm Base
  | Var : forall (t:typ), V t -> tm t
  | App : forall t1 t2 (m1 : tm (Arr t1 t2)) (m2 : tm t1), tm t2
  | Lam : forall t1 t2 (body : V t1 -> tm t2), tm (Arr t1 t2)
  | Opr : forall (m1 : tm Base) (m2 : tm Base), tm Base
  .

  Fixpoint open_tm (G : list typ) (u:typ) : Type :=
    match G with
    | [] => tm u
    | t::ts =>  V t -> (open_tm ts u)
    end.

End SYNTAX.

Definition Term (G : list typ) (u:typ) := forall (V : typ -> Type), open_tm V G u.

Arguments Lit {V}.
Arguments Var {V t}.
Arguments App {V t1 t2}.
Arguments Lam {V t1 t2}.
Arguments Opr {V}.

Section DENOTATION.
  Fixpoint denote_typ E (t:typ) : Type :=
    match t with
    | Base => nat
    | Arr s t => (denote_typ E s) -> itree E (denote_typ E t)
    end.

  Fixpoint denotation_tm_typ E (V:typ -> Type) (G : list typ) (u:typ) :=
    match G with
    | [] => itree E (V u)
    | t::ts => (V t) -> denotation_tm_typ E V ts u
    end.

  Fixpoint denote_closed_term {E} {u:typ} (m : tm (denote_typ E) u) : itree E (denote_typ E u) :=
    match m with
    | Lit n => Ret n
    | Var x => Ret x
    | App m1 m2 => f <- (denote_closed_term m1) ;;
                  x <- (denote_closed_term m2) ;;
                  ans <- f x ;;
                  ret ans
    | Lam body => ret (fun x => denote_closed_term (body x))
    | Opr m1 m2 => x <- (denote_closed_term m1) ;;
                  y <- (denote_closed_term m2) ;;
                  Ret (x + y)
    end.

  Program Fixpoint denote_rec
          (V:typ -> Type) E
          (base : forall u (m : tm V u), itree E (V u))
          (G: list typ) (u:typ) (m : open_tm V G u) : denotation_tm_typ E V G u :=
    match G with
    | [] => base u _
    | t::ts => fun (x : V t) => denote_rec V E base ts u _
    end.
  Next Obligation.
    simpl in m.
    exact m.
  Defined.
  Next Obligation.
    unfold Term in m.
    simpl in m.
    apply m in x.
    exact x.
  Defined.

  Program Definition denote E (G : list typ) (u:typ) (m : Term G u)
    : denotation_tm_typ E (denote_typ E) G u :=
    denote_rec (denote_typ E) E (@denote_closed_term E) G u _.
  Next Obligation.
    unfold Term in m.
    specialize (m (denote_typ E)).
    exact m.
  Defined.

End DENOTATION.

Definition id_tm : Term [] (Arr Base Base) :=
  fun V => Lam (fun x => Var x).

Definition example : Term [] Base :=
  fun V => App (id_tm V) (Lit 3).

Lemma example_equiv E : (denote E [] Base example) ≈ Ret 3.
Proof.
  cbn.
  repeat rewrite bind_ret_l.
  reflexivity.
Qed.

Definition twice : Term [] (Arr (Arr Base Base) (Arr Base Base)) :=
  fun V => Lam (fun f => Lam (fun x => App (Var f) (App (Var f) (Var x)))).

Definition example2 : Term [] Base :=
  fun V => App (App (twice V) (id_tm V)) (Lit 3).

Lemma big_example_equiv E : (denote E [] Base example2) ≈ Ret 3.
Proof.
  cbn.
  repeat rewrite bind_ret_l.
  reflexivity.
Qed.

Definition add_2_tm : Term [] (Arr Base Base) :=
  fun V => Lam (fun x => (Opr (Var x) (Lit 2))).

Definition example3 : Term [] Base :=
  fun V => App (App (twice V) (add_2_tm V)) (Lit 3).

Lemma big_example2_equiv E : (denote E [] Base example3) ≈ Ret 7.
Proof.
  cbn.
  repeat rewrite bind_ret_l.
  reflexivity.
Qed.


Require Import HOASLib.
Require Import Composition.

Definition cnot10 (n : nat) : Box ((S (S n) ⨂ Qubit)%qc) ((S (S n) ⨂ Qubit)%qc) :=
  box_ (tar,(ct,u)) ⇒ let_ (ct,tar) ← CNOT $ (ct,tar); (tar,(ct,u)).

Open Scope matrix_scope.

Fixpoint nket (n : nat) (st : Matrix 2 1) : Matrix (2^n) 1 :=
  match n with
  | 0 => I 1
  | S n' => st ⊗ (nket n' st)
  end.

Definition ghz_ket (n : nat) : Matrix (2^(S n)) 1 :=
  1/ √2 .* (nket (S n) qubit0) .+ 1/ √2 .* nket (S n) qubit1.

Definition ghz_state (n : nat) : Density (2^(S n)) :=
  outer_product (ghz_ket n) (ghz_ket n).

Require Import Symmetric.
Open Scope circ_scope.

Fixpoint ghz (n : nat) : Box ((S n) ⨂ One)%qc ((S n) ⨂ Qubit)%qc :=
  match n with
  | 0 => box_ (q,u) ⇒ let_ q ← _H $ init0 $ q; let_ u ← (); (q,u)
  | S n' => (init0 ∥ ghz n') ;; (cnot10 n')
  end.

Lemma typed_cnot10 :
  forall n : nat, Typed_Box (cnot10 n).
Proof.
  induction n; simpl; type_check.
Qed.

Lemma typed_ghz :
  forall n : nat, Typed_Box (ghz n).
Proof.
  induction n; simpl.
  - type_check.
  - assert (Typed_Box(cnot10 n)). apply typed_cnot10.
    type_check.
Qed.

Lemma wf_nket :
  forall (n : nat)(st : (Matrix 2 1)), WF_Matrix st -> WF_Matrix (nket n st).
Proof.
  intros. induction n.
  - simpl. apply WF_I1.
  - simpl. apply WF_kron.
    + rewrite <- plus_n_O. lia.
    + lia.
    + assumption.
    + assumption.
Qed.

Require Import Denotation.
Open Scope matrix_scope.

(* TODO: Move to Matrix.v *)
Definition notc : Matrix 4 4 :=
  fun x y => match x, y with
          | 0, 0 => C1
          | 1, 3 => C1
          | 2, 2 => C1
          | 3, 1 => C1
          | _, _ => C0
          end.

Lemma wf_notc : WF_Matrix notc.
Proof. show_wf. Qed.

Lemma wf_ghz :
  forall n : nat, WF_Matrix (ghz_state n).
Proof.
  intro.
  unfold ghz_state.
  apply WF_outer_product.
  all : unfold ghz_ket;
    apply WF_plus; apply WF_scale; apply wf_nket;
      try apply WF_qubit0; try apply WF_qubit1.
Qed.

#[export] Hint Resolve wf_ghz wf_nket wf_notc : wf_db.

Lemma ctrl_list_notc :
  forall n : nat,
    ctrl_list_to_unitary_r (repeat false n ++ [true]) σx = notc ⊗ I (2 ^ n).
Proof.
  induction n.
  - simpl.
    rewrite kron_1_r.
    solve_matrix.
  - simpl. rewrite IHn.
    assert (I (2 ^ n) ⊗ I 2 = I (2 ^ n + (2 ^ n + 0))).
    { rewrite id_kron. rewrite <- plus_n_O.
      replace (2^n*2)%nat with (2^n+2^n)%nat. reflexivity. lia. }
    rewrite <- H.
    assert ((length (repeat false n ++ [true])) = (S n)).
    { rewrite app_length. simpl. rewrite repeat_length. lia. }
    rewrite H0.
    rewrite Nat.add_1_r. repeat rewrite <- plus_n_O.
    replace (2^S(S n)+2^S (S n))%nat with (4*(2^n)*2)%nat.
    replace (2^n+2^n)%nat with ((2^n)*2)%nat.
    rewrite <- kron_assoc by auto with wf_db.
    reflexivity.
    lia.
    unify_pows_two.
Qed.

Local Close Scope C_scope.
Local Close Scope R_scope.
Lemma cnot10_correct :
  forall n ρ, WF_Matrix ρ ->
    ⟦cnot10 n⟧ ρ = (notc ⊗ (I (2^n))) × ρ × (notc ⊗ (I (2^n)))†.
Proof.
  intros.
  induction n.
  - matrix_denote.
    simpl in *.
    Msimpl.
    solve_matrix.
  - matrix_denote.
    rewrite add_fresh_split.
    simpl.
    matrix_denote.
    rewrite add_fresh_split. simpl.
    repeat rewrite subst_var_no_gaps.
    simpl.
    unify_pows_two.
    rewrite rev_repeat.
    rewrite size_ntensor. simpl.
    rewrite Nat.mul_1_r.
    rewrite subst_pat_fresh.
    rewrite swap_fresh_seq.
    simpl.
    rewrite size_ntensor. simpl.
    rewrite Nat.mul_1_r.
    repeat rewrite -> Nat.add_1_r.
    assert(E : forall i j, i > j -> (map (fun z : nat * nat => if match snd z with
                                                | 0 => true
                                                | S _ => false
                                      end then (fst z, j)%core else z) (combine (seq i n) (seq i n))) =
               (combine (seq i n) (seq i n))).
    clear. induction n. simpl. reflexivity. simpl.
    intros. simpl. rewrite IHn by lia. destruct i; try lia. reflexivity.
    rewrite E by lia. clear E.
    assert(E : forall i, i > 1 -> (map (fun z : nat * nat => if match snd z with
                                                | 1 => true
                                                | _ => false
                                      end then (fst z, 1)%core else z) (combine (seq i n) (seq i n))) =
               (combine (seq i n) (seq i n))).
    clear. induction n. simpl. reflexivity. simpl.
    intros. simpl. rewrite IHn by lia. destruct i as [|[|]]; try lia. reflexivity.
    rewrite E by lia. clear E.
    assert(E : forall i, i > 2 -> (map (fun z : nat * nat => if match snd z with
                                                | 2 => true
                                                | _ => false
                                      end then (fst z, 2)%core else z) (combine (seq i n) (seq i n))) =
               (combine (seq i n) (seq i n))).
    clear. induction n. simpl. reflexivity. simpl.
    intros. simpl. rewrite IHn by lia. destruct i as [|[|[|]]]; try lia. reflexivity.
    rewrite E by lia. clear E.

    assert ((2 ^ S (S (S n)))%nat=(4 * 2 ^ S n)%nat). unify_pows_two.
    assert ([false] = (repeat false 1)) by auto.

    repeat rewrite Mmult_1_r. repeat rewrite Mmult_1_l. Msimpl.
    rewrite swap_list_aux_id.
    replace (n+2) with (S (S n)) by lia.
    rewrite Nat.sub_diag. rewrite id_kron. rewrite mult_1_r. rewrite Mmult_1_l.
    rewrite id_adjoint_eq. rewrite Mmult_1_r.

    rewrite H1. rewrite repeat_combine.
    replace (n+1) with (S n) by lia.
    replace (2^S (S (S n))) with (4*2^S n) by unify_pows_two. rewrite ctrl_list_notc. reflexivity.

    rewrite H0. apply WF_mult. apply WF_mult.
    rewrite H1. rewrite repeat_combine.
    replace (n+1) with (S n) by lia. rewrite ctrl_list_notc. apply WF_kron.
    auto.  auto. show_wf. apply WF_I.
    assumption.

    rewrite H1. rewrite repeat_combine.
    replace (n+1) with (S n) by lia. rewrite ctrl_list_notc.
    apply WF_adjoint. apply WF_kron. auto. auto.
    show_wf. apply WF_I.

    rewrite H0. apply WF_mult. apply WF_mult.
    rewrite H1. rewrite repeat_combine.
    replace (n+1) with (S n) by lia. rewrite ctrl_list_notc.
    apply WF_kron.
    auto. auto. show_wf. apply WF_I.
    assumption.

    rewrite H1. rewrite repeat_combine.
    replace (n+1) with (S n) by lia.
    rewrite ctrl_list_notc.
    apply WF_adjoint.
    apply WF_kron.
    auto. auto.
    show_wf.
    apply WF_I.

    all : try (rewrite swap_list_aux_id; apply WF_I).

    repeat constructor.
    rewrite fresh_state_ntensor.
    rewrite app_length. simpl.
    repeat apply lt_n_S. apply Nat.lt_0_succ.

    apply add_fresh_state_no_gaps.
    repeat constructor.
    rewrite fresh_state_ntensor.
    rewrite app_length. simpl.
    repeat apply lt_n_S. apply Nat.lt_0_succ.

    apply add_fresh_state_no_gaps.
    repeat constructor.

    rewrite fresh_state_ntensor.
    rewrite app_length.
    simpl. apply Nat.lt_0_succ.

    apply add_fresh_state_no_gaps.
    repeat constructor.
Qed.

Lemma Mmult_outer_product :
  forall (n : nat)  (k : (Matrix n 1)) (M : Matrix n n),
    M × (outer_product k k) × M† = outer_product (M × k) (M × k).
Proof.
  intros.
  unfold outer_product.
  rewrite Mmult_adjoint.
  repeat rewrite Mmult_assoc. reflexivity.
Qed.

Lemma kron_product :
  forall (m n : nat) (a : (Matrix m 1))(b : (Matrix n 1)),
    (outer_product a a) ⊗ (outer_product b b) = outer_product (a ⊗ b) (a ⊗ b).
Proof.
  intros. unfold outer_product.
  rewrite <- kron_mixed_product.
  rewrite <- kron_adjoint. reflexivity.
Qed.

Lemma outer_eq :
  forall (n : nat)(a b : Matrix n 1),
    a = b -> outer_product a a = outer_product b b.
Proof.
  intros. rewrite H. reflexivity.
Qed.

Lemma Mplus_eq :
  forall (m n: nat)(a1 b1 a2 b2 : Matrix m n),
    a1 = a2 -> b1 = b2 -> a1 .+ b1 = a2 .+ b2.
Proof.
  intros. rewrite H. rewrite H0. reflexivity.
Qed.

Lemma Mscale_eq :
  forall (m n: nat)(c : C) (u v : (Matrix m n)),
    u = v -> c .* u = c .* v.
Proof.
  intros. rewrite H. reflexivity.
Qed.

Lemma kron_eq :
  forall (m n: nat)(u1 u2 : (Matrix m 1))(v1 v2 : (Matrix n 1)),
    u1=u2 -> v1=v2 -> u1⊗v1=u2⊗v2.
Proof.
  intros. rewrite H. rewrite H0. reflexivity.
Qed.

Local Open Scope C_scope.
Local Open Scope R_scope.
Theorem ghz_correct :
  forall n : nat, ⟦ghz n⟧ (I 1) = ghz_state n.
Proof.
  induction n as [| n' IHn'].
  - matrix_denote. Msimpl.
    unfold ghz_state, outer_product, ghz_ket.
    solve_matrix.
  - simpl.
    rewrite inSeq_correct.
    + assert ((I 1) = (I (2^⟦One⟧)) ⊗ (I (2^⟦((S n') ⨂ One)%qc⟧))).
      { Msimpl. rewrite size_ntensor. rewrite Nat.mul_0_r. reflexivity. }
      unfold compose_super.
      assert (⟦init0⟧ (I 1) = ∣0⟩⟨0∣).
      { simpl. Msimpl. solve_matrix. }
      assert (denote_box true (init0 ∥ ghz n') (I 1) = (denote_box true init0 (I (2^⟦One⟧))) ⊗ (denote_box true (ghz n') (I (2^⟦((S n') ⨂ One)%qc⟧)))).
      {
        rewrite -> H.
        apply inPar_correct.
        type_check.
        apply typed_ghz.
        simpl. apply WF_I1.
        replace (2^⟦(S n' ⨂ One)%qc⟧)%nat with 1%nat by (simpl; rewrite -> size_ntensor; rewrite Nat.mul_0_r; auto).
        apply WF_I1.
      }
      simpl in H1. rewrite -> H1.
      assert (denote_box true init0 (I 1) = ∣0⟩⟨0∣).
      { matrix_denote. solve_matrix. }
      rewrite H2. simpl in IHn'.
      repeat rewrite -> size_ntensor. rewrite Nat.mul_0_r. simpl. rewrite IHn'.
      assert (⟦cnot10 n'⟧ (∣0⟩⟨0∣ ⊗ ghz_state n') = (notc ⊗ (I (2^n'))) × (∣0⟩⟨0∣ ⊗ ghz_state n') × (notc ⊗ (I (2^n')))† ).
      { apply cnot10_correct. apply WF_kron.
        simpl. repeat rewrite <- plus_n_O. repeat rewrite plus_assoc. reflexivity.
        simpl. repeat rewrite <- plus_n_O. rewrite plus_assoc. reflexivity.
        apply WF_braqubit0. apply wf_ghz.
         }
      simpl in H3. simpl.
      assert ((size_wtype (n' ⨂ Qubit)%qc)=n').
      { rewrite size_ntensor. simpl.  lia. }
      simpl in H3. rewrite Nat.mul_1_r. simpl. rewrite -> H3.
      unfold ghz_state, ghz_ket.
      replace (∣0⟩⟨0∣) with (outer_product ∣0⟩ ∣0⟩) by (simpl; reflexivity).
      rewrite -> kron_product.
      replace ((2 * 2 ^ S n'))%nat with (4 * 2^n')%nat in * by (simpl; lia).
      rewrite -> Mmult_outer_product.
      rewrite kron_plus_distr_l.
      simpl in *.
      replace (2 ^ n' + (2 ^ n' + (2 ^ n' + (2 ^ n' + 0))))%nat with
          (2 ^ n' + (2 ^ n' + 0) + (2 ^ n' + (2 ^ n' + 0) + 0))%nat by (repeat rewrite <- plus_n_O; repeat rewrite plus_assoc; reflexivity).
      rewrite Mmult_plus_distr_l.
      apply outer_eq.
      apply Mplus_eq.
      *
        remember (nket n' ∣0⟩) as nk0.
        assert ( (∣0⟩ ⊗ (1%R / √ 2 .* (∣0⟩ ⊗ nk0))) = 1%R / √ 2 .* (∣0⟩ ⊗ ((∣0⟩ ⊗ nk0)))).
        { rewrite -> Mscale_kron_dist_r. reflexivity. }
        simpl in H5. rewrite -> H5.
        (* simpl. *)
        assert ((∣0⟩ ⊗ (∣0⟩ ⊗ nk0)) = (∣0⟩ ⊗ ∣0⟩) ⊗ nk0).
        { rewrite -> kron_assoc; subst; auto with wf_db. }
        simpl in H6. rewrite -> H6.
        rewrite -> Mscale_mult_dist_r.
        apply Mscale_eq.
        assert (notc ⊗ I (2 ^ n') × (∣0⟩ ⊗ ∣0⟩ ⊗ nk0) = (notc × (∣0⟩⊗∣0⟩)) ⊗ ((I (2^n')) × nk0)).
        { rewrite -> kron_mixed_product. reflexivity. }
        simpl in H7. repeat rewrite <- plus_n_O in H7.
        repeat rewrite <- plus_n_O.
        replace (2 ^ n' + 2 ^ n' + (2 ^ n' + 2 ^ n'))%nat with (2 ^ n' + (2 ^ n' + (2 ^ n' + 2 ^ n')))%nat by (repeat rewrite plus_assoc; reflexivity).
        rewrite -> H7.
        apply kron_eq.
        solve_matrix.
        rewrite Mmult_1_l. reflexivity.
        rewrite Heqnk0. apply wf_nket.
        apply WF_qubit0.
      *
        remember (nket n' ∣1⟩) as nk1.
        assert ( (∣0⟩ ⊗ (1%R / √ 2 .* (∣1⟩ ⊗ nk1))) = 1%R / √ 2 .* (∣0⟩ ⊗ ((∣1⟩ ⊗ nk1)))).
        { rewrite -> Mscale_kron_dist_r. reflexivity. }
        simpl in H5. rewrite -> H5.
        assert ((∣0⟩ ⊗ (∣1⟩ ⊗ nk1)) = (∣0⟩ ⊗ ∣1⟩) ⊗ nk1).
        { rewrite -> kron_assoc; subst; auto with wf_db. }
        simpl in H6. rewrite -> H6.
        rewrite Mscale_mult_dist_r.
        apply Mscale_eq.
        assert (notc ⊗ I (2 ^ n') × (∣0⟩ ⊗ ∣1⟩ ⊗ nk1) = (notc × (∣0⟩⊗∣1⟩)) ⊗ ((I (2^n')) × nk1)).
        { rewrite -> kron_mixed_product. reflexivity. }
        simpl in H7.
        repeat rewrite <- plus_n_O in H7.
        repeat rewrite <- plus_n_O.
        replace (2 ^ n' + 2 ^ n' + (2 ^ n' + 2 ^ n'))%nat with (2 ^ n' + (2 ^ n' + (2 ^ n' + 2 ^ n')))%nat by (repeat rewrite plus_assoc; reflexivity).
        rewrite -> H7.
        assert ((∣1⟩ ⊗ (∣1⟩ ⊗ nk1)) = (∣1⟩ ⊗ ∣1⟩) ⊗ nk1).
        { rewrite -> kron_assoc; subst; auto with wf_db. }
        replace (1 * 1)%nat with 1%nat in H8 by lia.
        replace (2^n'+2^n')%nat with (2*2^n')%nat by lia.
        rewrite -> H8.
        apply kron_eq.
        solve_matrix.
        rewrite Mmult_1_l. reflexivity.
        rewrite Heqnk1. apply wf_nket.
        apply WF_qubit1.
    + apply typed_cnot10.
    + apply inPar_WT. type_check. apply typed_ghz.
Qed.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.

Local Open Scope Z_scope.
Module Z2Nat.
  Definition inj_nonpos n : n <= 0 -> Z.to_nat n = 0%nat.
  Proof.
    destruct n; try reflexivity; lia.
  Qed.
End Z2Nat.

Module Z.
  Lemma pos_pow_nat_pos : forall x n,
    Z.pos x ^ Z.of_nat n > 0.
  Proof. intros; apply Z.lt_gt, Z.pow_pos_nonneg; lia. Qed.

  Lemma pow_Z2N_Zpow : forall a n, 0 <= a ->
                                   ((Z.to_nat a) ^ n = Z.to_nat (a ^ Z.of_nat n)%Z)%nat.
  Proof.
    intros a n H; induction n as [|n IHn]; try reflexivity.
    rewrite Nat2Z.inj_succ.
    rewrite Nat.pow_succ_r by apply le_0_n.
    rewrite Z.pow_succ_r by apply Zle_0_nat.
    rewrite IHn.
    rewrite Z2Nat.inj_mul; auto using Z.pow_nonneg.
  Qed.

  Lemma pow_Zpow : forall a n : nat, Z.of_nat (a ^ n) = Z.of_nat a ^ Z.of_nat n.
  Proof with auto using Zle_0_nat, Z.pow_nonneg.
    intros; apply Z2Nat.inj...
    rewrite <- pow_Z2N_Zpow, !Nat2Z.id...
  Qed.
  Hint Rewrite pow_Zpow : push_Zof_nat.
  Hint Rewrite <- pow_Zpow : pull_Zof_nat.

  Lemma Zpow_sub_1_nat_pow a v
    : (Z.pos a^Z.of_nat v - 1 = Z.of_nat (Z.to_nat (Z.pos a)^v - 1))%Z.
  Proof.
    rewrite <- (Z2Nat.id (Z.pos a)) at 1 by lia.
    change 2%Z with (Z.of_nat 2); change 1%Z with (Z.of_nat 1);
      autorewrite with pull_Zof_nat.
    rewrite Nat2Z.inj_sub
      by (change 1%nat with (Z.to_nat (Z.pos a)^0)%nat; apply Nat.pow_le_mono_r; simpl; lia).
    reflexivity.
  Qed.
  Hint Rewrite Zpow_sub_1_nat_pow : pull_Zof_nat.
  Hint Rewrite <- Zpow_sub_1_nat_pow : push_Zof_nat.
End Z.


Require Import set.
Require Import equiv.
Require Import equiv_symmetric.
Require Import equiv_transitive.

(* obvious consequence of transitivity and symmetry *)
Proposition equiv_compatible: forall (a a' b b':set),
  equiv a a' -> equiv b b' -> equiv a b -> equiv a' b'.
Proof.
  intros a a' b b' Haa' Hbb' Hab.
  apply equiv_transitive with (b:= b).
  apply equiv_transitive with (b:= a).
  apply equiv_symmetric. exact Haa'. exact Hab. exact Hbb'.
Qed.


Require Import Basics.
Require Import Types.
Require Import HSet.
Require Import Algebra.Group.

Local Open Scope mc_mult_scope.
Generalizable Variables G H A B C N f g.

(** * Subgroups *)

(** The property of being a subgroup *)
Class IsSubgroup (G H : Group) := {
  issubgroup_incl :> GroupHomomorphism G H;
  isinj_issubgroup_incl :> IsInjective issubgroup_incl;
}.

(* Subgroup inclusion is an embedding. *)
Global Instance isembedding_issubgroup_incl `{!IsSubgroup G H}
  : IsEmbedding (@issubgroup_incl G H _).
Proof.
  apply isembedding_isinj_hset.
  apply isinj_issubgroup_incl.
Defined.

Definition issig_issubgroup G H : _ <~> IsSubgroup G H
  := ltac:(issig).

(** A subgroup of a group H is a group G which is a subgroup of H. *)
Class Subgroup (H : Group) := {
  subgroup_group :> Group;
  subgroup_issubgroup :> IsSubgroup subgroup_group H;
}.

Coercion subgroup_group : Subgroup >-> Group.

Section Cosets.

  (** Left and right cosets give equivalence relations. *)

  Context {G : Group} `{!IsSubgroup H G}.

  (* The relation of being in a left coset represented by an element. *)
  Definition in_cosetL : Relation G.
  Proof.
    intros x y.
    refine (hfiber issubgroup_incl _).
    exact (-x * y).
  Defined.

  (* The relation of being in a right coset represented by an element. *)
  Definition in_cosetR : Relation G.
  Proof.
    intros x y.
    refine (hfiber issubgroup_incl _).
    exact (x * -y).
  Defined.

  (* These are props *)

  Global Instance ishprop_in_cosetL : is_mere_relation G in_cosetL.
  Proof.
    exact _.
  Defined.

  Global Instance ishprop_in_cosetR : is_mere_relation G in_cosetR.
  Proof.
    exact _.
  Defined.

  (* Infact they are both equivalence relations. *)

  Global Instance reflexive_in_cosetL : Reflexive in_cosetL.
  Proof.
    intro x; hnf.
    exists mon_unit.
    refine (_ @ _).
    2: apply symmetry, left_inverse.
    apply grp_homo_unit.
  Defined.

  Global Instance reflexive_in_cosetR : Reflexive in_cosetR.
  Proof.
    intro x; hnf.
    exists mon_unit.
    refine (_ @ _).
    2: apply symmetry, right_inverse.
    apply grp_homo_unit.
  Defined.

  Global Instance symmetric_in_cosetL : Symmetric in_cosetL.
  Proof.
    intros x y [h p]; hnf.
    exists (-h).
    refine (_ @ _).
    1: apply grp_homo_inv.
    apply moveR_equiv_M.
    refine (p @ _).
    symmetry.
    refine (negate_sg_op _ _ @ _).
    refine (ap (-x *.) _).
    apply negate_involutive.
  Defined.

  Global Instance symmetric_in_cosetR : Symmetric in_cosetR.
  Proof.
    intros x y [h p]; hnf.
    exists (-h).
    refine (_ @ _).
    1: apply grp_homo_inv.
    apply moveR_equiv_M.
    refine (p @ _).
    symmetry.
    refine (negate_sg_op _ _ @ _).
    refine (ap (fun x => x *  -y) _).
    apply negate_involutive.
  Defined.

  Global Instance transitive_in_cosetL : Transitive in_cosetL.
  Proof.
    intros x y z [h p] [h' q].
    exists (h * h').
    refine (grp_homo_op _ _ _ @ _).
    destruct p^, q^.
    rewrite <- simple_associativity.
    apply ap.
    rewrite simple_associativity.
    refine (ap (fun x => x *  -z) _ @ _).
    1: apply right_inverse.
    apply left_identity.
  Defined.

  Global Instance transitive_in_cosetR : Transitive in_cosetR.
  Proof.
    intros x y z [h p] [h' q].
    exists (h * h').
    refine (grp_homo_op _ _ _ @ _).
    destruct p^, q^.
    rewrite <- simple_associativity.
    apply ap.
    rewrite simple_associativity.
    refine (ap (fun x => x *  -z) _ @ _).
    1: apply left_inverse.
    apply left_identity.
  Defined.

End Cosets.

(** Identities related to the left and right cosets. *)

Definition in_cosetL_unit {G : Group} `{!IsSubgroup N G}
  : forall x y, in_cosetL (-x * y) mon_unit <~> in_cosetL x y.
Proof.
  intros x y.
  unfold in_cosetL.
  rewrite negate_sg_op.
  rewrite negate_involutive.
  rewrite (right_identity (-y * x)).
  change (in_cosetL y x <~> in_cosetL x y).
  serapply equiv_iff_hprop;
  by intro; symmetry.
Defined.

Definition in_cosetR_unit {G : Group} `{!IsSubgroup N G}
  : forall x y, in_cosetR (x * -y) mon_unit <~> in_cosetR x y.
Proof.
  intros x y.
  unfold in_cosetR.
  rewrite negate_mon_unit.
  rewrite (right_identity (x * -y)).
  reflexivity.
Defined.

(** Symmetry is an equivalence. *)
Definition equiv_in_cosetL_symm {G : Group} `{!IsSubgroup N G}
  : forall x y, in_cosetL x y <~> in_cosetL y x.
Proof.
  intros x y.
  serapply equiv_iff_hprop.
  all: by intro.
Defined.

Definition equiv_in_cosetR_symm {G : Group} `{!IsSubgroup N G}
  : forall x y, in_cosetR x y <~> in_cosetR y x.
Proof.
  intros x y.
  serapply equiv_iff_hprop.
  all: by intro.
Defined.

(* A subgroup is normal if being in a left coset is equivalent to being in a right coset represented by the same element. *)
Class IsNormalSubgroup {G : Group} (N : Subgroup G) := {
  isnormal {x y} : in_cosetL x y <~> in_cosetR x y;
}.

(* Inverses are then respected *)
Definition in_cosetL_inv {G : Group} `{!IsNormalSubgroup N}
  : forall x y, in_cosetL (-x) (-y) <~> in_cosetL x y.
Proof.
  intros x y.
  refine (_ oE (in_cosetL_unit _ _)^-1).
  refine (_ oE isnormal).
  refine (_ oE in_cosetR_unit _ _).
  refine (_ oE isnormal^-1).
  by rewrite negate_involutive.
Defined.

Definition in_cosetR_inv {G : Group} `{!IsNormalSubgroup N}
  : forall x y, in_cosetR (-x) (-y) <~> in_cosetR x y.
Proof.
  intros x y.
  refine (_ oE (in_cosetR_unit _ _)^-1).
  refine (_ oE isnormal^-1).
  refine (_ oE in_cosetL_unit _ _).
  refine (_ oE isnormal).
  by rewrite negate_involutive.
Defined.

(* There is always another element of the normal subgroup allowing us to commute with an element of the group. *)
Definition normal_subgroup_swap {G : Group}
  `{!IsNormalSubgroup N} (x : G) (h : N)
  : exists h' : N, x * issubgroup_incl h = issubgroup_incl h' * x.
Proof.
  assert (X : in_cosetL x (x * issubgroup_incl h)).
  { exists h.
    rewrite simple_associativity.
    rewrite left_inverse.
    symmetry.
    apply left_identity. }
  apply isnormal in X.
  destruct X as [a p].
  rewrite negate_sg_op in p.
  rewrite simple_associativity in p.
  eexists (-a).
  symmetry.
  rewrite grp_homo_inv.
  apply (moveR_equiv_M (f := (- _ *.))).
  cbn; rewrite negate_involutive.
  rewrite simple_associativity.
  apply (moveL_equiv_M (f := (fun x => x * _))).
  apply (moveL_equiv_M (f := (fun x => x * _))).
  symmetry.
  assumption.
Defined.

(* This let's us prove that left and right coset relations are congruences. *)
Definition in_cosetL_cong {G : Group} `{!IsNormalSubgroup N}
  : forall x x' y y', in_cosetL x y -> in_cosetL x' y' -> in_cosetL (x * x') (y * y').
Proof.
  intros x x' y y' [a p] [b q].
  eexists ?[c].
  rewrite negate_sg_op.
  rewrite <- simple_associativity.
  rewrite (simple_associativity (-x) y).
  rewrite <- p.
  rewrite simple_associativity.
  rewrite (normal_subgroup_swap _ a).2.
  rewrite <- simple_associativity.
  rewrite <- q.
  apply grp_homo_op.
Defined.

Definition in_cosetR_cong {G : Group} `{!IsNormalSubgroup N}
  : forall x x' y y', in_cosetR x y -> in_cosetR x' y' -> in_cosetR (x * x') (y * y').
Proof.
  intros x x' y y' [a p] [b q].
  eexists ?[c].
  rewrite negate_sg_op.
  rewrite <- simple_associativity.
  rewrite (simple_associativity x' (-y')).
  rewrite <- q.
  rewrite simple_associativity.
  rewrite (normal_subgroup_swap _ b).2.
  rewrite <- simple_associativity.
  rewrite <- p.
  apply grp_homo_op.
Defined.


From Undecidability.Shared.Libs.PSL Require Import FinTypes.

Fixpoint position {X : eqType} (x : X) (l : list X) : option (Fin.t (length l)).
Proof.
  induction l.
  - exact None.
  - cbn. decide (a = x).
    + exact (Some Fin.F1).
    + destruct (position _ x l) as [res | ].
      * exact (Some (Fin.FS res)).
      * exact None.
Defined.

Lemma position_in {X : eqType} (x : X) (l : list X) (H : x el l) :
  { i | position x l = Some i}.
Proof.
    induction l; cbn in *.
    - inv H.
    - decide (a = x).
        + eauto.
        + destruct IHl as [i IH]. firstorder. rewrite IH. eauto.
Defined.

Definition posIn {X : eqType} (x : X) (l : list X) (H : x el l) : Fin.t (length l).
Proof.
    eapply position_in in H. destruct (position x l) as [i | ]. exact i.
    abstract (exfalso; firstorder congruence).
Defined.

Fixpoint getat {X : Type} (l : list X) (i : Fin.t (length l)) : X.
Proof.
    destruct l.
    - inv i.
    - cbn in i. eapply (Fin.caseS' i (fun _ => X)).
      + exact x.
      + eapply getat.
Defined.

Arguments getat {_} _ _.

Lemma getatIn {X : Type} (l : list X) (i : Fin.t (length l)) :
    getat l i el l.
Proof.
    induction l.
    - inv i.
    - cbn in *. eapply (Fin.caseS' i); cbn. eauto. eauto.
Qed.

Lemma getat_position {X : eqType} (x : X) l (H : x el l) :
getat l (proj1_sig (position_in H)) = x.
Proof.
destruct (position_in H) as [i H1]. cbn.
induction l; cbn in *.
+ inv H1.
+ decide (a = x).
  * inv H1. cbn. reflexivity.
  * destruct (position x l) eqn:E; inv H1.
    cbn. eapply IHl. firstorder. reflexivity.
Qed.

Lemma finite_n (F : finType) :
    { n & {f : F -> Fin.t n & { g : Fin.t n -> F | (forall i, f (g i) = i) /\ forall x, g (f x) = x }}}.
Proof.
    destruct F as (X & [l H]). cbn in *.
    exists (length l).
    assert (Hin : forall x, x el l). { intros x. eapply count_in_equiv. rewrite H. lia. }
    exists (fun x => proj1_sig (position_in (Hin x))). exists (@getat _ l). split.
    - intros i. destruct position_in. cbn.
      specialize (H (getat l i)). clear - H e.
      induction l.
      + inv x.
      + cbn in *. revert H e.
        eapply (Fin.caseS' i). cbn.
        * decide (a = a); congruence.
        * cbn. intros. decide (getat l p = a).
         -- decide (a = getat l p); try congruence. subst. inv e. inv H.
            eapply countZero in H1 as []. eapply getatIn.
         -- decide (a = getat l p); try congruence.
            destruct position eqn:E; inv e. eapply IHl in E; congruence.
    - intros. eapply getat_position.
Qed.


Require Import Utf8.

Section Noniterability_of_induction.

Definition till (n : nat) (P : nat → Prop) := ∀ k, k<n → P k.
Definition prime (P : nat → Prop) (n : nat) := till n P → P n.
Definition univ (P: nat → Prop) := ∀ n, P n.
Notation "P '" := (prime P) (at level 1).

Print "<". Print "≤".
(* We see that ≤ is in fact basic relation in Coq's system
   (least reflexive S-closed on the right)
   and then < is defined from ≤ adding another S on the left.

   For this induction we need the von Neumann's order (∈)
   so we have to prove the equivalence of that with Coq's
   definitions: first for ≤, and then for <. *)

Theorem less_equal: ∀ m n, m ≤ S n → m ≤ n ∨ m = S n.
Proof.
  intros m n hyp. inversion hyp as [eql|n' less' n'j].
  - right. reflexivity.
  - left. assumption.
Qed.

Theorem less_succ: ∀ m n, m < S n → m < n ∨ m = n.
Proof.
  unfold "<". intros m n hyp. apply less_equal in hyp.
  destruct hyp as [first|second].
  - left. assumption.
  - right. injection second as [=eql]. assumption.
Qed.

Theorem strong_induction: ∀ P, univ P ' → univ P.
Proof.
  unfold univ. intros P hyp n. apply hyp.
  induction n as [|n IH].
  - unfold till. intros k contra. inversion contra.
  - unfold till. intros k less.
    apply less_succ in less as [less|eql].
    * apply IH. assumption.
    * subst. apply hyp. assumption.
Qed.

Theorem Šika1: ∀ P n, P ' ' n ↔ P ' n.
Proof.
  intros P n. split.
  - intros hyp till_n. apply hyp.
    + intros k less till_k. apply till_n. assumption.
    + assumption.
  - intros hyp till_n' till_n. apply hyp. assumption.
Qed.

End Noniterability_of_induction.

Section Geometry_Converses.

Variable (S : Set) (F G : S → Prop).

Definition exist (F : S → Prop) := ∃ x, F x.
Definition unique (G : S → Prop) := ∀ x y, G x ∧ G y → x = y.

Theorem Šika2: (∀ x, F x → G x) ∧ exist F ∧ unique G →
                   ∀ x, F x ↔ G x.
(* If every F is a G, and there are ≥1 Fs, and there are ≤1 Gs,
   then every G is an F too.
   In fact we can generalize 1→n, although it becomes even more
   convoluted to express that using just logic:
   if F ⇒ G and #F ≥ n ≥ #G, then F ⇔ G.
   But ONLY FOR FINITE n: if F ⇒ G and #F ≥ ℵ₀ ≥ #G
   then not necessarily F ⇔ G.
   (Hilbert's hotel: for example, F x :⇔ x > 2, G x :⇔ x > 1) *)
Proof.
  intros (onedirection & least1F & most1G) x. split.
  - apply onedirection.
  - intros Gx. destruct least1F as (x0 & Fx0).
    replace x with x0.
    + assumption.
    + apply most1G. split.
      * apply onedirection. assumption.
      * assumption.
Qed.
(* The whole mystery comes solely from the clumsiness of
   first order logic to express counting quantifiers. *)

End Geometry_Converses.

(* Require Import Classical_Prop. *)

Section Equality_Characterization.

Variable X : Set.

Definition reflexive (J : X → X → Prop) := ∀ x, J x x.
(* Leibniz property can be expressed relationally or functionally
   - but they aren't equivalent, and don't give the same results!
   (maybe codomain of f could be differently set up, or maybe J
   itself could be expressed functionally, but I don't know how. *)
Definition fLeibniz (J : X → X → Prop) :=
  ∀ (x y : X) (f : X → X), J x y → J (f x) (f y).
Definition rLeibniz (J : X → X → Prop) :=
  ∀ (x y : X) (P : X → Prop), J x y → P x → P y.
Definition RL (J : X → X → Prop) := reflexive J ∧ rLeibniz J.
Definition trueEquality (x y : X) := x = y.

Example rlj: RL trueEquality.
Proof. split.
  - intros x. reflexivity.
  - intros x y f xy. unfold trueEquality in xy.
    subst. intros hyp. assumption.
Qed.

Example flj: fLeibniz trueEquality.
Proof.
  intros x y f xy. unfold trueEquality in xy. subst. reflexivity. Qed.

Proposition characterization: ∀ J, (RL J ↔ ∀ x y, J x y ↔ x = y).
                    (* only extensionally: we can't say J = (=)! *)
Proof.
  intros J. split; intros hyp.
  - destruct hyp as (rj & lj). intros x y. split; intros xy.
    + apply lj with x.
      * assumption.
      * reflexivity.
    + subst. apply rj.
  - split.
    + intros x. apply hyp. reflexivity.
    + intros x y P Jxy Px. apply hyp in Jxy. subst. assumption.
Qed.
(* But the characterization doesn't hold for functional Leibniz
   property. If X has at least 2 elements and J is universal,
   it's obviously reflexive and fLeibniz, but it's not equality. *)

End Equality_Characterization.

Section Equivalence_Calculus.

(* Šika proposes using ≡ as a base for defining propositional
   logic, later adding ∨ to get a positive fragment and
   yet later adding ¬ to get the whole thing. Axioms:

   Associativity of ≡ (so parentheses aren't needed:)
   Commutativity of ≡: x≡y≡y≡x
   Associativity of ∨
   Commutativity of ∨
   Idempotence of ∨
   Distributivity of ∨ over ≡

   Half-distributivity of ¬ over ≡: ¬(x≡y)≡x≡¬y
    => DNE ¬¬x≡x
   Tertium non datur: x∨¬x
*)

Variable (B: Set) (ekviv: B → B → B).
Notation "x ≡ y" := (ekviv x y) (left associativity, at level 90).
Definition true x := x = (x ≡ x). Coercion true : B >-> Sortclass.
(* That means we can assert elements of B as propositions,
   and proving x actually means proving "true x" (x = (x ≡ x)). *)

Axiom eA: ∀ x y z, (x ≡ y ≡ z) ≡ (x ≡ (y ≡ z)).
Axiom eS: ∀ x y, x ≡ y ≡ y ≡ x.

Lemma ejj: ∀ x y, x ≡ y ↔ x = y.
Proof.
  apply characterization. split.
  - intros x. unfold true. (* now what? *) admit.
  - intros x y P xy px. (* even more hopeless *) admit.
Admitted.

(* One minor problem with defining t as y≡y: we must first have y.
   Bigger problem: To be able to rewrite using ≡, we must first
   have fLeibniz property (with respect to itself). However, this
   only follows from associativity _if_ you already can rewrite
   ("remove parentheses"). It is circular after all. :-( *)

Definition associative {X: Set} (op: X → X → X) := ∀ x y z,
  op x (op y z) = op (op x y) z.

Proposition eAj: associative ekviv.
Proof. intros x y z. symmetry. apply ejj. apply eA. Qed.

Proposition yyl1: ∀ x y, x ≡ ((y ≡ y) ≡ x).
Proof. intros x y. rewrite 2 eAj. apply eS. Qed.

Section Properties_Operation_Relation.

Variable (X: Set) (op: X → X → X).
Notation "x ○ y" := (op x y) (at level 65).
Definition R x y := x ○ y = y.
Notation "x # y" := (R x y) (at level 75).

Definition idempotent := ∀ x, x ○ x = x.
Proposition i2r: idempotent ↔ reflexive X R.
Proof. split; intros hyp x; apply hyp. Qed.

Definition absorbent t := ∀ x, x ○ t = t.
Definition maximal t := ∀ x, x # t.
Proposition a2m: ∀ t, absorbent t ↔ maximal t.
Proof. split; intros hyp x; apply hyp. Qed.

Definition transitive := ∀ x y z, x # y → y # z → x # z.
Proposition as2tr: associative op → transitive.
Proof.
  intros assoc x y z xy yz. unfold "#" in *.
  rewrite <- yz, assoc, xy. reflexivity.
Qed.
(* Converse doesn't hold here: on {t,f}, define x○y:=¬y.
   Then # is empty (x○y is never y) so trivially transitive,
   but t○(t○t)=t○f=t and (t○t)○t=f○t=f, so ○ is not associative. *)

(* Also: if ○ is commutative, then # is antisymmetric.
   The converse doesn't hold; same counterexample. *)

(* Also, what distributes through ○, is monotone with respect to #.
   Again, the same counterexample (with ∧ as additional operation)
   shows that converse doesn't hold. *)

End Properties_Operation_Relation.

(* The mystery of quasidistributivity *)
(* ---------------------------------- *)

(* ∨ distributes over ≡, but ∧ doesn't.
   There is a "quasidistributivity": ∧ distributes over ternary ≡!
   Of course, then ∨ also distributes over ternary ≡ (which is
   not surprising, since ternary ≡ is invariant to t↔f switch *)

(* | x  y     | is a square with "even parity".      | x  x∧y |
   | z  x≡y≡z |                                 Also | y  x∨y | *)

(* However, why does ∨ behave even better?
   Of course, if we want symmetry swapping ∨ and ∧, we also have
   to switch t↔f, and then binary ≡ becomes ⊻ (xor), but
   ternary ≡ is preserved (see squares above)

(* In | x y | there is an odd number of t and even number of f
      | x≡y |   so we can't just swap them: we get x⊻y below *)

(* And truly, ∧ distributes over ⊻: x∧(y⊻z) ≡ x∧y ⊻ x∧z.
   But ≡ can be used for rewriting, since it's transitive!
   Well, what does transitive mean? (x≡y)∧(y≡z)→(x≡z)
   Dually, we get a contrapositive: (x⊻y)∨(y⊻z)←(x⊻z) which holds.

And there is also a reason for extra-good property:
in Z2 (a ring of two elements, even and odd numbers)
* if we interpret t as even (0), and f as odd (1),
  then ⊻ is addition (mod 2),
  and ∧ is multiplication (mod 2 but irrelevant)
  - so this is distributivity of multiplication over addition!
    (this is well known, but the dual interpretation maybe isn't:)
* if we interpret t as odd (1), and f as even (0),
  then ≡ is addition (mod 2),
  and ∨ is multiplication (mod 2 but irrelevant)
  - so this is again distributivity of times over plus! :-)
I think it solves the mystery. *)

(* Šika: which axioms should be used for ≡ & ∧ ?
  Yes, quasidistributivity, probably, but with ∧ there is another
  natural choice for an axiom (that we don't have with ∨, again
  since t is favored over f): x ∧ t ≡ x. I think it doesn't follow
  from anything else, and it (at least a bit) restores the
  "disadvantage" that ∧ has over ∨ regarding distributivity. *)

(* ≡ and ∨ formalize exactly the positive fragment.
   Normal forms: ≡-chains of very elementary disjunctions
   (no negations, no repetition, order doesn't matter)
   So with x and y we have ≡-chains of: x y x∨y, which are
   (again, no repetition, order doesn't matter)
   x    y    x∨y    x≡y    x≡x∨y    y≡x∨y    x≡y≡x∨y
                             x←y       x→y       x∧y            *)
(* Does tertium non datur follow from other axioms? No! → Python *)

(* The simplest forms are (with ∨ as head) x∨¬x
   and (with ≡ as head) x∨f≡x. They cannot be simplified further.
   A 4-value countermodel shows it is not a consequence.
   (Just for humoristic value, there is a 2-value model, where
   ≡ and ∨ are interpreted as ordinary equivalence and disjunction
   while ¬ is interpreted as identity (!). It satisfies all the
   axioms except TND. *)


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Tactics.CompareToSgn.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Hints.ZArith.
Require Import Crypto.Util.ZUtil.Hints.PullPush.
Require Import Crypto.Util.ZUtil.ZSimplify.Core.
Local Open Scope Z_scope.

Module Z.
  Lemma div_mul' : forall a b : Z, b <> 0 -> (b * a) / b = a.
  Proof. intros. rewrite Z.mul_comm. apply Z.div_mul; auto. Qed.
  Hint Rewrite div_mul' using zutil_arith : zsimplify.

  Local Ltac replace_to_const c :=
    repeat match goal with
           | [ H : ?x = ?x |- _ ] => clear H
           | [ H : ?x = c, H' : context[?x] |- _ ] => rewrite H in H'
           | [ H : c = ?x, H' : context[?x] |- _ ] => rewrite <- H in H'
           | [ H : ?x = c |- context[?x] ] => rewrite H
           | [ H : c = ?x |- context[?x] ] => rewrite <- H
           end.

  Lemma lt_div_0 n m : n / m < 0 <-> ((n < 0 < m \/ m < 0 < n) /\ 0 < -(n / m)).
  Proof.
    Z.compare_to_sgn; rewrite Z.sgn_opp; simpl.
    pose proof (Zdiv_sgn n m) as H.
    pose proof (Z.sgn_spec (n / m)) as H'.
    repeat first [ progress intuition auto
                 | progress simpl in *
                 | congruence
                 | lia
                 | progress replace_to_const (-1)
                 | progress replace_to_const 0
                 | progress replace_to_const 1
                 | match goal with
                   | [ x : Z |- _ ] => destruct x
                   end ].
  Qed.

  Lemma div_add' a b c : c <> 0 -> (a + c * b) / c = a / c + b.
  Proof. intro; rewrite <- Z.div_add, (Z.mul_comm c); try lia. Qed.

  Lemma div_add_l' a b c : b <> 0 -> (b * a + c) / b = a + c / b.
  Proof. intro; rewrite <- Z.div_add_l, (Z.mul_comm b); lia. Qed.

  Hint Rewrite div_add_l' div_add' using zutil_arith : zsimplify.

  Lemma div_sub a b c : c <> 0 -> (a - b * c) / c = a / c - b.
  Proof. intros; rewrite <- !Z.add_opp_r, <- Z.div_add by lia; apply f_equal2; lia. Qed.

  Lemma div_sub' a b c : c <> 0 -> (a - c * b) / c = a / c - b.
  Proof. intro; rewrite <- div_sub, (Z.mul_comm c); try lia. Qed.

  Hint Rewrite div_sub div_sub' using zutil_arith : zsimplify.

  Lemma div_add_sub_l a b c d : b <> 0 -> (a * b + c - d) / b = a + (c - d) / b.
  Proof. rewrite <- Z.add_sub_assoc; apply Z.div_add_l. Qed.

  Lemma div_add_sub_l' a b c d : b <> 0 -> (b * a + c - d) / b = a + (c - d) / b.
  Proof. rewrite <- Z.add_sub_assoc; apply Z.div_add_l'. Qed.

  Lemma div_add_sub a b c d : c <> 0 -> (a + b * c - d) / c = (a - d) / c + b.
  Proof. rewrite (Z.add_comm _ (_ * _)), (Z.add_comm (_ / _)); apply Z.div_add_sub_l. Qed.

  Lemma div_add_sub' a b c d : c <> 0 -> (a + c * b - d) / c = (a - d) / c + b.
  Proof. rewrite (Z.add_comm _ (_ * _)), (Z.add_comm (_ / _)); apply Z.div_add_sub_l'. Qed.

  Hint Rewrite Z.div_add_sub Z.div_add_sub' Z.div_add_sub_l Z.div_add_sub_l' using zutil_arith : zsimplify.

  Lemma div_mul_skip a b k : 0 < b -> 0 < k -> a * b / k / b = a / k.
  Proof.
    intros; rewrite Z.div_div, (Z.mul_comm k), <- Z.div_div by lia.
    autorewrite with zsimplify. reflexivity.
  Qed.

  Lemma div_mul_skip' a b k : 0 < b -> 0 < k -> b * a / k / b = a / k.
  Proof.
    intros; rewrite Z.div_div, (Z.mul_comm k), <- Z.div_div by lia.
    autorewrite with zsimplify; reflexivity.
  Qed.

  Hint Rewrite Z.div_mul_skip Z.div_mul_skip' using zutil_arith : zsimplify.

  Lemma div_mul_skip_pow base e0 e1 x y : 0 < y -> 0 < base -> 0 <= e1 <= e0 -> x * base^e0 / y / base^e1 = x * base^(e0 - e1) / y.
  Proof.
    intros.
    assert (0 < base^e1) by auto with zarith.
    replace (base^e0) with (base^(e0 - e1) * base^e1) by (autorewrite with pull_Zpow zsimplify; reflexivity).
    rewrite !Z.mul_assoc.
    autorewrite with zsimplify; lia.
  Qed.
  Hint Rewrite div_mul_skip_pow using zutil_arith : zsimplify.

  Lemma div_mul_skip_pow' base e0 e1 x y : 0 < y -> 0 < base -> 0 <= e1 <= e0 -> base^e0 * x / y / base^e1 = base^(e0 - e1) * x / y.
  Proof.
    intros.
    rewrite (Z.mul_comm (base^e0) x), div_mul_skip_pow by lia.
    auto using f_equal2 with lia.
  Qed.
  Hint Rewrite div_mul_skip_pow' using zutil_arith : zsimplify.

  Lemma div_le_mono_nonneg a b c : 0 <= c -> a <= b -> a / c <= b / c.
  Proof.
    destruct (Z_zerop c).
    { subst; simpl; autorewrite with zsimplify; reflexivity. }
    { intros; apply Z.div_le_mono; omega. }
  Qed.
  Hint Resolve div_le_mono_nonneg : zarith.

  Lemma div_le_mono_pow_pos a b c e : a <= b -> a / Z.pos c ^ e <= b / Z.pos c ^ e.
  Proof. auto with zarith. Qed.

  Lemma div_nonneg a b : 0 <= a -> 0 <= b -> 0 <= a / b.
  Proof.
    destruct (Z_zerop b); subst; rewrite ?Zdiv_0_r; [ reflexivity | ].
    intros; apply Z.div_pos; omega.
  Qed.
  Hint Resolve div_nonneg : zarith.

  Lemma div_add_exact x y d : d <> 0 -> x mod d = 0 -> (x + y) / d = x / d + y / d.
  Proof.
    intros; rewrite (Z_div_exact_full_2 x d) at 1 by assumption.
    rewrite Z.div_add_l' by assumption; lia.
  Qed.
  Hint Rewrite div_add_exact using zutil_arith : zsimplify.

  Lemma div_sub_mod_exact a b : b <> 0 -> a / b = (a - a mod b) / b.
  Proof.
    intro.
    rewrite (Z.div_mod a b) at 2 by lia.
    autorewrite with zsimplify.
    reflexivity.
  Qed.

  Lemma div_sub_mod_cond x y d
    : d <> 0
      -> (x - y) / d
         = x / d + ((x mod d - y) / d).
  Proof. clear.
         intro.
         replace (x - y) with ((x - x mod d) + (x mod d - y)) by lia.
         rewrite Z.div_add_exact by (autorewrite with pull_Zmod zsimplify; auto).
         rewrite <- Z.div_sub_mod_exact by lia; lia.
  Qed.
  Hint Resolve div_sub_mod_cond : zarith.

  Lemma div_add_mod_cond_l : forall x y d, d <> 0 -> (x + y) / d = (x mod d + y) / d + x / d.
  Proof.
    intros. replace (x + y) with ((x - x mod d) + (x mod d + y)) by lia.
    rewrite Z.div_add_exact by (autorewrite with pull_Zmod zsimplify; auto).
    rewrite <- Z.div_sub_mod_exact by lia; lia.
  Qed.

  Lemma div_add_mod_cond_r : forall x y d, d <> 0 -> (x + y) / d = (x + y mod d) / d + y / d.
  Proof.
    intros. rewrite Z.add_comm, div_add_mod_cond_l by auto. repeat (f_equal; try ring).
  Qed.

End Z.


Require Export Subbases SeparatednessAxioms.
From ZornsLemma Require Export Relation_Definitions_Implicit.
From ZornsLemma Require Import EnsemblesTactics.

Section OrderTopology.

Variable X:Type.
Variable R:relation X.
Hypothesis R_ord: order R.

Inductive order_topology_subbasis : Family X :=
  | intro_lower_interval: forall x:X,
    In order_topology_subbasis [ y:X | R y x /\ y <> x ]
  | intro_upper_interval: forall x:X,
    In order_topology_subbasis [ y:X | R x y /\ y <> x].

Definition OrderTopology : TopologicalSpace :=
  Build_TopologicalSpace_from_subbasis X order_topology_subbasis.

Section if_total_order.

Hypothesis R_total: forall x y:X, R x y \/ R y x.

Lemma lower_closed_interval_closed: forall x:X,
  closed [ y:X | R y x ] (X:=OrderTopology).
Proof.
intro.
red.
match goal with |- open ?U => replace U with (interior U) end.
{ apply interior_open. }
apply Extensionality_Ensembles; split.
{ apply interior_deflationary. }
intros y ?.
red in H.
red in H.
assert (R x y).
{ destruct (R_total x y); trivial.
  now contradiction H. }
exists [z:X | R x z /\ z <> x];
  constructor; split; trivial.
- apply (Build_TopologicalSpace_from_subbasis_subbasis
    _ order_topology_subbasis).
  constructor.
- red. intros z ?.
  destruct H1.
  destruct H1.
  intro.
  destruct H3.
  contradiction H2.
  now apply (ord_antisym R_ord).
- intro.
  contradiction H.
  constructor.
  now subst.
Qed.

Lemma upper_closed_interval_closed: forall x:X,
  closed [y:X | R x y] (X:=OrderTopology).
Proof.
intro.
red.
match goal with |- open ?U => replace U with (interior U) end.
{ apply interior_open. }
apply Extensionality_Ensembles; split.
{ apply interior_deflationary. }
intros y ?.
red in H.
red in H.
assert (R y x).
{ destruct (R_total x y); trivial.
  now contradiction H. }
exists ([z:X | R z x /\ z <> x]);
  constructor; split; trivial.
- apply (Build_TopologicalSpace_from_subbasis_subbasis
    _ order_topology_subbasis).
  constructor.
- red; intros z ?.
  destruct H1.
  destruct H1.
  intro.
  destruct H3.
  contradiction H2.
  now apply (ord_antisym R_ord).
- intro.
  contradiction H.
  constructor.
  now subst.
Qed.

Lemma order_topology_Hausdorff: Hausdorff OrderTopology.
Proof.
red.
match goal with |- forall x y:point_set OrderTopology, ?P =>
  cut (forall x y:point_set OrderTopology, R x y -> P)
  end;
  intros.
- destruct (R_total x y).
  { exact (H x y H1 H0). }
  assert (y <> x) by auto.
  destruct (H y x H1 H2) as [V [U [? [? [? []]]]]].
  exists U, V.
  repeat split; trivial.
  transitivity (Intersection V U); trivial.
  now extensionality_ensembles.
- pose proof (Build_TopologicalSpace_from_subbasis_subbasis
    _ order_topology_subbasis).
  destruct (classic (exists z:X, R x z /\ R z y /\ z <> x /\ z <> y)).
  + destruct H2 as [z [? [? []]]].
    exists ([w:X | R w z /\ w <> z]),
           ([w:X | R z w /\ w <> z]).
    repeat split; auto.
    * apply H1.
      constructor.
    * apply H1.
      constructor.
    * extensionality_ensembles.
      destruct H6, H7.
      contradiction H8.
      now apply (ord_antisym R_ord).
  + exists ([w:X | R w y /\ w <> y]),
           ([w:X | R x w /\ w <> x]).
    repeat split; auto.
    * apply H1.
      constructor.
    * apply H1.
      constructor.
    * extensionality_ensembles.
      destruct H3, H4.
      contradiction H2.
      exists x0.
      now repeat split.
Qed.

End if_total_order.

End OrderTopology.

Arguments OrderTopology {X}.


Require Import Arith.
Require Import Omega.
Require Import Psatz.

Require Import kernel_numeric.
Require Import kernel_graph.
Require Import graph_examples.
Require Import graph_constructions.

Definition graph_complement (G : Graph) : Graph.
Proof.
  refine {| V := (V G);
            E := fun x y => x <> y  /\ not(E G x y);
         |}.
  - intros x y.
    destruct (Nat.eq_dec x y).
    + right.
      intro A.
      destruct A.
      auto.
    + destruct (E_decidable G x y).
      * right.
        intro A.
        destruct A.
        auto.
      * auto.
  - intros x q A.
    destruct A.
    auto.
  - intros x q y r.
    pose (E_symmetric G).
    intro A.
    destruct A.
    split; auto. (* spet primer ko auto zna omega pa ne*)
Qed.

Definition ordered_induced_subgraph (G : Graph) (n : nat) (p: n <= (V G)): Graph.
(*Proof. (* kje je Proof. bolj smiselno? *)*)
  refine {| V := n;
            E := fun x y => E G x y;
         |}.
(* Tu bi sel tudi tukaj ampak kje drugje pa ne saj moti znak ; *)
Proof.
  - apply (E_decidable G).
  - intros x q.
    apply (E_irreflexive G).
    omega.
  - intros x q y r.
    apply E_symmetric; omega.
Qed.

(* This definition is for reflexive edges only - must be normal graph. *)
Definition graph_equality (G1 : Graph) (G2 : Graph) :=
  (V G1) = (V G2) /\ (all x : (V G1), all y : x, (E G1 x y <-> E G2 x y)).

Definition graph_homomorphism (G1 G2 : Graph) (f : nat -> nat):=
  (all x : (V G1), ((f x) < (V G2)))/\
  (all x : (V G1), all y : x, (E G1 x y -> E G2 (f x) (f y))).

(* graph_surjective_homeomorphism *)
Definition graph_epimorphism (G1 G2 : Graph) (f : nat -> nat):=
  (all x : (V G1), ((f x) < (V G2))) /\
  (all y : (V G2), some x : (V G1), ((f x) = y)) /\
  (all x : (V G1), all y : x, (E G1 x y -> E G2 (f x) (f y))).
(**
to je sedaj definiran epimorfizm s pripadajoco funkcijo
Mogoce nekoc enako brez da podana funkcija.
Potem uporabim obstaja f...
**)

Definition graph_monomorphism (G1 G2 : Graph) (f : nat -> nat):=
  (all x : (V G1), ((f x) < (V G2))) /\
  (all x1 : (V G1), all x2 : (V G1), ((x1 <> x2) -> ((f x1) <> (f x2)))) /\
  (all x : (V G1), all y : x, (E G1 x y -> E G2 (f x) (f y))).

Definition graph_monomorphism_back (G1 G2 : Graph) (f : nat -> nat):=
  (all x : (V G1), ((f x) < (V G2))) /\
  (all x1 : (V G1), all x2 : (V G1), ((x1 <> x2) -> ((f x1) <> (f x2)))) /\
  (all x : (V G1), all y : x, (E G2 (f x) (f y) -> E G1 x y)).

Definition graph_izomorphismA (G1 G2 : Graph) (f : nat -> nat):=
  (V G1) = (V G2) /\ (graph_epimorphism G1 G2 f).

Definition graph_izomorphismB (G1 G2 : Graph) (f : nat -> nat):=
  (V G1) = (V G2) /\ (graph_monomorphism G1 G2 f).

Definition increasing_conected_graph (G : Graph) :=
  (all x : (V G), some y : x, (E G x y)).

Definition conected_graphA (G : Graph) :=
  (exists H : Graph , ((increasing_conected_graph H) /\
   exists f : nat -> nat, (graph_epimorphism H G f))).

(*
Search (~ (_ /\ _) -> (_ \/ _)).
Search (~(_ \/ _) -> (_ /\ _)).
*)

(*
Definition conected_graphB (G : Graph) :=
  (exists H : Graph , ((increasing_conected_graph H) /\
   exists f : nat -> nat, (graph_monomorphism_back G H f))).

Definition conected_graphC (G : Graph) :=
  (exists H : Graph , ((increasing_conected_graph H) /\
   exists f : nat -> nat, (graph_monomorphism_back
    (graph_complement G) (graph_complement H) f))).
*)


Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.Ranalysis1.
Require Import Coq.Reals.Ranalysis4.
Require Import Coq.micromega.Psatz.
Require Import Coq.Reals.Rbasic_fun.
Require Import Coq.Reals.Rtrigo_def.
Require Import Coq.Reals.Reals.
Require Import SLogic.Tactics.

Definition strict_increasing_bound
           (f : R -> R) (bound : R) : Prop :=
  forall x y, (bound <= x < y -> f x < f y)%R.

Definition decreasing_bound
           (f : R -> R) (bound : R) : Prop :=
  forall x y, (bound <= x <= y -> f y <= f x)%R.

Definition K_fun (f : R -> R) : Prop :=
  continuity f /\ strict_increasing_bound f R0 /\ f R0 = R0.

(* I couldn't find a definition in the standard library
   for the limit at infinity. *)
Definition limit_pos_inf (f : R -> R) (l : R) : Prop :=
  forall epsilon, (epsilon > 0)%R ->
    exists M, (M > 0)%R /\
      (forall x, x > M -> Rabs (f x - l) < epsilon)%R.

Definition unbounded (f : R -> R) : Prop :=
  (forall N, N > 0 ->
     exists M, (M > 0)%R /\
       forall x, x > M -> f(x) > N)%R.

Definition K_inf_fun (f : R -> R) : Prop :=
  K_fun f /\ unbounded f.

(* This is not the same as the definition of L functions
   from the Tabuada paper. In particular, we only require
   that the function be decreasing, not strictly decreasing.
   I think that if you require the function to be strictly
   decreasing, then there are no KLD functions. Moreover,
   I think that our definition of L function is the
   standard one from control theory. *)
Definition L_fun (f : R -> R) : Prop :=
  continuity f /\ decreasing_bound f R0 /\
  limit_pos_inf f R0.

Definition KL_fun (f : R -> R -> R) : Prop :=
  (forall t, (0 <= t)%R -> K_fun (fun c => f c t)) /\
  (forall c, (0 <= c)%R -> L_fun (fun t => f c t)).

Definition KLD_fun (f : R -> R -> R) : Prop :=
  KL_fun f /\
  forall (c : R),
    (0 <= c)%R ->
    f c 0%R = c /\
    forall (s t : R),
      (0 <= s)%R -> (0 <= t)%R ->
      (f c (s + t) = f (f c s) t)%R.

(* Now some useful properties of these functions. *)

Lemma K_fun_pos :
  forall f, K_fun f ->
            forall r, (0 <= r)%R ->
                      (0 <= f r)%R.
Proof.
  unfold K_fun, strict_increasing_bound. intros.
  destruct H as [? [Hincr HR0]].
  rewrite <- HR0. destruct H0.
  { specialize (Hincr R0 r). psatzl R. }
  { rewrite H0. psatzl R. }
Qed.

Lemma KL_fun_pos :
  forall f, KL_fun f ->
            forall r1 r2,
              (0 <= r1)%R -> (0 <= r2)%R ->
              (0 <= f r1 r2)%R.
Proof.
  unfold KL_fun. intros.
  destruct H as [HK ?].
  specialize (HK r2 H1).
  eapply K_fun_pos in HK; eauto.
Qed.

Lemma KLD_fun_pos :
  forall f, KLD_fun f ->
            forall r1 r2,
              (0 <= r1)%R -> (0 <= r2)%R ->
              (0 <= f r1 r2)%R.
Proof.
  unfold KLD_fun. intros.
  apply KL_fun_pos; tauto.
Qed.

Lemma KLD_fun_increasing_nonneg :
  forall f,
    KLD_fun f ->
    forall t, (0 <= t)%R ->
              strict_increasing_bound (fun x => f x t) R0.
Proof.
  intros. unfold KLD_fun, KL_fun, K_fun in *.
  intuition. specialize (H t).
  specialize_arith_hyp H. tauto.
Qed.

Lemma KLD_fun_0 :
  forall f,
    KLD_fun f ->
    forall t, (0 <= t)%R ->
              f R0 t = R0.
Proof.
  unfold KLD_fun, KL_fun, K_fun, L_fun. intros.
  intuition.
  (* This requires reasoning about infinite limits. *)
Admitted.

Lemma continuity_id :
  continuity id.
Proof.
  apply derivable_continuous; apply derivable_id.
Qed.

Lemma continuity_exp :
  continuity exp.
Proof.
  apply derivable_continuous; apply derivable_exp.
Qed.

(* TODO: move *)
(* Proves continuity facts of real-valued functions. *)
Ltac prove_continuity :=
  repeat first [ apply continuity_plus |
                 apply continuity_opp |
                 apply continuity_minus |
                 apply continuity_mult |
                 solve [apply continuity_const; congruence] |
                 apply continuity_scal |
                 apply continuity_inv |
                 apply continuity_div |
                 apply continuity_id |
                 apply continuity_exp |
                 apply Ranalysis4.Rcontinuity_abs ].

Lemma Rabs_involutive :
  forall r, Rabs (Rabs r) = Rabs r.
Proof.
  intros. apply Rabs_pos_eq; apply Rabs_pos.
Qed.

Local Open Scope R_scope.

Lemma K_fun_id :
  K_fun Ranalysis1.id.
Proof.
  split.
  { prove_continuity. }
  { unfold strict_increasing_bound, Ranalysis1.id.
    split; intros; psatzl R. }
Qed.

Lemma K_fun_mult :
  forall f1 f2,
    K_fun f1 -> K_fun f2 ->
    K_fun (fun x => f1 x * f2 x).
Proof.
  unfold K_fun; intros; split.
  { prove_continuity; tauto. }
  { unfold strict_increasing_bound in *. intuition.
    pose proof (H0 x y). pose proof (H2 x y).
    specialize_arith_hyp H3. specialize_arith_hyp H8.
    specialize (H0 0 x). specialize (H2 0 x).
    destruct H6.
    { specialize_arith_hyp H0. specialize_arith_hyp H2.
      psatz R. }
    { subst. psatz R. } }
Qed.

Lemma K_fun_scale :
  forall f c,
    K_fun f -> 0 < c ->
    K_fun (fun x => c * f x).
Proof.
  unfold K_fun. intros. split.
  { prove_continuity; tauto. }
  { unfold strict_increasing_bound in *. intuition. }
Qed.

Lemma K_inf_fun_id :
  K_inf_fun Ranalysis1.id.
Proof.
  split.
  { apply K_fun_id. }
  { unfold unbounded, id. intros. eauto. }
Qed.

Lemma K_inf_fun_scale :
  forall f c,
    K_inf_fun f -> 0 < c ->
    K_inf_fun (fun x => c * f x).
Proof.
  unfold K_inf_fun. intros. split.
  { apply K_fun_scale; tauto. }
  { unfold unbounded in *. intros.
    assert (/c > 0) by (apply Rinv_0_lt_compat; assumption).
    assert (N / c > 0) by (unfold Rdiv; psatz R).
    destruct H. specialize (H4 _ H3).
    destruct H4. destruct H4.
    exists x. split; auto. intros. specialize (H5 _ H6).
    apply Rlt_gt. apply (Rmult_lt_reg_l (/c)); [ psatzl R | ].
    rewrite <- Rmult_assoc. rewrite <- Rinv_l_sym; psatzl R. }
Qed.

Lemma KL_fun_abs_exp :
  forall a,
    0 < a ->
    KL_fun (fun d t => Rabs d * exp (-t * a)).
Proof.
  repeat split.
  { prove_continuity. }
  { unfold strict_increasing_bound. intros.
    pose proof (Exp_prop.exp_pos (-t * a)).
    repeat (rewrite Rabs_right;
            [ | solve [psatzl R ] ]).
    psatz R. }
  { rewrite Rabs_R0. psatzl R. }
  { prove_continuity.
    apply continuity_comp with (f1:=fun x => -x * a)
                                 (f2:=exp);
      prove_continuity. }
  { unfold decreasing_bound. intros.
    destruct H1. destruct H2.
    { pose proof (exp_increasing (-y * a) (-x * a)).
      pose proof (Rabs_pos c).
      assert (- y * a < - x * a) by psatz R.
      pose proof (exp_pos (-y * a)).
      intuition.
    (* I don't understand
             how this solves the goal. *) }
    { subst. intuition. } }
  { unfold limit_pos_inf. intros.
    admit. (* Need some limit lemmas. *) }
Admitted.

Lemma KLD_fun_abs_exp :
  forall a,
    0 < a ->
    KLD_fun (fun d t => Rabs d * exp (-t * a)).
Proof.
  split.
  { apply KL_fun_abs_exp; assumption. }
  { repeat split.
    { intros.
      rewrite RIneq.Ropp_0. rewrite Rmult_0_l. rewrite exp_0.
      rewrite RIneq.Rmult_1_r.
      apply Rabs_pos_eq; assumption. }
    { intros. rewrite RIneq.Ropp_plus_distr.
      rewrite Rmult_plus_distr_r. rewrite Exp_prop.exp_plus.
      rewrite Rabs_mult. rewrite Rabs_involutive.
      rewrite Rabs_pos_eq with (x:=exp (-s * a));
        [ | left; apply Exp_prop.exp_pos ].
      psatzl R. } }
Qed.