Require Import Psatz.
Require Import Reals.

Require Export Matrix.

(* Using our (complex, unbounded) matrices, their complex numbers *)

(*******************************************)
(** * Quantum basis states *)
(*******************************************)

(* Maybe change to IF statements? *)
Definition qubit0 : Vector 2 :=
  fun x y => match x, y with
          | 0, 0 => C1
          | 1, 0 => C0
          | _, _ => C0
          end.
Definition qubit1 : Vector 2 :=
  fun x y => match x, y with
          | 0, 0 => C0
          | 1, 0 => C1
          | _, _ => C0
          end.

(* Ket notation: \mid 0 \rangle *)
Notation "∣0⟩" := qubit0.
Notation "∣1⟩" := qubit1.
Notation "⟨0∣" := qubit0†.
Notation "⟨1∣" := qubit1†.
Notation "∣0⟩⟨0∣" := (∣0⟩×⟨0∣).
Notation "∣1⟩⟨1∣" := (∣1⟩×⟨1∣).
Notation "∣1⟩⟨0∣" := (∣1⟩×⟨0∣).
Notation "∣0⟩⟨1∣" := (∣0⟩×⟨1∣).

Definition bra (x : nat) : Matrix 1 2 := if x =? 0 then ⟨0∣ else ⟨1∣.
Definition ket (x : nat) : Matrix 2 1 := if x =? 0 then ∣0⟩ else ∣1⟩.

(* Note the 'mid' symbol for these *)
Notation "'∣' x '⟩'" := (ket x).
Notation "'⟨' x '∣'" := (bra x). (* This gives the Coq parser headaches *)

Notation "∣ x , y , .. , z ⟩" := (kron .. (kron ∣x⟩ ∣y⟩) .. ∣z⟩) (at level 0).
(* Alternative: |0⟩|1⟩. *)

Transparent bra.
Transparent ket.
Transparent qubit0.
Transparent qubit1.

Definition bool_to_ket (b : bool) : Matrix 2 1 := if b then ∣1⟩ else ∣0⟩.

Definition bool_to_matrix (b : bool) : Matrix 2 2 := if b then ∣1⟩⟨1∣ else ∣0⟩⟨0∣.

Definition bool_to_matrix' (b : bool) : Matrix 2 2 := fun x y =>
  match x, y with
  | 0, 0 => if b then 0 else 1
  | 1, 1 => if b then 1 else 0
  | _, _ => 0
  end.

Lemma bool_to_matrix_eq : forall b, bool_to_matrix b = bool_to_matrix' b.
Proof. intros. destruct b; simpl; solve_matrix. Qed.

Lemma bool_to_ket_matrix_eq : forall b,
    outer_product (bool_to_ket b) (bool_to_ket b) = bool_to_matrix b.
Proof. unfold outer_product. destruct b; simpl; reflexivity. Qed.

Definition bools_to_matrix (l : list bool) : Square (2^(length l)) :=
  big_kron (map bool_to_matrix l).

Lemma ket_decomposition : forall (ψ : Vector 2),
  WF_Matrix ψ ->
  ψ = (ψ 0%nat 0%nat) .* ∣ 0 ⟩ .+ (ψ 1%nat 0%nat) .* ∣ 1 ⟩.
Proof.
  intros.
  prep_matrix_equality.
  unfold scale, Mplus.
  destruct y as [|y'].
  2:{ rewrite H; try lia.
      unfold ket, qubit0, qubit1. simpl.
      repeat (destruct x; try lca). }
  destruct x as [| [| n]]; unfold ket, qubit0, qubit1; simpl; try lca.
  rewrite H; try lia.
  lca.
Qed.

(****************)
(** * Unitaries *)
(****************)

Definition hadamard : Matrix 2 2 :=
  (fun x y => match x, y with
          | 0, 0 => (1 / √2)
          | 0, 1 => (1 / √2)
          | 1, 0 => (1 / √2)
          | 1, 1 => -(1 / √2)
          | _, _ => 0
          end).

Fixpoint hadamard_k (k : nat) : Matrix (2^k) (2^k):=
  match k with
  | 0 => I 1
  | S k' => hadamard ⊗ hadamard_k k'
  end.

Lemma hadamard_1 : hadamard_k 1 = hadamard.
Proof. apply kron_1_r. Qed.

(* Alternative definitions:
Definition pauli_x : Matrix 2 2 := fun x y => if x + y =? 1 then 1 else 0.
Definition pauli_y : Matrix 2 2 := fun x y => if x + y =? 1 then (-1) ^ x * Ci else 0.
Definition pauli_z : Matrix 2 2 := fun x y => if (x =? y) && (x <? 2)
                                           then (-1) ^ x * Ci else 0.
*)

Definition σx : Matrix 2 2 :=
  fun x y => match x, y with
          | 0, 1 => C1
          | 1, 0 => C1
          | _, _ => C0
          end.

Definition σy : Matrix 2 2 :=
  fun x y => match x, y with
          | 0, 1 => -Ci
          | 1, 0 => Ci
          | _, _ => C0
          end.

Definition σz : Matrix 2 2 :=
  fun x y => match x, y with
          | 0, 0 => C1
          | 1, 1 => -C1
          | _, _ => C0
          end.

Definition control {n : nat} (A : Matrix n n) : Matrix (2*n) (2*n) :=
  fun x y => if (x <? n) && (y =? x) then 1 else
          if (n <=? x) && (n <=? y) then A (x-n)%nat (y-n)%nat else 0.

(* Definition cnot := control pauli_x. *)
(* Direct definition makes our lives easier *)
(* Dimensions are given their current form for convenient
   kron_mixed_product applications *)
Definition cnot : Matrix (2*2) (2*2) :=
  fun x y => match x, y with
          | 0, 0 => C1
          | 1, 1 => C1
          | 2, 3 => C1
          | 3, 2 => C1
          | _, _ => C0
          end.

Lemma cnot_eq : cnot = control σx.
Proof.
  unfold cnot, control, σx.
  solve_matrix.
Qed.

Definition notc : Matrix (2*2) (2*2) :=
  fun x y => match x, y with
          | 1, 3 => 1%C
          | 3, 1 => 1%C
          | 0, 0 => 1%C
          | 2, 2 => 1%C
          | _, _ => 0%C
          end.

(* Swap Matrices *)

Definition swap : Matrix (2*2) (2*2) :=
  fun x y => match x, y with
          | 0, 0 => C1
          | 1, 2 => C1
          | 2, 1 => C1
          | 3, 3 => C1
          | _, _ => C0
          end.

Hint Unfold qubit0 qubit1 hadamard σx σy σz control cnot swap bra ket : U_db.

(** ** Rotation Matrices *)

(* Standard(?) definition, but it makes equivalence-checking a little annoying
   because of a global phase.

Definition rotation (θ ϕ λ : R) : Matrix 2 2 :=
  fun x y => match x, y with
             | 0, 0 => (Cexp (-(ϕ + λ)/2)) * (cos (θ/2))
             | 0, 1 => - (Cexp (-(ϕ - λ)/2)) * (sin (θ/2))
             | 1, 0 => (Cexp ((ϕ - λ)/2)) * (sin (θ/2))
             | 1, 1 => (Cexp ((ϕ + λ)/2)) * (cos (θ/2))
             | _, _ => C0
             end.
*)
Definition rotation (θ ϕ λ : R) : Matrix 2 2 :=
  fun x y => match x, y with
             | 0, 0 => (cos (θ/2))
             | 0, 1 => - (Cexp λ) * (sin (θ/2))
             | 1, 0 => (Cexp ϕ) * (sin (θ/2))
             | 1, 1 => (Cexp (ϕ + λ)) * (cos (θ/2))
             | _, _ => C0
             end.

(* z_rotation lemmas are further down *)
Definition phase_shift (ϕ : R) : Matrix 2 2 :=
  fun x y => match x, y with
          | 0, 0 => C1
          | 1, 1 => Cexp ϕ
          | _, _ => C0
          end.

(* Notation z_rotation := phase_shift. *)

Definition x_rotation  (θ : R) : Matrix 2 2 :=
  fun x y => match x, y with
          | 0, 0 => cos (θ / 2)
          | 0, 1 => -Ci * sin (θ / 2)
          | 1, 0 => -Ci * sin (θ / 2)
          | 1, 1 => cos (θ / 2)
          | _, _ => 0
          end.

Definition y_rotation  (θ : R) : Matrix 2 2 :=
  fun x y => match x, y with
          | 0, 0 => cos (θ / 2)
          | 0, 1 => - sin (θ / 2)
          | 1, 0 => sin (θ / 2)
          | 1, 1 => cos (θ / 2)
          | _, _ => 0
          end.

(* Shifted by i so x/y_rotation PI = σx/y :
Definition x_rotation  (θ : R) : Matrix 2 2 :=
  fun x y => match x, y with
          | 0, 0 => Ci * cos (θ / 2)
          | 0, 1 => sin (θ / 2)
          | 1, 0 => sin (θ / 2)
          | 1, 1 => Ci * cos (θ / 2)
          | _, _ => 0
          end.

Definition y_rotation  (θ : R) : Matrix 2 2 :=
  fun x y => match x, y with
          | 0, 0 => Ci * cos (θ / 2)
          | 0, 1 => -Ci * sin (θ / 2)
          | 1, 0 => Ci * sin (θ / 2)
          | 1, 1 => Ci * cos (θ / 2)
          | _, _ => 0
          end.
 *)

Lemma x_rotation_pi : x_rotation PI = -Ci .* σx.
Proof.
  unfold σx, x_rotation, scale.
  prep_matrix_equality.
  destruct_m_eq;
  autorewrite with trig_db C_db;
  reflexivity.
Qed.

Lemma y_rotation_pi : y_rotation PI = -Ci .* σy.
Proof.
  unfold σy, y_rotation, scale.
  prep_matrix_equality.
  destruct_m_eq;
  autorewrite with trig_db C_db;
  try reflexivity.
Qed.

Lemma hadamard_rotation : rotation (PI/2) 0 PI = hadamard.
Proof.
  unfold hadamard, rotation.
  prep_matrix_equality.
  destruct_m_eq; try reflexivity;
  unfold Cexp; apply injective_projections; simpl;
  autorewrite with R_db;
  autorewrite with trig_db;
  autorewrite with R_db;
  try reflexivity.
  all: rewrite Rmult_assoc;
       replace (/2 * /2)%R with (/4)%R by lra;
       repeat rewrite <- Rdiv_unfold;
       autorewrite with trig_db;
       rewrite sqrt2_div2;
       lra.
Qed.

Lemma pauli_x_rotation : rotation PI 0 PI = σx.
Proof.
  unfold σx, rotation.
  prep_matrix_equality.
  destruct_m_eq; try reflexivity;
  unfold Cexp; apply injective_projections; simpl;
  autorewrite with trig_db;
  lra.
Qed.

Lemma pauli_y_rotation : rotation PI (PI/2) (PI/2) = σy.
Proof.
  unfold σy, rotation.
  prep_matrix_equality.
  destruct_m_eq; try reflexivity;
  unfold Cexp; apply injective_projections; simpl;
  autorewrite with trig_db;
  lra.
Qed.

Lemma pauli_z_rotation : rotation 0 0 PI = σz.
Proof.
  unfold σz, rotation.
  prep_matrix_equality.
  destruct_m_eq; try reflexivity;
  unfold Cexp; apply injective_projections; simpl;
  autorewrite with R_db;
  autorewrite with trig_db;
  lra.
Qed.

Lemma Rx_rotation : forall θ, rotation θ (3*PI/2) (PI/2) = x_rotation θ.
Proof.
  intros.
  unfold rotation, x_rotation.
  prep_matrix_equality.
  destruct_m_eq;
  autorewrite with C_db Cexp_db; reflexivity.
Qed.

Lemma Ry_rotation : forall θ, rotation θ 0 0 = y_rotation θ.
Proof.
  intros.
  unfold rotation, y_rotation.
  prep_matrix_equality.
  destruct_m_eq;
  autorewrite with C_db Cexp_db; try reflexivity.
Qed.

Lemma phase_shift_rotation : forall θ, rotation 0 0 θ = phase_shift θ.
Proof.
  intros.
  unfold phase_shift, rotation.
  prep_matrix_equality.
  destruct_m_eq; try reflexivity;
  unfold Cexp; apply injective_projections; simpl;
  autorewrite with R_db;
  autorewrite with trig_db;
  lra.
Qed.

Lemma I_rotation : rotation 0 0 0 = I 2.
Proof.
  unfold I, rotation.
  prep_matrix_equality.
  destruct_m_eq; try reflexivity;
  unfold Cexp; apply injective_projections; simpl;
  autorewrite with R_db;
  autorewrite with trig_db;
  autorewrite with R_db;
  try reflexivity.
  bdestruct (x =? y); bdestruct (S (S x) <? 2); simpl; try reflexivity; lia.
  destruct (x =? y); destruct (S (S x) <? 2); reflexivity.
Qed.

(* Lemmas *)

(* Additional tactics for ∣0⟩, ∣1⟩, cnot and σx. *)

Lemma Mmult00 : ⟨0∣ × ∣0⟩ = I 1. Proof. solve_matrix. Qed.
Lemma Mmult01 : ⟨0∣ × ∣1⟩ = Zero. Proof. solve_matrix. Qed.
Lemma Mmult10 : ⟨1∣ × ∣0⟩ = Zero. Proof. solve_matrix. Qed.
Lemma Mmult11 : ⟨1∣ × ∣1⟩ = I 1. Proof. solve_matrix. Qed.

Lemma MmultX1 : σx × ∣1⟩ = ∣0⟩. Proof. solve_matrix. Qed.
Lemma Mmult1X : ⟨1∣ × σx = ⟨0∣. Proof. solve_matrix. Qed.
Lemma MmultX0 : σx × ∣0⟩ = ∣1⟩. Proof. solve_matrix. Qed.
Lemma Mmult0X : ⟨0∣ × σx = ⟨1∣. Proof. solve_matrix. Qed.

Lemma MmultXX : σx × σx = I 2. Proof. solve_matrix. Qed.
Lemma MmultYY : σy × σy = I 2. Proof. solve_matrix. Qed.
Lemma MmultZZ : σz × σz = I 2. Proof. solve_matrix. Qed.
Lemma MmultHH : hadamard × hadamard = I 2. Proof. solve_matrix. Qed.
Lemma Mplus01 : ∣0⟩⟨0∣ .+ ∣1⟩⟨1∣ = I 2. Proof. solve_matrix. Qed.
Lemma Mplus10 : ∣1⟩⟨1∣ .+ ∣0⟩⟨0∣ = I 2. Proof. solve_matrix. Qed.

Lemma σx_on_right0 : forall (q : Vector 2), (q × ⟨0∣) × σx = q × ⟨1∣.
Proof. intros. rewrite Mmult_assoc, Mmult0X. reflexivity. Qed.

Lemma σx_on_right1 : forall (q : Vector 2), (q × ⟨1∣) × σx = q × ⟨0∣.
Proof. intros. rewrite Mmult_assoc, Mmult1X. reflexivity. Qed.

Lemma σx_on_left0 : forall (q : Matrix 1 2), σx × (∣0⟩ × q) = ∣1⟩ × q.
Proof. intros. rewrite <- Mmult_assoc, MmultX0. reflexivity. Qed.

Lemma σx_on_left1 : forall (q : Matrix 1 2), σx × (∣1⟩ × q) = ∣0⟩ × q.
Proof. intros. rewrite <- Mmult_assoc, MmultX1. reflexivity. Qed.

Lemma cancel00 : forall (q1 : Matrix 2 1) (q2 : Matrix 1 2),
  WF_Matrix q2 ->
  (q1 × ⟨0∣) × (∣0⟩ × q2) = q1 × q2.
Proof.
  intros.
  rewrite Mmult_assoc.
  rewrite <- (Mmult_assoc ⟨0∣).
  rewrite Mmult00.
  Msimpl; reflexivity.
Qed.

Lemma cancel01 : forall (q1 : Matrix 2 1) (q2 : Matrix 1 2),
  (q1 × ⟨0∣) × (∣1⟩ × q2) = Zero.
Proof.
  intros.
  rewrite Mmult_assoc.
  rewrite <- (Mmult_assoc ⟨0∣).
  rewrite Mmult01.
  Msimpl_light; reflexivity.
Qed.

Lemma cancel10 : forall (q1 : Matrix 2 1) (q2 : Matrix 1 2),
  (q1 × ⟨1∣) × (∣0⟩ × q2) = Zero.
Proof.
  intros.
  rewrite Mmult_assoc.
  rewrite <- (Mmult_assoc ⟨1∣).
  rewrite Mmult10.
  Msimpl_light; reflexivity.
Qed.

Lemma cancel11 : forall (q1 : Matrix 2 1) (q2 : Matrix 1 2),
  WF_Matrix q2 ->
  (q1 × ⟨1∣) × (∣1⟩ × q2) = q1 × q2.
Proof.
  intros.
  rewrite Mmult_assoc.
  rewrite <- (Mmult_assoc ⟨1∣).
  rewrite Mmult11.
  Msimpl; reflexivity.
Qed.

Hint Rewrite Mmult00 Mmult01 Mmult10 Mmult11 Mmult0X MmultX0 Mmult1X MmultX1 : Q_db.
Hint Rewrite MmultXX MmultYY MmultZZ MmultHH Mplus01 Mplus10 : Q_db.
Hint Rewrite σx_on_right0 σx_on_right1 σx_on_left0 σx_on_left1 : Q_db.
Hint Rewrite cancel00 cancel01 cancel10 cancel11 using (auto with wf_db) : Q_db.

Lemma swap_swap : swap × swap = I (2*2). Proof. solve_matrix. Qed.

Lemma swap_swap_r : forall (A : Matrix (2*2) (2*2)),
  WF_Matrix A ->
  A × swap × swap = A.
Proof.
  intros.
  rewrite Mmult_assoc.
  rewrite swap_swap.
  Msimpl.
  reflexivity.
Qed.

Hint Rewrite swap_swap swap_swap_r using (auto 100 with wf_db): Q_db.

(* The input k is really k+1, to appease to Coq termination gods *)
(* NOTE: Check that the offsets are right *)
(* Requires: i + 1 < n *)
Fixpoint swap_to_0_aux (n i : nat) {struct i} : Matrix (2^n) (2^n) :=
  match i with
  | O => swap ⊗ I (2^(n-2))
  | S i' =>  (I (2^i) ⊗ swap ⊗ I (2^(n-i-2))) × (* swap i-1 with i *)
            swap_to_0_aux n i' ×
            (I (2^i) ⊗ swap ⊗ I (2^(n-i-2))) (* swap i-1 with 0 *)
  end.

(* Requires: i < n *)
Definition swap_to_0 (n i : nat) : Matrix (2^n) (2^n) :=
  match i with
  | O => I (2^n)
  | S i' => swap_to_0_aux n i'
  end.

(* Swapping qubits i and j in an n-qubit system, where i < j *)
(* Requires i < j, j < n *)
Fixpoint swap_two_aux (n i j : nat) : Matrix (2^n) (2^n) :=
  match i with
  | O => swap_to_0 n j
  | S i' => I 2 ⊗ swap_two_aux (n-1) (i') (j-1)
  end.

(* Swapping qubits i and j in an n-qubit system *)
(* Requires i < n, j < n *)
Definition swap_two (n i j : nat) : Matrix (2^n) (2^n) :=
  if i =? j then I (2^n)
  else if i <? j then swap_two_aux n i j
  else swap_two_aux n j i.

(* Simpler version of swap_to_0 that shifts other elements *)
(* Requires: i+1 < n *)
Fixpoint move_to_0_aux (n i : nat) {struct i}: Matrix (2^n) (2^n) :=
  match i with
  | O => swap ⊗ I (2^(n-2))
  | S i' => (move_to_0_aux n i') × (I (2^i) ⊗ swap ⊗ I (2^(n-i-2)))

  end.

(* Requires: i < n *)
Definition move_to_0 (n i : nat) : Matrix (2^n) (2^n) :=
  match i with
  | O => I (2^n)
  | S i' => move_to_0_aux n i'
  end.

(* Always moves up in the matrix from i to k *)
(* Requires: k < i < n *)
Fixpoint move_to (n i k : nat) : Matrix (2^n) (2^n) :=
  match k with
  | O => move_to_0 n i
  | S k' => I 2 ⊗ move_to (n-1) (i-1) (k')
  end.

(*
Eval compute in ((swap_two 1 0 1) 0 0)%nat.
Eval compute in (print_matrix (swap_two 1 0 2)).
*)

(** Well Formedness of Quantum States and Unitaries **)

Lemma WF_bra0 : WF_Matrix ⟨0∣. Proof. show_wf. Qed.
Lemma WF_bra1 : WF_Matrix ⟨1∣. Proof. show_wf. Qed.
Lemma WF_qubit0 : WF_Matrix ∣0⟩. Proof. show_wf. Qed.
Lemma WF_qubit1 : WF_Matrix ∣1⟩. Proof. show_wf. Qed.
Lemma WF_braqubit0 : WF_Matrix ∣0⟩⟨0∣. Proof. show_wf. Qed.
Lemma WF_braqubit1 : WF_Matrix ∣1⟩⟨1∣. Proof. show_wf. Qed.

Lemma WF_bra : forall (x : nat), WF_Matrix (bra x).
Proof. intros x. unfold bra. destruct (x =? 0). show_wf. show_wf.
Qed.

Lemma WF_ket : forall (x : nat), WF_Matrix (ket x).
Proof. intros x. unfold ket. destruct (x =? 0). show_wf. show_wf.
Qed.

Lemma WF_bool_to_ket : forall b, WF_Matrix (bool_to_ket b).
Proof. destruct b; show_wf. Qed.
Lemma WF_bool_to_matrix : forall b, WF_Matrix (bool_to_matrix b).
Proof. destruct b; show_wf. Qed.
Lemma WF_bool_to_matrix' : forall b, WF_Matrix (bool_to_matrix' b).
Proof. destruct b; show_wf. Qed.

Lemma WF_bools_to_matrix : forall l,
  @WF_Matrix (2^(length l)) (2^(length l))  (bools_to_matrix l).
Proof.
  induction l; auto with wf_db.
  unfold bools_to_matrix in *; simpl.
  apply WF_kron; try rewrite map_length; try lia.
  apply WF_bool_to_matrix.
  apply IHl.
Qed.

Hint Resolve WF_bra0 WF_bra1 WF_qubit0 WF_qubit1 WF_bra WF_ket WF_braqubit0 WF_braqubit1 : wf_db.
Hint Resolve WF_bool_to_ket WF_bool_to_matrix WF_bool_to_matrix' : wf_db.
Hint Resolve WF_bools_to_matrix : wf_db.

Lemma WF_hadamard : WF_Matrix hadamard. Proof. show_wf. Qed.
Lemma WF_σx : WF_Matrix σx. Proof. show_wf. Qed.
Lemma WF_σy : WF_Matrix σy. Proof. show_wf. Qed.
Lemma WF_σz : WF_Matrix σz. Proof. show_wf. Qed.
Lemma WF_cnot : WF_Matrix cnot. Proof. show_wf. Qed.
Lemma WF_swap : WF_Matrix swap. Proof. show_wf. Qed.

Lemma WF_rotation : forall θ ϕ λ, WF_Matrix (rotation θ ϕ λ). Proof. intros. show_wf. Qed.
Lemma WF_phase : forall ϕ, WF_Matrix (phase_shift ϕ). Proof. intros. show_wf. Qed.

Lemma WF_control : forall (n : nat) (U : Matrix n n),
      WF_Matrix U -> WF_Matrix (control U).
Proof.
  intros n U WFU.
  unfold control, WF_Matrix in *.
  intros x y [Hx | Hy];
  bdestruct (x <? n); bdestruct (y =? x); bdestruct (n <=? x); bdestruct (n <=? y);
    simpl; try reflexivity; try lia.
  all: rewrite WFU; [reflexivity|lia].
Qed.

Hint Resolve WF_hadamard WF_σx WF_σy WF_σz WF_cnot WF_swap WF_phase : wf_db.
Hint Resolve WF_rotation : wf_db.

Hint Extern 2 (WF_Matrix (phase_shift _)) => apply WF_phase : wf_db.
Hint Extern 2 (WF_Matrix (control _)) => apply WF_control : wf_db.

(***************************)
(** Unitaries are unitary **)
(***************************)

(* For this section, we could just convert all single-qubit unitaries into their
   rotation form and use rotation_unitary. *)

Definition WF_Unitary {n: nat} (U : Matrix n n): Prop :=
  WF_Matrix U /\ U † × U = I n.

Hint Unfold WF_Unitary : U_db.

(* More precise *)
(* Definition unitary_matrix' {n: nat} (A : Matrix n n): Prop := Minv A A†. *)

Lemma H_unitary : WF_Unitary hadamard.
Proof.
  split.
  show_wf.
  unfold Mmult, I.
  prep_matrix_equality.
  autounfold with U_db.
  destruct x as [| [|x]]; destruct y as [|[|y]]; simpl; autorewrite with C_db;
    try reflexivity.
  replace ((S (S x) <? 2)) with false by reflexivity.
  rewrite andb_false_r.
  reflexivity.
Qed.

Lemma σx_unitary : WF_Unitary σx.
Proof.
  split.
  show_wf.
  unfold Mmult, I.
  prep_matrix_equality.
  destruct x as [| [|x]]; destruct y as [|[|y]]; try lca.
  simpl.
  replace ((S (S x) <? 2)) with false by reflexivity.
  rewrite andb_false_r.
  lca.
Qed.

Lemma σy_unitary : WF_Unitary σy.
Proof.
  split.
  show_wf.
  unfold Mmult, I.
  prep_matrix_equality.
  destruct x as [| [|x]]; destruct y as [|[|y]]; try lca.
  simpl.
  replace ((S (S x) <? 2)) with false by reflexivity.
  rewrite andb_false_r.
  lca.
Qed.

Lemma σz_unitary : WF_Unitary σz.
Proof.
  split.
  show_wf.
  unfold Mmult, I.
  prep_matrix_equality.
  destruct x as [| [|x]]; destruct y as [|[|y]]; try lca.
  simpl.
  replace ((S (S x) <? 2)) with false by reflexivity.
  rewrite andb_false_r.
  lca.
Qed.

Lemma phase_unitary : forall ϕ, @WF_Unitary 2 (phase_shift ϕ).
Proof.
  intros ϕ.
  split; [show_wf|].
  unfold Mmult, I, phase_shift, adjoint, Cexp.
  prep_matrix_equality.
  destruct x as [| [|x]]; destruct y as [|[|y]]; try lca.
  - simpl.
    Csimpl.
    unfold Cconj, Cmult.
    simpl.
    unfold Rminus.
    rewrite Ropp_mult_distr_l.
    rewrite Ropp_involutive.
    replace (cos ϕ * cos ϕ)%R with ((cos ϕ)²) by easy.
    replace (sin ϕ * sin ϕ)%R with ((sin ϕ)²) by easy.
    rewrite Rplus_comm.
    rewrite sin2_cos2.
    lca.
  - simpl. Csimpl.
    replace ((S (S x) <? 2)) with false by reflexivity.
    rewrite andb_false_r.
    lca.
Qed.

Lemma rotation_unitary : forall θ ϕ λ, @WF_Unitary 2 (rotation θ ϕ λ).
Proof.
  intros.
  split; [show_wf|].
  unfold Mmult, I, rotation, adjoint, Cexp.
  prep_matrix_equality.
  destruct_m_eq; try lca;
  unfold Cexp, Cconj;
  apply injective_projections; simpl;
  autorewrite with R_db;
  try lra.
  (* some general rewriting *)
  all: (repeat rewrite <- Rmult_assoc;
        repeat rewrite Ropp_mult_distr_l;
        repeat rewrite <- Rmult_plus_distr_r;
        repeat rewrite Rmult_assoc;
        repeat rewrite (Rmult_comm (cos (θ * / 2)));
        repeat rewrite (Rmult_comm (sin (θ * / 2)));
        repeat rewrite <- Rmult_assoc;
        repeat rewrite <- Rmult_plus_distr_r).
  (* all the cases are about the same; just setting up applications of
     cos_minus/sin_minus and simplifying *)
  all: repeat rewrite <- cos_minus.
  3: (rewrite (Rmult_comm (cos ϕ));
      rewrite <- (Ropp_mult_distr_l (sin ϕ));
      rewrite (Rmult_comm (sin ϕ));
      rewrite <- Rminus_unfold).
  5: (rewrite (Rmult_comm _ (cos ϕ));
      rewrite (Rmult_comm _ (sin ϕ));
      rewrite <- Ropp_mult_distr_r;
      rewrite <- Rminus_unfold).
  all: try rewrite <- sin_minus.
  all: autorewrite with R_db.
  all: repeat rewrite Rplus_opp_r.
  all: try (rewrite Ropp_plus_distr;
            repeat rewrite <- Rplus_assoc;
            rewrite Rplus_opp_r).
  all: try (rewrite (Rplus_comm ϕ λ);
            rewrite Rplus_assoc;
            rewrite Rplus_opp_r).
  all: (autorewrite with R_db;
        autorewrite with trig_db;
        autorewrite with R_db).
  all: try lra.
  all: try (replace (cos (θ * / 2) * cos (θ * / 2))%R with ((cos (θ * / 2))²) by easy;
            replace (sin (θ * / 2) * sin (θ * / 2))%R with ((sin (θ * / 2))²) by easy).
  1: rewrite Rplus_comm.
  all: try (rewrite sin2_cos2; reflexivity).
  (* two weird left-over cases *)
  all: (destruct ((x =? y) && (S (S x) <? 2)) eqn:E;
        try reflexivity).
  apply andb_prop in E as [_ E].
  apply Nat.ltb_lt in E; lia.
Qed.

Lemma x_rotation_unitary : forall θ, @WF_Unitary 2 (x_rotation θ).
Proof. intros. rewrite <- Rx_rotation. apply rotation_unitary. Qed.

Lemma y_rotation_unitary : forall θ, @WF_Unitary 2 (y_rotation θ).
Proof. intros. rewrite <- Ry_rotation. apply rotation_unitary. Qed.

(* caused errors so commenting out for now:

 Lemma control_unitary : forall n (A : Matrix n n),
                          WF_Unitary A -> WF_Unitary (control A).
Proof.
  intros n A H.
  destruct H as [WF U].
  split; auto with wf_db.
  unfold control, adjoint, Mmult, I.
  prep_matrix_equality.
  simpl.
  bdestruct (x =? y).
  - subst; simpl.
    rewrite Csum_sum.
    bdestruct (y <? n + (n + 0)).
    + bdestruct (n <=? y).
      * rewrite Csum_0_bounded. Csimpl.
        rewrite (Csum_eq _ (fun x => A x (y - n)%nat ^* * A x (y - n)%nat)).
        ++ unfold control, adjoint, Mmult, I in U.
           rewrite Nat.add_0_r.
           eapply (equal_f) in U.
           eapply (equal_f) in U.
           rewrite U.
           rewrite Nat.eqb_refl. simpl.
           bdestruct (y - n <? n).
           easy.
        ++ apply functional_extensionality. intros x.
           bdestruct (n + x <? n).
           bdestruct (n <=? n + x).
           rewrite minus_plus.
           easy.
        ++ intros x L.
           bdestruct (y =? x).
           rewrite andb_false_r.
           bdestructΩ (n <=? x).
           simpl. lca.
      * rewrite (Csum_unique 1).
        rewrite Csum_0_bounded.
        ++ lca.
        ++ intros.
           rewrite andb_false_r.
           bdestruct (n + x <? n).
           simpl.
           lca.
        ++ exists y.
           repeat rewrite andb_false_r.
           split. easy.
           split.
           rewrite Nat.eqb_refl.
           bdestructΩ (y <? n).
           simpl. lca.
           intros x Ne.
           bdestruct (y =? x ).
           repeat rewrite andb_false_r.
           lca.
    + rewrite 2 Csum_0_bounded; [lca| |].
      * intros x L.
        rewrite WF by (right; lia).
        bdestructΩ (n + x <? n).
        bdestructΩ (n <=? n + x).
        bdestructΩ (n <=? y).
        lca.
      * intros x L.
        bdestructΩ (y =? x).
        rewrite andb_false_r.
        bdestructΩ (n <=? x).
        simpl. lca.
  - simpl.
    rewrite Csum_sum.
    bdestructΩ (y <? n + (n + 0)).
    + bdestructΩ (n <=? y).
      * rewrite Csum_0_bounded. Csimpl.
        bdestructΩ (n <=? x).
        rewrite (Csum_eq _ (fun z => A z (x - n)%nat ^* * A z (y - n)%nat)).
        ++ unfold control, adjoint, Mmult, I in U.
           rewrite Nat.add_0_r.
           eapply (equal_f) in U.
           eapply (equal_f) in U.
           rewrite U.
           bdestructΩ (x - n =? y - n).
           simpl.
           easy.
        ++ apply functional_extensionality. intros z.
           bdestructΩ (n + z <? n).
           bdestructΩ (n <=? n + z).
           rewrite minus_plus.
           easy.
        ++ rewrite Csum_0. easy.
           intros z.
           bdestructΩ (n + z <? n).
           rewrite andb_false_r.
           Csimpl. easy.
        ++ intros z L.
           bdestructΩ (z <? n).
           bdestructΩ (n <=? z).
           bdestructΩ (x =? z); bdestructΩ (y =? z); try lca.
      * bdestructΩ (n <=? x).
        ++ rewrite Csum_0_bounded.
           rewrite Csum_0_bounded. lca.
           ** intros z L.
              bdestructΩ (n + z <? n).
              rewrite andb_false_r.
              lca.
           ** intros z L.
              bdestructΩ (z <? n).
              rewrite andb_false_r.
              bdestructΩ (x =? z); bdestructΩ (y =? z); try lca.
              bdestructΩ (n <=? z).
              lca.
        ++ rewrite 2 Csum_0_bounded; [lca| |].
           ** intros z L.
              rewrite andb_false_r.
              bdestructΩ (x =? n + z); bdestructΩ (y =? n + z); rewrite andb_false_r; lca.
           ** intros z L.
              rewrite andb_false_r.
              bdestructΩ (x =? z); bdestructΩ (y =? z); rewrite andb_false_r; lca.
    + rewrite 2 Csum_0_bounded; [lca| |].
      * intros z L.
        bdestructΩ (n + z <? n).
        bdestructΩ (n <=? n + z).
        bdestructΩ (n <=? y).
        rewrite (WF _ (y-n)%nat) by (right; lia).
        lca.
      * intros z L.
        bdestructΩ (y =? z).
        rewrite andb_false_r.
        rewrite (WF _ (y-n)%nat) by (right; lia).
        destruct ((n <=? z) && (n <=? y)); lca.
Qed. *)

Lemma transpose_unitary : forall n (A : Matrix n n), WF_Unitary A -> WF_Unitary (A†).
Proof.
  intros.
  simpl.
  split.
  + destruct H; auto with wf_db.
  + unfold WF_Unitary in *.
    rewrite adjoint_involutive.
    destruct H as [H H0].
    apply Minv_left in H0 as [_ S]; auto with wf_db.
Qed.

Lemma cnot_unitary : WF_Unitary cnot.
Proof.
  split.
  apply WF_cnot.
  unfold Mmult, I.
  prep_matrix_equality.
  do 4 (try destruct x; try destruct y; try lca).
  replace ((S (S (S (S x))) <? 4)) with (false) by reflexivity.
  rewrite andb_false_r.
  lca.
Qed.

Lemma id_unitary : forall n, WF_Unitary (I n).
Proof.
  split.
  apply WF_I.
  unfold WF_Unitary.
  rewrite id_adjoint_eq.
  apply Mmult_1_l.
  apply WF_I.
Qed.

Lemma swap_unitary : WF_Unitary swap.
Proof.
  split.
  apply WF_swap.
  unfold WF_Unitary, Mmult, I.
  prep_matrix_equality.
  do 4 (try destruct x; try destruct y; try lca).
  replace ((S (S (S (S x))) <? 4)) with (false) by reflexivity.
  rewrite andb_false_r.
  lca.
Qed.

Lemma zero_not_unitary : forall n, ~ (WF_Unitary (@Zero (2^n) (2^n))).
Proof.
  intros n.
  intros F.
  destruct F as [_ U].
  apply (f_equal2_inv 0 0)%nat in U.
  revert U.
  rewrite Mmult_0_r.
  unfold I, Zero.
  simpl.
  bdestruct (0 <? 2 ^ n).
  intros F. inversion F. lra.
  specialize (pow_positive 2 n) as P.
  lia.
Qed.

Lemma kron_unitary : forall {m n} (A : Matrix m m) (B : Matrix n n),
  WF_Unitary A -> WF_Unitary B -> WF_Unitary (A ⊗ B).
Proof.
  intros m n A B [WFA UA] [WFB UB].
  unfold WF_Unitary in *.
  split.
  auto with wf_db.
  rewrite kron_adjoint.
  rewrite kron_mixed_product.
  rewrite UA, UB.
  rewrite id_kron.
  easy.
Qed.

Lemma Mmult_unitary : forall (n : nat) (A : Square n) (B : Square n),
  WF_Unitary A ->
  WF_Unitary B ->
  WF_Unitary (A × B).
Proof.
  intros n A B [WFA UA] [WFB UB].
  split.
  auto with wf_db.
  Msimpl.
  rewrite Mmult_assoc.
  rewrite <- (Mmult_assoc A†).
  rewrite UA.
  Msimpl.
  apply UB.
Qed.

(********************)
(* Self-adjointness *)
(********************)

(* Maybe change to "Hermitian?" *)

Definition id_sa := id_adjoint_eq.

Lemma hadamard_sa : hadamard† = hadamard.
Proof.
  prep_matrix_equality.
  repeat (try destruct x; try destruct y; try lca; trivial).
Qed.

Lemma σx_sa : σx† = σx.
Proof.
  prep_matrix_equality.
  repeat (try destruct x; try destruct y; try lca; trivial).
Qed.

Lemma σy_sa : σy† = σy.
Proof.
  prep_matrix_equality.
  repeat (try destruct x; try destruct y; try lca; trivial).
Qed.

Lemma σz_sa : σz† = σz.
Proof.
  prep_matrix_equality.
  repeat (try destruct x; try destruct y; try lca; trivial).
Qed.

Lemma cnot_sa : cnot† = cnot.
Proof.
  prep_matrix_equality.
  repeat (try destruct x; try destruct y; try lca; trivial).
Qed.

Lemma swap_sa : swap† = swap.
Proof.
  prep_matrix_equality.
  repeat (try destruct x; try destruct y; try lca; trivial).
Qed.

Lemma control_adjoint : forall n (U : Square n), (control U)† = control (U†).
Proof.
  intros n U.
  unfold control, adjoint.
  prep_matrix_equality.
  rewrite Nat.eqb_sym.
  bdestruct (y =? x).
  - subst.
    bdestruct (x <? n); bdestruct (n <=? x); try lia; simpl; lca.
  - rewrite 2 andb_false_r.
    rewrite andb_comm.
    rewrite (if_dist _ _ _ Cconj).
    rewrite Cconj_0.
    reflexivity.
Qed.

Lemma control_sa : forall (n : nat) (A : Square n),
    A† = A -> (control A)† = (control A).
Proof.
  intros n A H.
  rewrite control_adjoint.
  rewrite H.
  easy.
Qed.

Lemma phase_adjoint : forall ϕ, (phase_shift ϕ)† = phase_shift (-ϕ).
Proof.
  intros ϕ.
  unfold phase_shift, adjoint.
  prep_matrix_equality.
  destruct_m_eq; try lca.
  unfold Cexp, Cconj.
  rewrite cos_neg, sin_neg.
  easy.
Qed.

(* x and y rotation adjoints aren't x and rotations? *)

Lemma rotation_adjoint : forall θ ϕ λ, (rotation θ ϕ λ)† = rotation (-θ) (-λ) (-ϕ).
Proof.
  intros.
  unfold rotation, adjoint.
  prep_matrix_equality.
  destruct_m_eq; try lca;
  unfold Cexp, Cconj;
  apply injective_projections; simpl;
  try rewrite <- Ropp_plus_distr;
  autorewrite with R_db;
  autorewrite with trig_db;
  try rewrite (Rplus_comm λ ϕ);
  autorewrite with R_db;
  reflexivity.
Qed.

Lemma braqubit0_sa : ∣0⟩⟨0∣† = ∣0⟩⟨0∣. Proof. lma. Qed.
Lemma braqubit1_sa : ∣1⟩⟨1∣† = ∣1⟩⟨1∣. Proof. lma. Qed.

Hint Rewrite hadamard_sa σx_sa σy_sa σz_sa cnot_sa swap_sa braqubit1_sa braqubit0_sa control_adjoint phase_adjoint rotation_adjoint : Q_db.

(* Rather use control_adjoint :
Hint Rewrite control_sa using (autorewrite with M_db; reflexivity) : M_db. *)

Lemma cnot_decomposition : ∣1⟩⟨1∣ ⊗ σx .+ ∣0⟩⟨0∣ ⊗ I 2 = cnot.
Proof. solve_matrix. Qed.

Lemma notc_decomposition : σx ⊗ ∣1⟩⟨1∣ .+ I 2 ⊗ ∣0⟩⟨0∣ = notc.
Proof. solve_matrix. Qed.

(*********************)
(** ** Phase Lemmas **)
(*********************)

Lemma phase_0 : phase_shift 0 = I 2.
Proof.
  unfold phase_shift, I.
  rewrite Cexp_0.
  solve_matrix.
Qed.

Lemma phase_2pi : phase_shift (2 * PI) = I 2.
  unfold phase_shift, I.
  rewrite Cexp_2PI.
  solve_matrix.
Qed.

Lemma phase_pi : phase_shift PI = σz.
Proof.
  unfold phase_shift, σz.
  rewrite Cexp_PI.
  replace (RtoC (-1)) with (Copp (RtoC 1)) by lca.
  reflexivity.
Qed.

Lemma phase_neg_pi : phase_shift (-PI) = σz.
Proof.
  unfold phase_shift, σz.
  rewrite Cexp_neg.
  rewrite Cexp_PI.
  replace (/ -1) with (Copp (RtoC 1)) by lca.
  reflexivity.
Qed.

Lemma phase_mul : forall θ θ', phase_shift θ × phase_shift θ' = phase_shift (θ + θ').
Proof.
  intros. solve_matrix. rewrite Cexp_add. reflexivity.
Qed.

(* Old, can probably remove *)
Lemma phase_PI4_m8 : forall k,
  phase_shift (IZR k * PI / 4) = phase_shift (IZR (k - 8) * PI / 4).
Proof.
  intros. unfold phase_shift. rewrite Cexp_PI4_m8. reflexivity.
Qed.

Lemma phase_mod_2PI : forall k, phase_shift (IZR k * PI) = phase_shift (IZR (k mod 2) * PI).
Proof.
  intros. unfold phase_shift. rewrite Cexp_mod_2PI. reflexivity.
Qed.

Lemma phase_mod_2PI_scaled : forall (k sc : Z),
  sc <> 0%Z ->
  phase_shift (IZR k * PI / IZR sc) = phase_shift (IZR (k mod (2 * sc)) * PI / IZR sc).
Proof.
  intros. unfold phase_shift. rewrite Cexp_mod_2PI_scaled; easy.
Qed.

Hint Rewrite phase_0 phase_2pi phase_pi phase_neg_pi : Q_db.

(*****************************)
(* Positive Semidefiniteness *)
(*****************************)

Definition positive_semidefinite {n} (A : Square n) : Prop :=
  forall (z : Vector n), WF_Matrix z -> fst ((z† × A × z) O O) >= 0.

Lemma pure_psd : forall (n : nat) (ϕ : Vector n), (WF_Matrix ϕ) -> positive_semidefinite (ϕ × ϕ†).
Proof.
  intros n ϕ WFϕ z WFZ.
  repeat rewrite Mmult_assoc.
  remember (ϕ† × z) as ψ.
  repeat rewrite <- Mmult_assoc.
  rewrite <- (adjoint_involutive _ _ ϕ).
  rewrite <- Mmult_adjoint.
  rewrite <- Heqψ.
  unfold Mmult. simpl.
  rewrite <- Ropp_mult_distr_l.
  rewrite Rplus_0_l.
  unfold Rminus.
  rewrite Ropp_involutive.
  replace (fst (z 1%nat 0%nat) * fst (z 1%nat 0%nat))%R with ((fst (z 1%nat 0%nat))²) by easy.
  replace (snd (z 1%nat 0%nat) * snd (z 1%nat 0%nat))%R with ((snd (z 1%nat 0%nat))²) by easy.
  apply Rle_ge.
  apply Rplus_le_le_0_compat; apply Rle_0_sqr.
Qed.

Lemma braket0_psd : positive_semidefinite ∣0⟩⟨0∣.
Proof. apply pure_psd. auto with wf_db. Qed.

Lemma braket1_psd : positive_semidefinite ∣1⟩⟨1∣.
Proof. apply pure_psd. auto with wf_db. Qed.

Lemma H0_psd : positive_semidefinite (hadamard × ∣0⟩⟨0∣ × hadamard).
Proof.
  repeat rewrite Mmult_assoc.
  rewrite <- hadamard_sa at 2.
  rewrite <- Mmult_adjoint.
  repeat rewrite <- Mmult_assoc.
  apply pure_psd.
  auto with wf_db.
Qed.

(*************************)
(* Pure and Mixed States *)
(*************************)

Notation Density n := (Matrix n n) (only parsing).

Definition Classical {n} (ρ : Density n) := forall i j, i <> j -> ρ i j = 0.

Definition Pure_State_Vector {n} (φ : Vector n): Prop :=
  WF_Matrix φ /\ φ† × φ = I  1.

Definition Pure_State {n} (ρ : Density n) : Prop :=
  exists φ, Pure_State_Vector φ /\ ρ = φ × φ†.

Inductive Mixed_State {n} : Matrix n n -> Prop :=
| Pure_S : forall ρ, Pure_State ρ -> Mixed_State ρ
| Mix_S : forall (p : R) ρ1 ρ2, 0 < p < 1 -> Mixed_State ρ1 -> Mixed_State ρ2 ->
                                       Mixed_State (p .* ρ1 .+ (1-p)%R .* ρ2).

Lemma WF_Pure : forall {n} (ρ : Density n), Pure_State ρ -> WF_Matrix ρ.
Proof. intros. destruct H as [φ [[WFφ IP1] Eρ]]. rewrite Eρ. auto with wf_db. Qed.
Hint Resolve WF_Pure : wf_db.

Lemma WF_Mixed : forall {n} (ρ : Density n), Mixed_State ρ -> WF_Matrix ρ.
Proof. induction 1; auto with wf_db. Qed.
Hint Resolve WF_Mixed : wf_db.

Lemma pure0 : Pure_State ∣0⟩⟨0∣.
Proof. exists ∣0⟩. intuition. split. auto with wf_db. solve_matrix. Qed.

Lemma pure1 : Pure_State ∣1⟩⟨1∣.
Proof. exists ∣1⟩. intuition. split. auto with wf_db. solve_matrix. Qed.

Lemma pure_id1 : Pure_State (I  1).
Proof. exists (I  1). split. split. auto with wf_db. solve_matrix. solve_matrix. Qed.

Lemma pure_dim1 : forall (ρ : Square 1), Pure_State ρ -> ρ = I  1.
Proof.
  intros.
  assert (H' := H).
  apply WF_Pure in H'.
  destruct H as [φ [[WFφ IP1] Eρ]].
  apply Minv_flip in IP1; auto with wf_db.
  rewrite Eρ; easy.
Qed.

Lemma pure_state_kron : forall m n (ρ : Square m) (φ : Square n),
  Pure_State ρ -> Pure_State φ -> Pure_State (ρ ⊗ φ).
Proof.
  intros m n ρ φ [u [[WFu Pu] Eρ]] [v [[WFv Pv] Eφ]].
  exists (u ⊗ v).
  split; [split |].
  - replace (S O) with (S O * S O)%nat by reflexivity.
    apply WF_kron; auto.
  - Msimpl. rewrite Pv, Pu. Msimpl. easy.
  - Msimpl. subst. easy.
Qed.

Lemma mixed_state_kron : forall m n (ρ : Square m) (φ : Square n),
  Mixed_State ρ -> Mixed_State φ -> Mixed_State (ρ ⊗ φ).
Proof.
  intros m n ρ φ Mρ Mφ.
  induction Mρ.
  induction Mφ.
  - apply Pure_S. apply pure_state_kron; easy.
  - rewrite kron_plus_distr_l.
    rewrite 2 Mscale_kron_dist_r.
    apply Mix_S; easy.
  - rewrite kron_plus_distr_r.
    rewrite 2 Mscale_kron_dist_l.
    apply Mix_S; easy.
Qed.

Lemma pure_state_trace_1 : forall {n} (ρ : Density n), Pure_State ρ -> trace ρ = 1.
Proof.
  intros n ρ [u [[WFu Uu] E]].
  subst.
  clear -Uu.
  unfold trace.
  unfold Mmult, adjoint in *.
  simpl in *.
  match goal with
    [H : ?f = ?g |- _] => assert (f O O = g O O) by (rewrite <- H; easy)
  end.
  unfold I in H; simpl in H.
  rewrite <- H.
  apply Csum_eq.
  apply functional_extensionality.
  intros x.
  rewrite Cplus_0_l, Cmult_comm.
  easy.
Qed.

Lemma mixed_state_trace_1 : forall {n} (ρ : Density n), Mixed_State ρ -> trace ρ = 1.
Proof.
  intros n ρ H.
  induction H.
  - apply pure_state_trace_1. easy.
  - rewrite trace_plus_dist.
    rewrite 2 trace_mult_dist.
    rewrite IHMixed_State1, IHMixed_State2.
    lca.
Qed.

(* The following two lemmas say that for any mixed states, the elements along the
   diagonal are real numbers in the [0,1] interval. *)

Lemma mixed_state_diag_in01 : forall {n} (ρ : Density n) i , Mixed_State ρ ->
                                                        0 <= fst (ρ i i) <= 1.
Proof.
  intros.
  induction H.
  - destruct H as [φ [[WFφ IP1] Eρ]].
    destruct (lt_dec i n).
    2: rewrite Eρ; unfold Mmult, adjoint; simpl; rewrite WFφ; simpl; [lra|lia].
    rewrite Eρ.
    unfold Mmult, adjoint in *.
    simpl in *.
    rewrite Rplus_0_l.
    match goal with
    [H : ?f = ?g |- _] => assert (f O O = g O O) by (rewrite <- H; easy)
    end.
    unfold I in H. simpl in H. clear IP1.
    match goal with
    [ H : ?x = ?y |- _] => assert (H': fst x = fst y) by (rewrite H; easy); clear H
    end.
    simpl in H'.
    rewrite <- H'.
    split.
    + unfold Rminus. rewrite <- Ropp_mult_distr_r. rewrite Ropp_involutive.
      rewrite <- Rplus_0_r at 1.
      apply Rplus_le_compat; apply Rle_0_sqr.
    + match goal with
      [ |- ?x <= fst (Csum ?f ?m)] => specialize (Csum_member_le f n) as res
      end.
      simpl in *.
      unfold Rminus in *.
      Search (_ * - _)%R.
      rewrite <- Ropp_mult_distr_r.
      rewrite Ropp_mult_distr_l.
      apply res with (x := i); trivial.
      intros x.
      unfold Rminus. rewrite <- Ropp_mult_distr_l. rewrite Ropp_involutive.
      rewrite <- Rplus_0_r at 1.
      apply Rplus_le_compat; apply Rle_0_sqr.
  - simpl.
    repeat rewrite Rmult_0_l.
    repeat rewrite Rminus_0_r.
    split.
    assert (0 <= p * fst (ρ1 i i)).
      apply Rmult_le_pos; lra.
    assert (0 <= (1 - p) * fst (ρ2 i i)).
      apply Rmult_le_pos; lra.
    lra.
    assert (p * fst (ρ1 i i) <= p)%R.
      rewrite <- Rmult_1_r.
      apply Rmult_le_compat_l; lra.
    assert ((1 - p) * fst (ρ2 i i) <= (1-p))%R.
      rewrite <- Rmult_1_r.
      apply Rmult_le_compat_l; lra.
    lra.
Qed.

Lemma mixed_state_diag_real : forall {n} (ρ : Density n) i , Mixed_State ρ ->
                                                        snd (ρ i i) = 0.
Proof.
  intros.
  induction H.
  + unfold Pure_State in H.
  - destruct H as [φ [[WFφ IP1] Eρ]].
    rewrite Eρ.
    simpl.
    lra.
  + simpl.
    rewrite IHMixed_State1, IHMixed_State2.
    repeat rewrite Rmult_0_r, Rmult_0_l.
    lra.
Qed.

Lemma mixed_dim1 : forall (ρ : Square 1), Mixed_State ρ -> ρ = I  1.
Proof.
  intros.
  induction H.
  + apply pure_dim1; trivial.
  + rewrite IHMixed_State1, IHMixed_State2.
    prep_matrix_equality.
    lca.
Qed.

(* Useful to be able to normalize vectors *)

Definition norm {n} (ψ : Vector n) : R :=
  sqrt (fst ((ψ† × ψ) O O)).

Lemma norm_real : forall {n} (v : Vector n), snd ((v† × v) 0%nat 0%nat) = 0%R.
Proof. intros. unfold Mmult, adjoint.
       rewrite Csum_snd_0. easy.
       intros. rewrite Cmult_comm.
       rewrite Cmult_conj_real.
       reflexivity.
Qed.

Definition normalize {n} (ψ : Vector n) :=
  / (norm ψ) .* ψ.

Lemma inner_product_ge_0 : forall {d} (ψ : Vector d),
  0 <= fst ((ψ† × ψ) O O).
Proof.
  intros.
  unfold Mmult, adjoint.
  apply Csum_ge_0.
  intro.
  rewrite <- Cmod_sqr.
  simpl.
  autorewrite with R_db.
  apply Rmult_le_pos; apply Cmod_ge_0.
Qed.

Lemma norm_scale : forall {n} c (v : Vector n), norm (c .* v) = ((Cmod c) * norm v)%R.
Proof.
  intros n c v.
  unfold norm.
  rewrite Mscale_adj.
  distribute_scale.
  unfold scale.
  simpl.
  replace (fst c * snd c + - snd c * fst c)%R with 0%R.
  autorewrite with R_db C_db.
  replace (fst c * fst c)%R with (fst c ^ 2)%R by lra.
  replace (snd c * snd c)%R with (snd c ^ 2)%R by lra.
  rewrite sqrt_mult_alt.
  reflexivity.
  apply Rplus_le_le_0_compat; apply pow2_ge_0.
  lra.
Qed.

Lemma div_real : forall (c : C),
  snd c = 0 -> snd (/ c) = 0.
Proof. intros.
       unfold Cinv.
       simpl.
       rewrite H. lra.
Qed.

Lemma Cmod_real : forall (c : C),
  fst c >= 0 -> snd c = 0 -> Cmod c = fst c.
Proof. intros.
       unfold Cmod.
       rewrite H0.
       simpl.
       autorewrite with R_db.
       apply sqrt_square.
       lra.
Qed.

Lemma normalized_norm_1 : forall {n} (v : Vector n),
  norm v <> 0 -> norm (normalize v) = 1.
Proof. intros.
       unfold normalize.
       distribute_scale.
       rewrite norm_scale.
       rewrite Cmod_real.
       simpl.
       autorewrite with R_db.
       rewrite Rmult_comm.
       rewrite Rinv_mult_distr; try easy.
       rewrite <- Rmult_comm.
       rewrite <- Rmult_assoc.
       rewrite Rinv_r; try easy.
       autorewrite with R_db.
       reflexivity.
       unfold Cinv.
       simpl.
       autorewrite with R_db.
       rewrite Rinv_mult_distr; try easy.
       rewrite <- Rmult_assoc.
       rewrite Rinv_r; try easy.
       autorewrite with R_db.
       assert (H' : norm v >= 0).
       { assert (H'' : 0 <= norm v).
         { apply sqrt_pos. }
         lra. }
       destruct H' as [H0 | H0].
       left.
       assert (H1 : 0 < norm v). { lra. }
       apply Rinv_0_lt_compat in H1.
       lra. easy.
       apply div_real.
       easy.
Qed.

(** Density matrices and superoperators **)

Definition Superoperator m n := Density m -> Density n.

Definition WF_Superoperator {m n} (f : Superoperator m n) :=
  (forall ρ, Mixed_State ρ -> Mixed_State (f ρ)).

Definition super {m n} (M : Matrix m n) : Superoperator n m := fun ρ =>
  M × ρ × M†.

Lemma super_I : forall n ρ,
      WF_Matrix ρ ->
      super (I n) ρ = ρ.
Proof.
  intros.
  unfold super.
  Msimpl.
  reflexivity.
Qed.

Lemma WF_super : forall  m n (U : Matrix m n) (ρ : Square n),
  WF_Matrix U -> WF_Matrix ρ -> WF_Matrix (super U ρ).
Proof.
  unfold super.
  auto with wf_db.
Qed.

Hint Resolve WF_super : wf_db.

Lemma super_outer_product : forall m (φ : Matrix m 1) (U : Matrix m m),
    super U (outer_product φ φ) = outer_product (U × φ) (U × φ).
Proof.
  intros. unfold super, outer_product.
  autorewrite with M_db Q_db.
  repeat rewrite Mmult_assoc. reflexivity.
Qed.

Definition compose_super {m n p} (g : Superoperator n p) (f : Superoperator m n)
                      : Superoperator m p := fun ρ => g (f ρ).

Lemma WF_compose_super : forall m n p (g : Superoperator n p) (f : Superoperator m n)
  (ρ : Square m),
  WF_Matrix ρ ->
  (forall A, WF_Matrix A -> WF_Matrix (f A)) ->
  (forall A, WF_Matrix A -> WF_Matrix (g A)) ->
  WF_Matrix (compose_super g f ρ).
Proof.
  unfold compose_super.
  auto.
Qed.

Hint Resolve WF_compose_super : wf_db.

Lemma compose_super_correct : forall {m n p}
                              (g : Superoperator n p) (f : Superoperator m n),
      WF_Superoperator g ->
      WF_Superoperator f ->
      WF_Superoperator (compose_super g f).
Proof.
  intros m n p g f pf_g pf_f.
  unfold WF_Superoperator.
  intros ρ mixed.
  unfold compose_super.
  apply pf_g. apply pf_f. auto.
Qed.

Definition sum_super {m n} (f g : Superoperator m n) : Superoperator m n :=
  fun ρ => (1/2)%R .* f ρ .+ (1 - 1/2)%R .* g ρ.

Lemma sum_super_correct : forall m n (f g : Superoperator m n),
      WF_Superoperator f -> WF_Superoperator g -> WF_Superoperator (sum_super f g).
Proof.
  intros m n f g wf_f wf_g ρ pf_ρ.
  unfold sum_super.
  set (wf_f' := wf_f _ pf_ρ).
  set (wf_g' := wf_g _ pf_ρ).
  apply (Mix_S (1/2) (f ρ) (g ρ)); auto.
  lra.
Qed.

(* Maybe we shouldn't call these superoperators? Neither is trace-preserving *)
Definition SZero {m n} : Superoperator m n := fun ρ => Zero.
Definition Splus {m n} (S T : Superoperator m n) : Superoperator m n :=
  fun ρ => S ρ .+ T ρ.

(* These are *)
Definition new0_op : Superoperator 1 2 := super ∣0⟩.
Definition new1_op : Superoperator 1 2 := super ∣1⟩.
Definition meas_op : Superoperator 2 2 := Splus (super ∣0⟩⟨0∣) (super ∣1⟩⟨1∣).
Definition discard_op : Superoperator 2 1 := Splus (super ⟨0∣) (super ⟨1∣).

Lemma pure_unitary : forall {n} (U ρ : Matrix n n),
  WF_Unitary U -> Pure_State ρ -> Pure_State (super U ρ).
Proof.
  intros n U ρ [WFU H] [φ [[WFφ IP1] Eρ]].
  rewrite Eρ.
  exists (U × φ).
  split.
  - split; auto with wf_db.
    rewrite (Mmult_adjoint U φ).
    rewrite Mmult_assoc.
    rewrite <- (Mmult_assoc (U†)).
    rewrite H, Mmult_1_l, IP1; easy.
  - unfold super.
    rewrite (Mmult_adjoint U φ).
    repeat rewrite Mmult_assoc.
    reflexivity.
Qed.

Lemma mixed_unitary : forall {n} (U ρ : Matrix n n),
  WF_Unitary U -> Mixed_State ρ -> Mixed_State (super U ρ).
Proof.
  intros n U ρ H M.
  induction M.
  + apply Pure_S.
    apply pure_unitary; trivial.
  + unfold WF_Unitary, super in *.
    rewrite Mmult_plus_distr_l.
    rewrite Mmult_plus_distr_r.
    rewrite 2 Mscale_mult_dist_r.
    rewrite 2 Mscale_mult_dist_l.
    apply Mix_S; trivial.
Qed.

Lemma super_unitary_correct : forall {n} (U : Matrix n n),
  WF_Unitary U -> WF_Superoperator (super U).
Proof.
  intros n U H ρ Mρ.
  apply mixed_unitary; easy.
Qed.

Lemma compose_super_assoc : forall {m n p q}
      (f : Superoperator m n) (g : Superoperator n p) (h : Superoperator p q),
      compose_super (compose_super f g) h
    = compose_super f (compose_super g h).
Proof. easy. Qed.

Lemma compose_super_eq : forall {m n p} (A : Matrix m n) (B : Matrix n p),
      compose_super (super A) (super B) = super (A × B).
Proof.
  intros.
  unfold compose_super, super.
  apply functional_extensionality. intros ρ.
  rewrite Mmult_adjoint.
  repeat rewrite Mmult_assoc.
  reflexivity.
Qed.

(* This is compose_super_correct
Lemma WF_Superoperator_compose : forall m n p (s : Superoperator n p) (s' : Superoperator m n),
    WF_Superoperator s ->
    WF_Superoperator s' ->
    WF_Superoperator (compose_super s s').
Proof.
  unfold WF_Superoperator.
  intros m n p s s' H H0 ρ H1.
  unfold compose_super.
  apply H.
  apply H0.
  easy.
Qed.
*)

(**************)
(* Automation *)
(**************)

Ltac Qsimpl := try restore_dims; autorewrite with M_db_light M_db Q_db.

(****************************************)
(* Tests and Lemmas about swap matrices *)
(****************************************)

Lemma swap_spec : forall (q q' : Vector 2), WF_Matrix q ->
                                       WF_Matrix q' ->
                                       swap × (q ⊗ q') = q' ⊗ q.
Proof.
  intros q q' WF WF'.
  solve_matrix.
  - destruct y. lca.
    rewrite WF by lia.
    rewrite (WF' O (S y)) by lia.
    lca.
  - destruct y. lca.
    rewrite WF by lia.
    rewrite (WF' O (S y)) by lia.
    lca.
  - destruct y. lca.
    rewrite WF by lia.
    rewrite (WF' 1%nat (S y)) by lia.
    lca.
  - destruct y. lca.
    rewrite WF by lia.
    rewrite (WF' 1%nat (S y)) by lia.
    lca.
Qed.

Hint Rewrite swap_spec using (auto 100 with wf_db) : Q_db.

Example swap_to_0_test_24 : forall (q0 q1 q2 q3 : Vector 2),
  WF_Matrix q0 -> WF_Matrix q1 -> WF_Matrix q2 -> WF_Matrix q3 ->
  swap_to_0 4 2 × (q0 ⊗ q1 ⊗ q2 ⊗ q3) = (q2 ⊗ q1 ⊗ q0 ⊗ q3).
Proof.
  intros q0 q1 q2 q3 WF0 WF1 WF2 WF3.
  unfold swap_to_0, swap_to_0_aux.
  simpl.
  rewrite Mmult_assoc.
  repeat rewrite Mmult_assoc.
  rewrite (kron_assoc q0 q1). Qsimpl.
  replace 4%nat with (2*2)%nat by reflexivity.
  repeat rewrite kron_assoc.
  restore_dims.
  rewrite <- (kron_assoc q0 q2). Qsimpl.
  rewrite (kron_assoc q2). Qsimpl.
  rewrite <- kron_assoc. Qsimpl.
  repeat rewrite <- kron_assoc.
  reflexivity.
  all : auto with wf_db.
Qed.

Lemma swap_two_base : swap_two 2 1 0 = swap.
Proof. unfold swap_two. simpl. apply kron_1_r. Qed.

Lemma swap_second_two : swap_two 3 1 2 = I 2 ⊗ swap.
Proof.
  unfold swap_two.
  simpl.
  rewrite kron_1_r.
  reflexivity.
Qed.

Lemma swap_0_2 : swap_two 3 0 2 = (I 2 ⊗ swap) × (swap ⊗ I 2) × (I 2 ⊗ swap).
Proof.
  unfold swap_two.
  simpl.
  Qsimpl.
  reflexivity.
Qed.

(*
Proposition swap_to_0_spec : forall (q q0 : Matrix 2 1) (n k : nat) (l1 l2 : list (Matrix 2 1)),
   length l1 = (k - 1)%nat ->
   length l2 = (n - k - 2)%nat ->
   @Mmult (2^n) (2^n) 1 (swap_to_0 n k) (⨂ ([q0] ++ l1 ++ [q] ++ l2)) =
     ⨂ ([q] ++ l1 ++ [q0] ++ l2).

Proposition swap_two_spec : forall (q q0 : Matrix 2 1) (n0 n1 n2 n k : nat) (l0 l1 l2 : list (Matrix 2 1)),
   length l0 = n0 ->
   length l1 = n1 ->
   length l2 = n2 ->
   n = (n0 + n1 + n2 + 2)%nat ->
   @Mmult (2^n) (2^n) 1
     (swap_two n n0 (n0+n1+1)) (⨂ (l0 ++ [q0] ++ l1 ++ [q] ++ l2)) =
     ⨂ (l0 ++ [q] ++ l1 ++ [q0] ++ l2).
*)

Example move_to_0_test_24 : forall (q0 q1 q2 q3 : Vector 2),
  WF_Matrix q0 -> WF_Matrix q1 -> WF_Matrix q2 -> WF_Matrix q3 ->
  move_to_0 4 2 × (q0 ⊗ q1 ⊗ q2 ⊗ q3) = (q2 ⊗ q0 ⊗ q1 ⊗ q3).
Proof.
  intros q0 q1 q2 q3 WF0 WF1 WF2 WF3.
  unfold move_to_0, move_to_0_aux.
  repeat rewrite Mmult_assoc.
  rewrite (kron_assoc q0 q1).
  simpl.
  restore_dims.
  replace 4%nat with (2*2)%nat by reflexivity.
  Qsimpl.
  rewrite <- kron_assoc.
  restore_dims.
  repeat rewrite (kron_assoc _ q1).
  Qsimpl.
  reflexivity.
  all : auto with wf_db.
Qed.

(* *)


From mathcomp Require Import ssreflect eqtype.
From deriving Require Import deriving.

Require Import type.

(* I tried to write the induction principle myself, but it does not work with
   deriving. *)
Module induction_try.

(* We have to manually write the right induction behaviour *)
Section induction.

Context (A : Type) (P : t A -> Type).
Context
  (H0 : forall a, P (Leaf _ a))
  (H1 : P (Node _ nil))
  (H2 : forall a l, P (Node _ l) -> P (Node _ (a::l))).

Lemma t_rect : forall x, P x.
Proof.
  refine (fix aux x :=
    match x with
    | Leaf a => H0 a
    | Node l =>
      (fix aux0 (l : list (t A)) :=
      match l with
      | nil => H1
      | cons _ _ => H2 _ _ (aux0 _)
      end) l
    end).
Defined.

Lemma list_t_rect : forall l, P (Node _ l).
Proof.
  refine (fix aux l :=
    match l with
    | nil => H1
    | cons _ _ => H2 _ _ (aux _)
    end).
Defined.

Combined Scheme t_list_t_rect from t_rect, list_t_rect.

End induction.

End induction_try.

Module induction_done_right.

(* see https://github.com/arthuraa/deriving/blob/master/tests/nested.v *)

Section induction.

Context (A : eqType).

Definition t_rect
  (P1 : t A -> Type)
  (P2 : list (t A) -> Type)
  (HL : forall a, P1 (Leaf _ a))
  (HR : forall rs, P2 rs -> P1 (Node _ rs))
  (HN : P2 nil)
  (HC : forall r, P1 r -> forall rs, P2 rs -> P2 (cons r rs))
  : forall r, P1 r :=
  fix rose_rect r :=
    let fix seq_rose_rect rs : P2 rs :=
        match rs with
        | nil => HN
        | cons r rs => HC r (rose_rect r) rs (seq_rose_rect rs)
        end in
    match r with
    | Leaf a => HL a
    | Node rs => HR rs (seq_rose_rect rs) end.

Definition list_t_rect
  (P1 : t A -> Type)
  (P2 : list (t A) -> Type)
  (HL : forall a, P1 (Leaf _ a))
  (HR : forall rs, P2 rs -> P1 (Node _ rs))
  (HN : P2 nil)
  (HC : forall r, P1 r -> forall rs, P2 rs -> P2 (cons r rs))
  : forall rs, P2 rs :=
    fix list_t_rect rs : P2 rs :=
      match rs with
      | nil => HN
      | cons r rs => HC r (t_rect _ _ HL HR HN HC r) rs (list_t_rect rs)
      end.

Combined Scheme t_list_t_rect from t_rect, list_t_rect.

Definition t_list_t_indDef := [indDef for t_list_t_rect].
Canonical t_indType := IndType (t A) t_list_t_indDef.
Definition t_eqMixin := [derive eqMixin for t A].
Canonical rose_eqType := EqType (t A) t_eqMixin.

End induction.

End induction_done_right.


Require Import MachineInt.
Require Import List.

(** Pris chez Coq 8.5. *)

Section Repeat.

  Variable A : byte.
  Fixpoint repeat (x : byte) (n: nat ) :=
    match n with
      | O => nil
      | S k => x::(repeat x k)
    end.

  Theorem repeat_length x n:
    length (repeat x n) = n.
  Proof.
    induction n as [| k Hrec]; simpl; rewrite ?Hrec; reflexivity.
  Qed.

  Theorem repeat_spec n x y:
    In y (repeat x n) -> y=x.
  Proof.
    induction n as [|k Hrec]; simpl; destruct 1; auto.
  Qed.

End Repeat.


(* Basic Propositions *)

Variables P Q R : Prop.

(* simple tautology proof *)

Theorem I : P -> P.

Proof.
  intro H.                      (* to prove P -> Q, assume P and prove Q *)
  exact H.                      (* current goal is just the assumption *)
Qed.

Definition I2 : P -> P := fun H : P => H. (* Curry-Howard *)

Theorem K : P -> (Q -> P).

Proof.
  intro H1.
  intro H2.
  exact H1.
Qed.

Theorem S : (P -> Q -> R) -> (P -> Q) -> P -> R.

Proof.
  intro pqrH.
  intro pqH.
  intro pH.
  apply pqrH.                   (* MP *)
  exact pH.
  apply pqH.                    (* MP *)
  exact pH.
Qed.


(** 1 basics **)

(** examples of dependent functions **)

Definition pick_first (a : Type) (b : Type) : Type := a.

Compute pick_first nat bool.

Definition return_7 (a : Type) (b : Type) : nat := 7.

Compute return_7 nat bool.

(** 1a identity **)

(** Definition my_id (t : Type) : t -> t := (fun a => a). **)

Definition my_id : (forall t : Type, t -> t) := (fun t a => a).

(**
Pi _{x : A} B(x) is (forall x : A, B(x))
fun is a constructor
evaluation is a desctructor
**)

Compute my_id nat 7.

Check my_id.

Theorem identity_1a : forall t : Type, t -> t.
Proof.
exact (my_id).
Show Proof.
Qed.

(** 1b composition **)

Definition my_composition : (forall a b c : Type, (b -> c) -> (a -> b) -> (a -> c))
:= (fun a b c g f av => g (f av)).

Definition add1 : nat -> nat := (fun x => x + 1).

Compute (my_composition nat nat nat add1 add1) 7.

(** 1c introducing functions **)

(**
Pi _{x : A} B(x) is (forall x : A, B(x))
**)

Definition my_type : Type := forall x : bool, nat.
Compute my_type.

(** 2 finite products **)

(** 2a unit type **)

Inductive my_unit : Set :=
    my_star : my_unit.

Definition type_to_unit : (forall t : Type, t -> my_unit) := (fun t a => my_star).

Compute type_to_unit nat 7.

(** WE WANT CODE TO VERIFY THE UNIQUENESS OF AN ARROW INTO THE UNIT TYPE **)

(** 2b products **)

Inductive my_prod (A B:Type) : Type :=
  my_pair : A -> B -> (my_prod A B).

Definition my_fst : (forall A B : Type, (my_prod A B) -> A) :=
  (fun A B p => match p with (my_pair _ _ x y) => x end).

Definition my_snd : (forall A B : Type, (my_prod A B) -> B) :=
  (fun A B p => match p with (my_pair _ _ x y) => y end).

Definition my_pair_example : my_prod nat bool := my_pair nat bool 7 true.

Compute my_fst nat bool my_pair_example.

Definition my_intermediary : (forall A B H : Type, (H -> A) -> (H -> B) ->
 (H -> my_prod A B)) := (fun A B H f g hv => my_pair A B (f hv) (g hv)).

(** Want to prove universal property **)

(** 3a Empty type **)

Inductive my_empty_set : Set :=.

Definition my_empty_function (A : Type) (x : my_empty_set) : (A : Type) :=
  match x with end.

Check my_empty_function nat.

(** 3b Coproduct type **)

Inductive my_sum (A B:Type) : Type :=
  | my_inl : A -> my_sum A B
  | my_inr : B -> my_sum A B.

Check my_inl.

Check my_inl nat bool 7.

Definition my_coproduct_inter : (forall A B H : Type, (A -> H) -> (B -> H) ->
  ((my_sum A B) -> H)) := (fun A B H f g n =>
  match n with
    | (my_inl _ _ x) => (f x)
    | (my_inr _ _ y) => (g y)
  end).

(** 4a exponential elimination rule **)

Definition expo_elim : (forall X Y : Type, (my_prod (X -> Y) X) -> Y) :=
  (fun X Y v => ((my_fst (X -> Y) X v) (my_snd (X -> Y) X v))).

(** 4b exponential introduction rule **)

Definition expo_intro : (forall A B C : Type, ((my_prod A B) -> C) ->
  (A -> (B -> C))) := (fun A B C pair_fun av bv =>
  pair_fun (my_pair A B av bv)).

(** extra **)

Inductive my_nat : Set :=
  | my_zero : my_nat
  | my_succ : my_nat -> my_nat.

(** finish representing Heyting Algebra ideas
go fo HoTT representation from book, and encode those rules
**)

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

(**
Sigma _{x : A} B(x) is like  (exists x : A, B(x))
Check ex_intro.
Check ex_proj1.
Definition my_sigma_val : (exists x : bool, (my_B x)) := ex_intro false 7.
https://coq.inria.fr/stdlib/Coq.Init.Logic.html

**)

Definition my_B : bool -> Type := fun b => match b with true => bool | false => nat end.

Check sigT.

Check existT.

Inductive my_sigT (A:Type) (P:A -> Type) : Type :=
    my_existT : forall x:A, P x -> my_sigT A P.

Definition my_sigma_val : (my_sigT bool my_B) :=  my_existT bool my_B false 7.

Definition my_projT1 (A:Type) (P:A -> Type) (x: my_sigT A P) : A := match x with
                                      | my_existT _ _ a _ => a
                                      end.

Check my_projT1.

Compute my_projT1 bool my_B my_sigma_val.

(**
beware of
Set Implicit Arguments.
in
https://coq.inria.fr/stdlib/Coq.Init.Specif.html

**)

(** *** **)
(* https://coq.inria.fr/library/Coq.Init.Datatypes.html *)

Check Empty_set.

Definition Empty_function (A : Type) (x : Empty_set) : (A : Type) :=
  match x with end.

Check Empty_function nat.

Check unit.

Check tt.

Check sum.
Check inl.

Check prod.
Check pair.
Check 7.

Definition idv (A : Type) (x : A) : A := x.

Compute idv nat 7.

Definition id_strange (t : Type) : t -> t := (fun a => a).
Compute (id_strange nat 7).


From mathcomp Require Import ssreflect.

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

Require Import logic_pred_theories.
Require Import class_set.
Require Import direct_product_theories.
Require Import binary_relation.

Inductive GraphOfBinaryRelation {U:Type} (R:BinaryRelation U) (A B: Ensemble U): Ensemble (Ensemble (Ensemble U)) :=
| Definition_of_Graph: forall (x y:U), R x y /\ (|x, y|) ∈ A × B -> (|x, y|) ∈ GraphOfBinaryRelation R A B.

Inductive DomainOfCorrespondence {U:Type} (f:Ensemble (Ensemble (Ensemble U))) : Ensemble U :=
| Definition_of_DomainOfCorrespondence: forall (x:U), x ∈ Pr1 f -> x ∈ DomainOfCorrespondence f.

Inductive RangeOfCorrespondence {U:Type} (f:Ensemble (Ensemble (Ensemble U))) : Ensemble U :=
| Definition_of_RangeOfCorrespondence: forall (y:U), y ∈ Pr2 f -> y ∈ RangeOfCorrespondence f.

Inductive ImageOfCorrespondence {U:Type} (f:Ensemble (Ensemble (Ensemble U))) (C:Ensemble U) : Ensemble U :=
  | Definition_of_ImageOfCorrespondence: forall (y:U), (exists x:U, x ∈ C /\ (|x,y|) ∈ f) -> y ∈ ImageOfCorrespondence f C.

Inductive CompoundCorrespondence {U:Type} (g f:Ensemble (Ensemble (Ensemble U))) : Ensemble (Ensemble (Ensemble U)) :=
| Definition_of_CompoundCorrespondence :
    forall (x y:U), (exists z:U, (|x,z|) ∈ f /\ (|z,y|) ∈ g) -> (|x,y|) ∈ CompoundCorrespondence g f.

Inductive TransposeOfGraph {U:Type} (f:Ensemble (Ensemble (Ensemble U))) :
    Ensemble (Ensemble (Ensemble U)) :=
| Definition_of_InverseCorrespondence :
    forall (x y: U), (|x,y|) ∈ f -> (|y,x|) ∈ TransposeOfGraph f.

(* ⥴: Unicode 2974 (RIGHTWARDS ARROW ABOVE TILDE OPERATO) *)
(* ≔ : Unicode 2254 (COLON EQUAL) *)
(* ⊦ : Unicode 22A6 (ASSERTION) *)
Notation "f ≔ R ⊦ A ⥴ B" := (f = GraphOfBinaryRelation R A B) (at level 44).

(* ∘: Unicode 2218 *)
Notation "g ∘ f" := (CompoundCorrespondence g f) (at level 45).

(* 𝕯: Unicode:1D56F, 𝕽: Unicode:1D57D *)
Notation "𝕯( f )" := (DomainOfCorrespondence f) (at level 45).
Notation "𝕽( f )" := (RangeOfCorrespondence f) (at level 45).

Notation "f ^-1" := (TransposeOfGraph f) (at level 44).

Notation "f '' A" := (ImageOfCorrespondence f A) (at level 46).

Proposition transpose_correspondence_iff:
  forall (U:Type) (x y:U) (R:BinaryRelation U) (A B:Ensemble U) (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> (|x,y|) ∈ f <-> (|y,x|) ∈ f^-1.
  Proof.
    move => U x y R A B f H.
    rewrite /iff.
    split => H0.
    split.
    apply H0.
    inversion H0.
    apply ordered_pair_swap in H1.
    rewrite H1 in H2.
    apply H2.
  Qed.

Section Correspondence.
  Variable U: Type.
  Variable R: BinaryRelation U.
  Variable A B C D: Ensemble U.

  Proposition graph_is_included_in_direct_product:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> f ⊂ A × B.
  Proof.
    move => f H.
    rewrite H => X.
    case => [x y [H0]].
    apply.
  Qed.

  Proposition domain_of_graph_is_included_in_source_set:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> 𝕯( f ) ⊂ A.
  Proof.
    move => f H x H0.
    inversion H0 as [x' H1].
    inversion H1 as [x0 [y0]].
    rewrite H in H3.
    rewrite -H4 in H3.
    inversion H3.
    inversion H6.
    rewrite H5 in H8.
    apply ordered_pair_in_direct_product_iff_and in H8.
    inversion H8.
    rewrite -H4.
    apply H9.
  Qed.

  Proposition range_of_graph_is_included_in_source_set:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> 𝕽( f ) ⊂ B.
  Proof.
    move => f H y H0.
    inversion H0 as [y' [y0 [x]]].
    rewrite H in H1.
    inversion H1 as [x1 y1 [HR H3]].
    rewrite H4 in H3.
    apply ordered_pair_in_direct_product_iff_and in H3.
    inversion H3.
    apply H6.
  Qed.

  Proposition singleton_image_to_direct_product:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> forall (x y:U), {|y|} = f '' {|x|} -> (|x,y|) ∈ f.
  Proof.
    move => f Hf x y H.
    rewrite Hf in  H.
    apply Extension in H.
    inversion H.
    rewrite Hf.
    move: (H0 y).
    case.
    apply singleton_eq_iff.
    reflexivity.
    move => y0 H2.
    inversion H2 as [x0 []].
    apply singleton_eq_iff in H3.
    rewrite -H3.
    apply H4.
  Qed.

  Theorem relation_iff_in_graph:
    forall (f:Ensemble (Ensemble (Ensemble U))) (x y:U),
      x ∈ A /\ y ∈ B /\ f ≔ R ⊦ A ⥴ B -> R x y <-> (|x,y|) ∈ f.
  Proof.
    move => f x y [HA [HB Hf]].
    rewrite /iff.
    split => H.
    rewrite Hf.
    split.
    split.
    apply H.
    apply ordered_pair_in_direct_product_iff_and.
    split.
    apply HA.
    apply HB.
    rewrite Hf in H.
    inversion H.
    inversion H1.
    apply ordered_pair_iff in H0.
    inversion H0.
    rewrite H4 H5 in H2.
    apply H2.
  Qed.

  Theorem union_of_image_of_correspondence_eq:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> f '' (C ∪ D) = f '' C ∪ f '' D.
  Proof.
    move => f H.
    apply Extensionality_Ensembles.
    split => z.
    +case => [y [x [H0 H1]]].
     inversion H0 as [x' H2|x' H2]; [left|right]; split; exists x; split.
     ++apply H2.
       apply H1.
     ++apply H2.
       apply H1.
    +case => z0; case => [y [x [H' H0]]]; split; exists x; split.
     ++left.
       apply H'.
       apply H0.
     ++right.
       apply H'.
       apply H0.
  Qed.

  Theorem and_image_of_correspondence_included:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> f '' (C ∩ D) ⊂ (f '' C ∩ f '' D).
  Proof.
    move => f H y H0.
    inversion H0 as [y' [x' [H1 H2]]].
    inversion H1.
    split; split; exists x; rewrite H6; split.
    apply H4.
    apply H2.
    apply H5.
    apply H2.
  Qed.

  Theorem included_domain_to_included_image:
    forall (f:Ensemble (Ensemble (Ensemble U))) (V W:Ensemble U),
      f ≔ R ⊦ A ⥴ B -> V ⊂ W /\ W ⊂ A -> (f '' V ⊂ f '' W).
  Proof.
    move => f V W HF.
    case => [HVW HWA] y H0.
    inversion H0 as [y0 [x [H1 H2]]].
    split.
    exists x.
    split.
    apply HVW.
    apply H1.
    apply H2.
  Qed.

  Proposition double_transpose:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> (f^-1)^-1 = f.
  Proof.
    move => f H.
    apply /Extensionality_Ensembles.
    split => Z H0.
    +inversion H0.
     rewrite transpose_correspondence_iff.
     apply H1.
     apply H.
    +rewrite H in H0.
     inversion H0.
     rewrite -H2 in H0.
     rewrite -H in H0.
     split; split.
     apply H0.
  Qed.

  Goal forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> f '' (C ∩ D) ⊂ f '' C ∩ f '' D.
  Proof.
    move => f H x H0.
    inversion H0 as [x0 [y' [H1 H2]]].
    inversion H1.
    split; split; exists y'; split.
    +apply H4.
     apply H2.
    +apply H5.
     apply H2.
  Qed.

  (* g ∘ f (D) = g(f(D)) *)
  Proposition image_compound_correspondence_eq:
    forall (F G:BinaryRelation U) (f g:Ensemble (Ensemble (Ensemble U))),
      f ≔ F ⊦ A ⥴ B /\ g ≔ G ⊦ B ⥴ C -> g ∘ f '' D = g '' (f '' D).
  Proof.
    move => F G f g.
    case => HF HG.
    apply Extensionality_Ensembles.
    split => y H.
    +inversion H as [y0 [x0 []]].
     inversion H1 as [x1 y1 [z [H3 H4]]].
     apply ordered_pair_iff in H5.
     inversion H5.
     split.
     exists z.
     split.
     ++split.
       exists x1.
       split.
       rewrite H6.
       apply H0.
       apply H3.
     ++rewrite -H7.
       apply H4.
    +inversion H as [y0 [z []]].
     inversion H0 as [y0' [x []]].
     split.
     exists x.
     split.
     apply H3.
     split.
     exists z.
     split.
     apply H4.
     apply H1.
  Qed.

  (* h ∘ (g ∘ f) = (h ∘ g) ∘ f *)
  Theorem compound_correspondence_assoc:
    forall (X Y Z W:Ensemble U) (F G H:BinaryRelation U) (f g h:Ensemble (Ensemble (Ensemble U))),
      f ≔ F ⊦ X ⥴ Y /\ g ≔ G ⊦ Y ⥴ Z /\ h ≔ H ⊦ Z ⥴ W ->
      h ∘ (g ∘ f) = (h ∘ g) ∘ f.
  Proof.
    move => X Y Z W F G H f g h.
    case => HF [HG HH].
    apply Extensionality_Ensembles.
    split => V H0.
    +inversion H0 as [x y [z0 []]].
     inversion H1 as [x0 z0' [z1 []]].
     apply ordered_pair_iff in H6.
     inversion H6.
     split.
     exists z1.
     split.
     rewrite -H7.
     apply H4.
     split.
     exists z0'.
     split.
     apply H5.
     rewrite H8.
     apply H2.
    +inversion H0 as [x y [z0 []]].
     inversion H2 as [z0' y0 [z1 []]].
     apply ordered_pair_iff in H6.
     inversion H6.
     split.
     exists z1.
     split.
     split.
     exists z0.
     split.
     apply H1.
     rewrite -H7.
     apply H4.
     rewrite -H8.
     apply H5.
  Qed.

  (* (g ∘ f)^(-1) = f^(-1) ∘ g^(-1) *)
  Theorem unfold_compound_corrsepondence_inverse:
    forall (F G:BinaryRelation U) (f g:Ensemble (Ensemble (Ensemble U))),
      f ≔ F ⊦ A ⥴ B /\ g ≔ G ⊦ B ⥴ C -> (g ∘ f) ^-1 = f ^-1 ∘ g ^-1.
  Proof.
    move => F G f g.
    case => HF HG.
    apply Extensionality_Ensembles.
    split => X H.
    -inversion H as [x y].
     inversion H0 as [x0 y0].
     inversion H2 as [z []].
     apply ordered_pair_iff in H3.
     inversion H3.
     split.
     exists z.
     split; split.
      +rewrite H7 in H5.
       apply H5.
      +rewrite H6 in H4.
       apply H4.
    -inversion H as [x y].
     inversion H0 as [z []].
     split.
     split.
     exists z.
     split.
     apply (transpose_correspondence_iff y z HF) in H3.
     apply H3.
     apply (transpose_correspondence_iff z x HG) in H2.
     apply H2.
  Qed.

  Theorem transpose_graph_keep_included:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ R ⊦ A ⥴ B -> f ⊂ A × B <-> f^-1 ⊂ B × A.
  Proof.
    move => f HF.
    rewrite HF.
    rewrite /iff.
    split => H Z H0; inversion H0 as [x y H1].
    +inversion H1 as [x0 y0].
     inversion H3.
     rewrite H4 in H6.
     apply ordered_pair_in_direct_product_iff_and in H6.
     inversion H6.
     apply ordered_pair_in_direct_product_iff_and.
     split.
     apply H8.
     apply H7.
    +inversion H1.
     apply H4.
  Qed.

End Correspondence.

Require Export class_set.
Require Export direct_product_theories.
Require Export binary_relation.


Search True.
Search False.
Search bool.

Inductive int : Set :=
  | Z  : int         (*  0      *)
  | Zp : int -> int  (*  x + 1  *)
  | Zn : int -> int. (*  x - 1  *)

Fixpoint zplus (x y:int) : int :=
  match x with
  | Z    => y              (* 0     + y = y           *)
  | Zp x => Zp (zplus x y) (* (x+1) + y = (x + y) + 1 *)
  | Zn x => Zn (zplus x y) (* (x-1) + y = (x + y) - 1 *)
  end.

Fixpoint zminus (x y:int) : int :=
  match y with
  | Z    => x               (* x - 0     = x           *)
  | Zp y => Zn (zminus x y) (* x - (y+1) = (x - y) + 1 *)
  | Zn y => Zp (zminus x y) (* x - (y-1) = (x - y) - 1 *)
  end.

Theorem zplus_id_right : forall x:int, zplus x Z = x.
Proof.
  intros.
  induction x.
    simpl. reflexivity.
    simpl. rewrite IHx. reflexivity.
    simpl. rewrite IHx. reflexivity.
Qed.

Fixpoint zmult (x y:int) : int :=
  match x with
  | Z => Z                       (* 0 * y     = 0         *)
  | Zp x => zplus  (zmult x y) y (* (x+1) * y = (x*y) + y *)
  | Zn x => zminus (zmult x y) y (* (x-1) * y = (x*y) - y *)
  end.

Theorem zmult_zero_right : forall x:int, zmult x Z = Z.
Proof.
  intros.
  induction x.
    simpl. reflexivity.
    simpl. rewrite IHx. reflexivity.
    simpl. rewrite IHx. reflexivity.
Qed.

(*

N_rec:
  forall P : N -> Set,
  P O -> (forall n : N, P n -> P (S n)) -> forall n : N, P n.

bool_rec:
  forall P : bool -> Set,
  P true -> P false -> forall b : bool, P b

N_ind:
  forall P : N -> Prop,
  P O -> (forall n : N, P n -> P (S n)) -> forall n : N, P n

bool_ind:
  forall P : bool -> Prop,
  P true -> P false -> forall b : bool, P b.

*)


Require Import Coq.Program.Basics.
Require Import Coq.Vectors.Fin.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Import Lia.
Import EqNotations.
Local Open Scope program_scope.

Module List.
Import ListNotations.

Fixpoint lookup {A : Type} (xs : list A) : Fin.t (length xs) -> A :=
  match xs with
  | [] => Fin.case0 (fun _ => A)
  | x :: xs => fun i =>
    match i in Fin.t (S n) return n = length xs -> A with
    | F1 => const x
    | FS j => fun H => lookup xs (rew H in j)
    end eq_refl
  end.

Fixpoint take {A : Type} (xs : list A) : Fin.t (S (length xs)) -> list A :=
  match xs with
  | [] => const []
  | x :: xs => fun i =>
    match i in Fin.t (S n) return n = S (length xs) -> list A with
    | F1 => const []
    | FS j => fun H => x :: take xs (rew H in j)
    end eq_refl
  end.

Fixpoint drop {A : Type} (xs : list A) : Fin.t (S (length xs)) -> list A :=
  match xs with
  | [] => const []
  | x :: xs => fun i =>
    match i in Fin.t (S n) return n = S (length xs) -> list A with
    | F1 => const (x :: xs)
    | FS j => fun H => drop xs (rew H in j)
    end eq_refl
  end.

Lemma Forall_lookup {A : Type} {P : A -> Prop} {xs : list A} (H : Forall P xs) : forall i, P (lookup xs i).
Proof.
  induction H.
  - intros.
    inversion i.
  - intros.
    apply (Fin.caseS' i).
    + apply H.
    + apply IHForall.
Defined.

End List.

Module Vector.
Import VectorDef.
Import VectorNotations.

Fixpoint take {A : Type} (m : nat) {n : nat} : VectorDef.t A (m+n) -> VectorDef.t A m :=
  match m return VectorDef.t A (m + n) -> VectorDef.t A m with
  | 0 => Basics.const []
  | S m => fun xs =>
    match xs in VectorDef.t _ l return l = S m + n -> VectorDef.t A (S m) with
    | [] => fun H => False_rect _ (O_S _ H)
    | x :: xs => fun H => x :: take m (rew eq_add_S _ _ H in xs)
    end eq_refl
  end.

Fixpoint drop {A : Type} (m : nat) {n : nat} : VectorDef.t A (m+n) -> VectorDef.t A n :=
  match m return VectorDef.t A (m + n) -> VectorDef.t A n with
  | 0 => id
  | S m => fun xs =>
    match xs in VectorDef.t _ l return l = S m + n -> VectorDef.t A n with
    | [] => fun H => False_rect _ (O_S _ H)
    | x :: xs => fun H => drop m (rew eq_add_S _ _ H in xs)
    end eq_refl
  end.

Fixpoint tabulate {A : Type} {n : nat} : (Fin.t n -> A) -> VectorDef.t A n :=
  match n as m return m = n -> (Fin.t m -> A) -> VectorDef.t A n with
  | 0 => fun H f => rew H in []
  | S n' => fun H f => rew H in (f F1 :: tabulate (f ∘ FS))
  end eq_refl.

Definition sum_nat {n : nat} : VectorDef.t nat n -> nat :=
  fun xs => fold_right plus xs 0.

Definition inner_product {n : nat} : VectorDef.t nat n -> VectorDef.t nat n -> nat :=
  fun xs ys => sum_nat (map2 mult xs ys).

End Vector.

Module Fin.

Fixpoint inject1 {n : nat} : Fin.t n -> Fin.t (S n) :=
  match n return Fin.t n -> Fin.t (S n) with
  | 0 => Fin.case0 _
  | S n => fun i =>
    match i in Fin.t (S m) return m = n -> Fin.t (S (S n)) with
    | F1 => const F1
    | FS j => fun H => FS (inject1 (rew H in j))
    end eq_refl
  end.

Fixpoint sum_Fin {n : nat} : (Fin.t n -> nat) -> nat :=
  match n with
  | 0 => const 0
  | S n => fun f => f F1 + sum_Fin (f ∘ FS)
  end.

Definition toNat {n : nat} : Fin.t n -> nat := fun x => proj1_sig (Fin.to_nat x).

End Fin.

Import List.
Import Vector.
Import Fin.

Definition solution_set (xs : list Z) :=
  sigT (fun i : Fin.t (length xs) =>
  sigT (fun j : Fin.t (length xs) =>
  sig  (fun k : Fin.t (length xs) =>
    toNat i < toNat j < toNat k /\
    Z.sub (lookup xs j) (lookup xs i) = Z.sub (lookup xs k) (lookup xs j)
  ))).

Definition Iso (A B : Type) : Prop :=
  exists (f : A -> B) (g : B -> A),
  g ∘ f = id /\ f ∘ g = id.

Definition solution_rel (xs : list Z) (n : nat) := Iso (solution_set xs) (Fin.t n).

Import ListNotations.
Fixpoint count (x : Z) (xs : list Z) : nat :=
  match xs with
  | [] => 0
  | y :: xs =>
    if Z.eq_dec x y
      then S (count x xs)
      else count x xs
  end.

Definition toZ {n : nat} : Fin.t n -> Z := fun x => Z.of_nat (proj1_sig (Fin.to_nat x)).

Local Open Scope Z_scope.
Definition distribution (xs : list Z) (a b : Z) (Hab : a <= b) : VectorDef.t nat (Z.to_nat (b - a)) :=
  tabulate (fun i : Fin.t (Z.to_nat (b-a)) => count (a + toZ i) xs).

Lemma Connex_Z_le_le (x y : Z) : ({x <= y} + {y <= x}).
Proof.
  destruct (x <=? y) eqn: P;
  [ left; apply Z.leb_le
  | right; apply Z.lt_le_incl; apply Z.leb_gt
  ];
  assumption.
Defined.

Import VectorDef.
Import Vector.

Definition solution_dec (xs : list Z) (a b : Z) (Hab : a <= b) (H : List.Forall (fun x => a <= x < b) xs) : nat :=
  sum_Fin (fun i =>
    let l := Z.to_nat (b-a) in
    let xs_i := List.take xs (inject1 i) in
    let xs_k := List.drop xs (FS i) in
    let xj := lookup xs i in
    let xj_range : a <= xj < b := Forall_lookup H i in
      match Connex_Z_le_le (2*xj) (a+b-1) with
      | left P =>
        let m := Z.to_nat (2*xj - 2*a + 1) in
        let m_split : l = (m + (l - m))%nat := ltac: (lia) in
        let ds_i := take m (rew m_split in distribution xs_i a b Hab) in
        let ds_k := take m (rew m_split in distribution xs_k a b Hab) in
        inner_product ds_i (rev ds_k)
      | right P =>
        let m := Z.to_nat (2*xj - (a+b-1)) in
        let m_split : l = (m + (l - m))%nat := ltac: (lia) in
        let ds_i := drop m (rew m_split in distribution xs_i a b Hab) in
        let ds_k := drop m (rew m_split in distribution xs_k a b Hab) in
        inner_product ds_i (rev ds_k)
      end).


Require Import SegmentQueue.util.everything.
From Coq Require Import ssreflect.
Require Import stdpp.base stdpp.list.
Require Import SegmentQueue.util.find_index.

Fixpoint count_matching {A} (P: A -> Prop) {H': forall x, Decision (P x)} (l: list A): nat :=
  match l with
  | nil => 0
  | cons x l' => if decide (P x) then S (count_matching P l') else count_matching P l'
  end%GEN_IF.

Definition sum := foldr Nat.add 0.

Theorem sum_app a b: sum (a ++ b) = sum a + sum b.
Proof. induction a=> //=. rewrite IHa; lia. Qed.

Theorem count_matching_is_sum_map {A} (P: A -> Prop) {H': forall x, Decision (P x)} l:
  count_matching P l =
  sum (map (fun x => if decide (P x) then 1 else 0)%GEN_IF l).
Proof. induction l; auto. simpl. destruct (decide (P a)); simpl; auto. Qed.

Theorem count_matching_app {A} (P: A -> Prop) {H': forall x, Decision (P x)} (l1 l2: list A):
  count_matching P (l1 ++ l2) = (count_matching P l1 + count_matching P l2)%nat.
Proof. rewrite !count_matching_is_sum_map map_app sum_app //. Qed.

Theorem count_matching_alter
        {A} (P: A -> Prop) {H': forall x, Decision (P x)}:
  let to_num x := (if decide (P x) then 1%nat else 0%nat)%GEN_IF in
  forall v f l i, l !! i = Some v ->
               count_matching P (alter f i l) =
               (count_matching P l + (to_num (f v)) - (to_num v))%nat.
Proof.
  intros ? v f l i HEl. rewrite -[in count_matching P l](take_drop_middle l i v HEl).
  erewrite take_drop_middle_alter; last done.
  rewrite !count_matching_is_sum_map.
  rewrite !map_app !sum_app=> /=. subst to_num. simpl. lia.
Qed.

Theorem count_matching_le_length
        {A} (P: A -> Prop) {H': forall x, Decision (P x)} (l: list A):
  (count_matching P l <= length l)%nat.
Proof. induction l; first done. simpl. destruct (decide (P a)); lia. Qed.

Theorem count_matching_complement
        {A} (P: A -> Prop) {H': forall x, Decision (P x)} (l: list A):
  count_matching (fun b => not (P b)) l = (length l - count_matching P l)%nat.
Proof.
  induction l; first done.
  simpl.
  destruct (decide (P a)); destruct (decide (not (P a))); try contradiction.
  done.
  rewrite -minus_Sn_m; try lia.
  by apply count_matching_le_length.
Qed.

Theorem count_matching_take
        {A} (P: A -> Prop) {H': forall x, Decision (P x)} (l: list A):
  forall i, count_matching P (take i l) =
       (count_matching P l - count_matching P (drop i l))%nat.
Proof.
  intros i.
  replace (count_matching P l) with (count_matching P (take i l ++ drop i l)).
  2: by rewrite take_drop.
  rewrite count_matching_app. lia.
Qed.

Theorem count_matching_drop
        {A} (P: A -> Prop) {H': forall x, Decision (P x)} (l: list A):
  forall i, count_matching P (drop i l) =
       (count_matching P l - count_matching P (take i l))%nat.
Proof.
  intros i.
  replace (count_matching P l) with (count_matching P (take i l ++ drop i l)).
  2: by rewrite take_drop.
  rewrite count_matching_app. lia.
Qed.

Theorem count_matching_all
  {A} (P: A -> Prop) {H': forall x, Decision (P x)} (l: list A):
  count_matching P l = length l <-> ∀ i, i ∈ l → P i.
Proof.
  split.
  - induction l as [|a l]=> /=.
    * intros _ i Hi. inversion Hi.
    * destruct (decide (P a)).
      + case. intros HOk i Hi.
        inversion Hi; subst; first done. by apply IHl.
      + intros HContra.
        assert (count_matching P l ≤ length l); last lia.
        apply count_matching_le_length.
  - intros HEl. induction l as [|a l] => //=.
    rewrite decide_True; last by apply HEl; constructor.
    rewrite IHl //.
    intros i Hi. apply HEl. by constructor.
Qed.

Theorem count_matching_none
  {A} (P: A -> Prop) {H': forall x, Decision (P x)} (l: list A):
  count_matching P l = 0 <-> ∀ i, i ∈ l → ¬ P i.
Proof.
  assert (count_matching P l = 0 <->
          count_matching (fun b => ¬ (P b)) l = length l) as ->.
  {
    rewrite count_matching_complement.
    assert (count_matching P l ≤ length l).
    by apply count_matching_le_length.
    split; lia.
  }
  apply count_matching_all.
Qed.

Lemma present_cells_in_take_i_if_next_present_is_Si
  {A: Type} (P: A -> Prop) {H': forall x, Decision (P x)} (i: nat) (l: list A):
    find_index P l = Some i ->
    count_matching P (take i l) = O.
Proof.
  intros HFindSome. apply count_matching_none.
  apply find_index_Some in HFindSome. intros v HEl.
  destruct HFindSome as [_ HNotPresent].
  apply elem_of_list_lookup_1 in HEl. destruct HEl as [i' HEl].
  destruct (decide (i ≤ i')).
  by rewrite lookup_take_ge in HEl; last lia.
  rewrite lookup_take in HEl; last lia.
  destruct (HNotPresent i') as (v' & HEl' & HProof); first lia.
  by simplify_eq.
Qed.

Lemma present_cells_in_take_1_drop_i_if_next_present_is_Si
  {A: Type} (P: A -> Prop) {H': forall x, Decision (P x)} (i: nat) (l: list A):
    find_index P l = Some i ->
    count_matching P (take 1 (drop i l)) = 1%nat.
Proof.
  intros HFindSome.
  apply find_index_Some in HFindSome.
  destruct HFindSome as [[v [HIn HPresent]] HNotPresent].
  assert (i < length l)%nat as HLt.
  { apply lookup_lt_is_Some. by eexists. }

  replace (drop i l) with (v :: drop (S i) l).
  { simpl. destruct (decide (P v)); try contradiction. done. }
  assert (i = length (take i l))%nat as HH.
  by rewrite take_length_le; lia.
  replace (drop i l) with (drop i (take i l ++ v :: drop (S i) l)).
  { symmetry. rewrite drop_app_le; last lia. rewrite drop_ge //. lia. }
  by rewrite take_drop_middle.
Qed.

Lemma present_cells_in_take_Si_if_next_present_is_Si
  {A: Type} (P: A -> Prop) {H': forall x, Decision (P x)} (i: nat) (l: list A):
    find_index P l = Some i ->
    count_matching P (take (S i) l) = 1%nat.
Proof.
  intros HFindSome.
  change (S i) with (1 + i)%nat.
  rewrite Nat.add_comm -take_take_drop count_matching_app.
  rewrite present_cells_in_take_1_drop_i_if_next_present_is_Si //.
  rewrite present_cells_in_take_i_if_next_present_is_Si //.
Qed.

Lemma absent_cells_in_drop_Si_if_next_present_is_i
  {A: Type} (P: A -> Prop) {H': forall x, Decision (P x)} (i: nat) (l: list A):
    find_index P l = Some i ->
  count_matching (λ b, not (P b)) l =
  (i + count_matching (λ b, not (P b)) (drop (S i) l))%nat.
Proof.
  intros HFindSome.
  repeat rewrite count_matching_complement.
  rewrite drop_length.

  replace (count_matching P l) with
      (count_matching P (take (S i) l ++ drop (S i) l)).
  2: by rewrite take_drop.

  rewrite count_matching_app Nat.sub_add_distr.
  rewrite present_cells_in_take_Si_if_next_present_is_Si; try done.

  repeat rewrite -Nat.sub_add_distr /=.
  remember (count_matching (_) (drop (S i) _)) as K.
  rewrite plus_n_Sm.
  rewrite -(Nat.add_comm (S K)) Nat.sub_add_distr.
  assert (K <= length l - S i)%nat as HKLt.
  {
    rewrite HeqK. eapply transitivity.
    apply count_matching_le_length.
    by rewrite drop_length.
  }
  assert (i < length l)%nat; try lia.
  apply find_index_Some in HFindSome.
  destruct HFindSome as [(v & HEl & _) _].
  apply lookup_lt_is_Some. eauto.
Qed.

Theorem count_matching_find_index_Some A (P: A -> Prop) (H': forall x, Decision (P x)) l:
  (count_matching P l > 0)%nat -> is_Some (find_index P l).
Proof.
  induction l; simpl; first lia.
  destruct (decide (P a)); first by eauto.
  destruct (find_index P l); by eauto.
Qed.


From mathcomp Require Import ssreflect.

Require Import classical_predicate_logic.

(*
  A Collection does not include itself at type theory.
  For the above reason, we can avoid russel's paradox.
 *)
(*
  Collection is aliase of LogicFunction.
 *)
(*
  Uはこの世のすべての記号,元を集めた集合.
  論理関数の判定により,集合を作成する. (分出公理と目的は同じ.).
 *)

Definition Collection U := LogicFunction U.

Definition In (U:Type) (X:Collection U) (x:U) : Prop := X x.

Notation "x ∈ X" := (In _ X x) (right associativity, at level 35).
Notation "x ∉ X" := (~(In _ X x)) (right associativity, at level 35).

Reserved Notation "A ∪ B" (right associativity, at level 30).
(* Unicode of ⋃ is 22c3 *)
Reserved Notation "⋃ X" (right associativity, at level 30).

Reserved Notation "A ∩ B" (right associativity, at level 30).
(* Unicode of ⋂ is 22c2 *)
Reserved Notation "⋂ X"  (right associativity, at level 30).

Reserved Notation "A \ B"  (right associativity, at level 30).

(* 内包の公理 *)
Theorem AxiomOfComprehension:
  forall U:Type, forall F:LogicFunction U, exists z':Collection U, forall a:U, a ∈ z' <-> F a.
Proof.
  move => U F.
  exists F.
  move => a.
  rewrite /iff. split => H; apply H.
Qed.

(* 外延性公理 *)
Axiom AxiomOfExtentionality:
  forall U:Type, forall {x' y':Collection U},
      (forall x:U, (x ∈ x' <-> x ∈ y')) -> x' = y'.

Theorem collection_is_unique_existence:
  forall U:Type, forall F:LogicFunction U, exists! y':Collection U, forall x:U, (x ∈ y') <-> F x.
Proof.
  move => U F.
  exists F.
  rewrite /unique.
  split. move => x.
  rewrite /iff. split => H; apply H.
  move => x' H.
  apply AxiomOfExtentionality.
  move => x.
  apply: iff_sym.
  apply: (H x).
Qed.

Section Examples.
  Inductive DayOfTheWeek : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

  Definition Weekdays : Collection DayOfTheWeek :=
    fun d => d = monday \/ d = tuesday \/ d = wednesday \/ d = thursday \/ d = friday.
  Definition Holidays : Collection DayOfTheWeek :=
    fun d => d = saturday \/ d = sunday.

  Goal monday ∈ Weekdays.
  Proof.
    left.
    reflexivity.
  Qed.

  Goal forall d:DayOfTheWeek, d ∈ Weekdays <-> Weekdays d.
  Proof.
    move => d.
    rewrite /iff. split => H; apply H.
  Qed.

End Examples.

Export classical_predicate_logic.


Require Import Word.

Require Import Vector.
Require Import CoLoR_VecUtil.

Require Import Equality.

Import BOps.

Set Implicit Arguments.

Definition Distr T f g := forall a b c : T,
    g a (f b c) = f (g a b) (g a c).

Definition Comm T (f : T -> T -> T) := forall a b, f a b = f b a.

Arguments Distr [T] f g.
Arguments Comm [T] _.

Section Basics.

  Variable f g : bool -> bool -> bool.
  Variable n : nat.

  Lemma liftDistr : Distr f g -> Distr (@liftBV2 (@Vmap2 _ _ _ f) n)
                                       (@liftBV2 (@Vmap2 _ _ _ g) n).
    unfold Distr.
    intros.
    destruct a, b, c.
    unfold Bvector.Bvector in *.
    simpl.
    f_equal.
    induction n.
    now VOtac.
    VSntac b0. VSntac b1. VSntac b.
    simpl.
    f_equal.
    apply H.
    apply IHn0.
  Qed.

  Lemma liftComm : Comm f -> Comm (@liftBV2 (@Vmap2 _ _ _ f) n).
    unfold Comm.
    intros.
    destruct a, b.
    unfold Bvector.Bvector in *.
    simpl.
    f_equal.
    induction n.
    now VOtac.
    VSntac b0. VSntac b.
    simpl.
    f_equal.
    apply H.
    apply IHn0.
  Qed.

End Basics.

Lemma ntimesCompose A (f : A -> A) n1 n2 a
  : ntimes f n1 (ntimes f n2 a) = ntimes f (n1 + n2) a.
  induction n1.
  trivial.
  simpl.
  f_equal.
  apply IHn1.
Qed.

Lemma OrComm n (w1 w2 : Word.t n)
  : OrW w1 w2 = OrW w2 w1.
  unfold OrW, BVOr.
  apply liftComm.
  unfold Comm.
  apply Bool.orb_comm.
Qed.

Lemma AndComm n (w1 w2 : Word.t n)
  : AndW w1 w2 = AndW w2 w1.
  unfold AndW, BVAnd.
  apply liftComm.
  unfold Comm.
  apply Bool.andb_comm.
Qed.

Lemma OrDistrAnd n (w1 w2 w3 : Word.t n)
  : OrW w1 (AndW w2 w3) = AndW (OrW w1 w2) (OrW w1 w3).
  unfold OrW, BVOr, BVAnd.
  apply liftDistr.
  unfold Distr.
  apply Bool.orb_andb_distrib_r.
Qed.

Lemma AndDistrOr n (w1 w2 w3 : Word.t n)
  : AndW w1 (OrW w2 w3) = OrW (AndW w1 w2) (AndW w1 w3).
  unfold OrW, BVOr, BVAnd.
  apply liftDistr.
  unfold Distr.
  apply Bool.andb_orb_distrib_r.
Qed.

Lemma rotRCompose n r1 r2 (w : Word.t n)
  : RotRW r1 (RotRW r2 w) = RotRW (r1 + r2) w.
Proof.
  destruct w.
  unfold RotRW.
  simpl liftBV.
  f_equal.
  unfold BRotR.
  apply ntimesCompose.
Qed.

Lemma rotRDistrXor n : forall (w1 w2 : Word.t n) r,
    RotRW r (XorW w1 w2) = XorW (RotRW r w1) (RotRW r w2).
Proof.
  destruct w1 as [ b1 ].
  destruct w2 as [ b2 ].
  intro r.
  unfold RotRW.
  unfold XorW.
  cbn [liftBV liftBV2].
  f_equal.
  (* Reduced to assertion on BVectors *)
  induction r.
  - unfold BRotR; trivial.
  - unfold BRotR.
    unfold Word.BOps.ntimes.
    fold Word.BOps.ntimes.
    fold (BRotR r (BVXor b1 b2)).
    fold (BRotR r b1).
    fold (BRotR r b2).
    rewrite IHr.
    generalize (BRotR r b1) as bv1.
    generalize (BRotR r b2) as bv2.
    (* Reduced to the single rotation case *)
    clear IHr.
    intros.
    destruct n.
    simpl; trivial.
    VSntac (Vmap2 xorb bv1 bv2).
    VSntac bv1. VSntac bv2.
    simpl.
    (* This assertion does not have an induction by n proof *)
    f_equal.
    * destruct n.
      assert (Vtail bv1 = Vnil).
      apply VO_eq.
      rewrite H2.
      assert (Vtail bv2 = Vnil).
      apply VO_eq.
      rewrite H3.
      trivial.

      assert (n < S n) by auto.
      repeat rewrite (Vlast_nth _ _ H2).
      unfold BVXor.
      rewrite Vnth_map2; trivial.
    * unfold BVXor.
      unfold Vmap2 at 1.
      fold (Vmap2 xorb bv1 bv2).
      rewrite <- H0.
      rewrite <- H1.
      (* Finally down to an assertion that can be proved by induction on n *)
      clear b1 b2 r H H0 H1.
      induction n.
      + apply VO_eq.
      + VSntac bv1. VSntac bv2.

        unfold Vremove_last at 1.
        simpl.
        f_equal.
        (* Now to rewrite to look like induction hypothesis *)
        repeat rewrite Vsub_cons.
        unfold Vmap2 at 1.
        fold (Vmap2 xorb (Vtail bv1) (Vtail bv2)).
        rewrite (Vsub_pi (Vremove_last_aux n)).
        fold (Vremove_last (Vmap2 xorb (Vtail bv1) (Vtail bv2))).
        rewrite (Vsub_pi (Vremove_last_aux n)).
        fold (Vremove_last (Vtail bv1)).
        rewrite (Vsub_pi (Vremove_last_aux n)).
        fold (Vremove_last (Vtail bv2)).

        apply IHn.
Qed.


(* Transition system lemmas. *)

From set_theory Require Import lib.

(* Prove a property of a function that emulates a transition system. *)
Section Self_extending_state_transition_system.

(* A state transition system *)
Variable State : Type.
Variable Trans : Type.
Variable Value : Type.
Variable step : Trans -> State -> State.
Variable output : State -> Value.

(* The state output value tracks transition symbols. *)
Variable Symbol : Type.
Variable symb : Trans -> Symbol.
Variable push : Symbol -> Value -> Value.
Variable peek : Value -> Symbol.

(* The step function encodes the transition into the state output. *)
Hypothesis step_push : ∀s t, output (step t s) = push (symb t) (output s).
Hypothesis peek_push : ∀a v, peek (push a v) = a.

(* A function which takes a number of steps and outputs a value. *)
Variable f : State -> nat -> Value.

(* State transition used by f. *)
Variable trans : State -> Trans.

(* f computes transitions. *)
Hypothesis f_step : ∀s n, f s (S n) = f (step (trans s) s) n.
Hypothesis f_output : ∀s, f s 0 = output s.

(* f pushes one transition symbol at each successor. *)
Theorem self_extending s n :
  f s (S n) = push (peek (f s (S n))) (f s n).
Proof.
revert s; induction n; intros.
- now rewrite f_step, ?f_output, step_push, peek_push.
- now rewrite f_step, IHn, peek_push, (f_step s).
Qed.

End Self_extending_state_transition_system.


Require Import Lists.List.

Fixpoint sum (xs: list nat) : nat :=
  match xs with
    | nil => 0
    | x :: xs => x + sum xs
  end.

Theorem Pigeon_Hole_Principle :
  forall (xs : list nat), length xs < sum xs -> (exists x, 1<x /\ In x xs).
Proof.
  intros.
  induction xs.
  simpl in H.
  exfalso.
  apply (Lt.lt_n_0 0 H).
  destruct a.
  simpl in H.
  assert (exists x : nat, 1 < x /\ In x xs).
  apply IHxs.
  apply (Lt.lt_trans (length xs) (S (length xs)) (sum xs)).
  apply Lt.lt_n_Sn.
  exact H.
  destruct H0.
  exists x.
  destruct H0.
  split.
  assumption.
  simpl.
  right.
  assumption.
  destruct a.
  simpl in H.
  apply Lt.lt_S_n in H.
  apply IHxs in H.
  destruct H.
  destruct H.
  exists x.
  split.
  assumption.
  simpl.
  right.
  assumption.
  exists (S (S a)).
  split.
  apply Lt.lt_n_S.
  apply Lt.lt_0_Sn.
  simpl.
  left.
  reflexivity.
Qed.


Require Import Omega.

Lemma test_nat:
  forall n, (5 + pred n <= 5 + n).
Proof.
  intros.
  zify.
  omega.
Qed.

Lemma test_N:
  forall n, (5 + N.pred n <= 5 + n)%N.
Proof.
  intros.
  zify.
  omega.
Qed.


Add LoadPath "Category".
Require Import Category Epsilon.

Generalizable Variables hom obj.

Definition epimorphism `{Category} {A B} (f : hom A B) :=
  forall C (g1 g2 : B --> C), g1 • f = g2 • f -> g1 = g2.

Definition monomorphism `{Category} {A B} (f : hom A B) :=
  forall C (g1 g2 : hom C A), f • g1 = f • g2 -> g1 = g2.

Definition isInverse `{Category} {A B} (f : hom A B) (f' : hom B A) := f • f' = 1 /\ f' • f = 1.

Definition isomorphism `{Category} {A B} (f : hom A B) :=
  exists (f' : hom B A), isInverse f f'.

Definition isomorphic `{Category} (A B : obj) := exists (f : hom A B), isomorphism f.

Hint Unfold epimorphism monomorphism isInverse isomorphism isomorphic.

Notation "A == B" := (isomorphic A B) (at level 70, right associativity).

Lemma isomorphic_symmertric `{Category} {A B}: A == B <-> B ==  A.
Proof.
  unfold "==". autounfold. split; intros [f [f' [L R]]]; exists f', f; split; auto.
Qed.

Lemma isoIsMono: forall `{Category} {A B} (f : hom A B), isomorphism f -> monomorphism f.
Proof.
  autounfold. intros. inversion H0 as [f' [L R]].
  replace g2 with (1 • g2) by apply idLeft.
  replace g1 with (1 • g1) by apply idLeft.
  rewrite <- R. rewrite <- compAssoc. rewrite H1. apply compAssoc.
Qed.

Lemma isoIsEpi: forall `{Category} {A B} (f :hom A B), isomorphism f -> epimorphism f.
Proof.
  autounfold. intros. inversion H0 as [f' [L R]].
  replace g2 with (g2 • 1) by apply idRight.
  replace g1 with (g1 • 1) by apply idRight.
  unfold "1" in *.
  rewrite <- L. rewrite compAssoc. rewrite H1. rewrite compAssoc. reflexivity.
Qed.

Lemma inverseUnique: forall `{Category} {A B} (f1 f2 : hom A B) (f : hom B A),
  isInverse f1 f /\ isInverse f2 f -> f1 = f2.
Proof.
  intros obj hom cid comp Cat A B f1 f2 f Inv.
  destruct Inv as [Inv1 Inv2]. destruct Inv1 as [Inv1L Inv1R].
  destruct Inv2 as [Inv2L Inv2R].
  replace f1 with (f1 • 1) by apply idRight. rewrite <- Inv2R. rewrite compAssoc.
  rewrite Inv1L. apply idLeft.
Qed.

Lemma isomorphism_dual : forall `(C : Category obj hom) {A B} (f : hom A B),
  @isomorphism _ _ _ _ C _ _ f <->
  @isomorphism _ _ _ _ (Dual C) _ _ f.
Proof.
  intros. autounfold. unfold "1". unfold "•". unfold "-->".
  split; intros [f' [L R]]; exists f'; split; auto.
Qed.

Lemma isomorphic_dual : forall `(C : Category) {A B},
  @isomorphic _ _ _ _ C A B <-> @isomorphic _ _ _ _ (Dual C) A B.
Proof.
  autounfold. intros.
  split; intros [f [f' [L R]]]; exists f', f; auto.
Qed.

Lemma monomorphism_compose : forall `{Category obj hom}
  {A B C} (f : hom B C) (g : hom A B),
  monomorphism f -> monomorphism g -> monomorphism (f • g).
Proof.
  autounfold. intros. apply H1. apply H0. repeat (rewrite compAssoc).
  apply H2.
Qed.

Lemma monomorphism_decompose : forall `{Category obj hom}
  {A B C} (f : hom B C) (g : hom A B),
  monomorphism (f • g) -> monomorphism g.
Proof.
  autounfold. intros. apply H0. repeat (rewrite <- compAssoc).
  rewrite H1. reflexivity.
Qed.

Lemma epimorphism_compose : forall `{Category obj hom}
  {A B C} (f : hom B C) (g : hom A B),
  epimorphism f -> epimorphism g -> epimorphism (f • g).
Proof.
  intros. apply (@monomorphism_compose _ _ _ _ (Dual H)); auto.
Qed.

Lemma epimorphism_decompose : forall `{Category obj hom}
  {A B C} (f : hom B C) (g : hom A B),
  epimorphism (f • g) -> epimorphism f.
Proof.
  intros. eapply (@monomorphism_decompose _ _ _ _ (Dual H)).
  apply H0.
Qed.

(*** Initial and Terminal objects *)

Definition isTerminal `{C : Category} (T : obj) := forall A, exists ! f : hom A T, True.

Definition bang `{Category obj} (T : obj) (TH : isTerminal T) (A : obj) : A --> T.
  unfold isTerminal in TH. specialize TH with A.
  apply constructive_indefinite_description in TH. destruct TH. apply x.
Defined.

Notation "! H A" := (bang _ H A) (at level 30).

Lemma bang_unique `{Category obj} (T : obj) (TH : isTerminal T) :
  forall A (h : A --> T), h = (bang _ TH A).
Proof.
  intros. destruct (TH A). destruct H0. assert (x = h).
  apply H1. constructor. subst. apply H1. constructor.
Qed.

Hint Unfold isTerminal.

Lemma terminalUniqueIso1 `{C : Category} :
  forall B1 B2, isTerminal B1 /\ isTerminal B2 -> B1 == B2.
Proof.
  autounfold. intros B1 B2 [TermB1 TermB2].
  pose proof TermB1 as TermB1Copy.
  pose proof TermB2 as TermB2Copy.
  destruct TermB1 with B1 as [id1 Uid1]. clear TermB1.
  destruct TermB2 with B2 as [id2 Uid2]. clear TermB2.
  destruct TermB1Copy with B2 as [f1 Uf1]. clear TermB1Copy.
  destruct TermB2Copy with B1 as [f2 Uf2]. clear TermB2Copy.
  exists f2. exists f1. split.
  - inversion Uid2. rewrite <- H0 with (f2 • f1) by constructor. rewrite (H0 1) by
    constructor. reflexivity.
  - inversion Uid1. rewrite <- H0 with (f1 • f2) by constructor. rewrite (H0 1) by
    constructor. reflexivity.
Qed.

Lemma terminalUniqueIso2 `{C : Category}:
  forall B1 B2, isTerminal B1 /\ B1 == B2 -> isTerminal B2.
Proof.
  autounfold. intros B1 B2 Con.
  destruct Con as [T [f [f' Inv]]].
  intros A. assert (exists ! g : hom A B1, True) by apply T.
  destruct H. exists (f • x). split.
  - apply I.
  - intros g' Top. replace g' with (1 • g') by apply idLeft.
    inversion Inv as [L R]. rewrite <- L. rewrite <- compAssoc.
    replace (f' • g') with x; try reflexivity.
    + apply H. constructor.
Qed.

Definition isInitial `{C : Category} (I : obj) := forall A, exists ! f : hom I A, True.

Hint Unfold isInitial.

Corollary initialDualTerminal {obj hom cid comp} `(C : Category obj hom cid comp):
  forall o, @isTerminal _ _ _ _ C o <-> @isInitial _ _ _ _ (Dual C) o.
Proof.
  autounfold. intros. split; [intros hI A | intros hT A].
  - destruct hI with A as [f [[] H]].
    exists f. split; try apply I. intros g []. rewrite <- H; auto.
  - destruct hT with A as [f [[] H]].
    exists f. split; try apply I. intros g []. rewrite <- H; auto.
Qed.

Lemma initialUniqueIso1 `{C : Category} : forall B1 B2, isInitial B1 /\ isInitial B2
  -> B1 == B2.
Proof.
  intros.
  rewrite isomorphic_dual. apply terminalUniqueIso1.
  destruct H. split; auto.
Qed.

Lemma initialUniqueIso2 `{C : Category}: forall B1 B2,
  isInitial B1 /\ B1 == B2 -> isInitial B2.
Proof.
  intros B1 B2 [I E].
  rewrite <- (initialDualTerminal (Dual C) B2). eapply terminalUniqueIso2.
  split.
  - apply I.
  - rewrite isomorphic_symmertric. rewrite isomorphic_dual.
    rewrite isomorphic_symmertric. apply E.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.saccheri.

Section existential_triangle_rah.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma existential_triangle__rah : postulate_of_existence_of_a_triangle_whose_angles_sum_to_two_rights -> postulate_of_right_saccheri_quadrilaterals.
Proof.
  intro et.
  destruct et as [A [B [C [D [E [F]]]]]].
  spliter.
  apply (t22_14__rah A B C D E F); auto.
Qed.

End existential_triangle_rah.


(* Exercise 55 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_055 : ~(forall x, P x /\ Q x) /\ (forall x, Q x) -> ~(forall x, P x).
Proof.
imp_i a1.
neg_i (forall x:D, P x /\ Q x) a2.
con_e1 (forall x:D, Q x).
hyp a1.
all_i a.
con_i.
all_e (forall x:D, P x) a.
hyp a2.
all_e (forall x:D, Q x) a.
con_e2 (~(forall x:D, P x /\ Q x)).
hyp a1.
Qed.