From 1ead00c3809aed359011e045bd24afd9ccaa8aed Mon Sep 17 00:00:00 2001 From: William Spencer Date: Sat, 20 Jul 2024 12:22:55 -0700 Subject: [PATCH 01/10] =?UTF-8?q?Introduces=20machinery=20for=20manipulati?= =?UTF-8?q?ng=20permutations=20to=20VyZX.=20In=20particular:=20-=20Defines?= =?UTF-8?q?=20`ZXperm=20n`,=20a=20predicate=20defining=20the=20subset=20of?= =?UTF-8?q?=20`ZX=20n=20n`=20which=20are=20=20=20permutation-like,=20i.e.?= =?UTF-8?q?=20stacks=20and=20compositions=20of=20`Empty`,=20`Wire`,=20and?= =?UTF-8?q?=20`Swap`.=20-=20Defines=20`perm=5Fof=5Fzx`,=20which=20gives=20?= =?UTF-8?q?the=20underlying=20permutation=20of=20a=20ZXperm,=20and=20=20?= =?UTF-8?q?=20shows=20that=20this=20determines=20the=20semantics=20of=20th?= =?UTF-8?q?e=20diagram,=20so=20that=20showing=20the=20=20=20equivalence=20?= =?UTF-8?q?of=20`ZXperm`s=20reduces=20to=20showing=20the=20equality=20of?= =?UTF-8?q?=20their=20underlying=20=20=20permutations.=20This=20task=20in?= =?UTF-8?q?=20invariably=20far=20simpler=20(in=20particular,=20tractable),?= =?UTF-8?q?=20=20=20and=20we=20also=20provide=20significant=20automation?= =?UTF-8?q?=20for=20completing=20this=20task.=20-=20Defines=20`zx=5Fof=5Fp?= =?UTF-8?q?erm`,=20which=20realizes=20an=20arbitrary=20permutation=20as=20?= =?UTF-8?q?a=20ZX=20diagram.=20=20=20We=20prove=20this=20is=20suitably=20i?= =?UTF-8?q?nverse=20to=20`perm=5Fof=5Fzx`.=20-=20Defines=20`zx=5Fcomm=20n?= =?UTF-8?q?=20m=20:=20ZX=20(n=20+=20m)=20(m=20+=20n)`=20and=20proves=20its?= =?UTF-8?q?=20naturality,=20i.e.=20=20=20`(zx0=20=E2=86=95=20zx1)=20?= =?UTF-8?q?=E2=9F=B7=20zx=5Fcomm=20m=20q=20=E2=88=9D=20zx=5Fcomm=20n=20p?= =?UTF-8?q?=20=E2=9F=B7=20(zx1=20=E2=86=95=20zx0)`=20=20=20(see=20`zx=5Fco?= =?UTF-8?q?mm=5Fcommutes=5Fr`=20in=20`ZXpermFacts.v`).=20This=20gives=20pu?= =?UTF-8?q?lling=20arbitrary=20=20=20diagrams=20through=20Swap.=20Similarl?= =?UTF-8?q?y=20generalize=20`a=5Fswap`=20to=20show=20arbitrary=20=20=20dia?= =?UTF-8?q?grams=20can=20be=20pulled=20through=20it.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Permutations/KronComm.v | 2337 +++++++++++++++++++++ src/Permutations/MatEquivSetoid.v | 382 ++++ src/Permutations/PermMatrixFacts.v | 612 ++++++ src/Permutations/PermutationAutomation.v | 1465 +++++++++++++ src/Permutations/PermutationAuxiliary.v | 1514 +++++++++++++ src/Permutations/PermutationDefinitions.v | 91 + src/Permutations/PermutationFacts.v | 1797 ++++++++++++++++ src/Permutations/PermutationInstances.v | 902 ++++++++ src/Permutations/PermutationRules.v | 9 + src/Permutations/PermutationSemantics.v | 244 +++ src/Permutations/ZXperm.v | 84 + src/Permutations/ZXpermFacts.v | 1061 ++++++++++ src/Permutations/ZXpermSemantics.v | 186 ++ 13 files changed, 10684 insertions(+) create mode 100644 src/Permutations/KronComm.v create mode 100644 src/Permutations/MatEquivSetoid.v create mode 100644 src/Permutations/PermMatrixFacts.v create mode 100644 src/Permutations/PermutationAutomation.v create mode 100644 src/Permutations/PermutationAuxiliary.v create mode 100644 src/Permutations/PermutationDefinitions.v create mode 100644 src/Permutations/PermutationFacts.v create mode 100644 src/Permutations/PermutationInstances.v create mode 100644 src/Permutations/PermutationRules.v create mode 100644 src/Permutations/PermutationSemantics.v create mode 100644 src/Permutations/ZXperm.v create mode 100644 src/Permutations/ZXpermFacts.v create mode 100644 src/Permutations/ZXpermSemantics.v diff --git a/src/Permutations/KronComm.v b/src/Permutations/KronComm.v new file mode 100644 index 0000000..ba3a274 --- /dev/null +++ b/src/Permutations/KronComm.v @@ -0,0 +1,2337 @@ +Require Import Setoid. + +From VyZX Require Import CoreData. +From VyZX Require Import CoreRules. +From VyZX Require Import PermutationInstances. +Require Export MatEquivSetoid. +Require Export PermMatrixFacts. +Require Import PermutationAuxiliary. +Require Import PermutationAutomation. + +Import Matrix. + +Local Open Scope matrix_scope. + +Lemma Msum_transpose : forall n m p f, + (big_sum (G:=Matrix n m) f p) ⊤ = + big_sum (G:=Matrix n m) (fun i => (f i) ⊤) p. +Proof. + intros. + rewrite (big_sum_func_distr f transpose); easy. +Qed. + + + +Definition kron_comm p q : Matrix (p*q) (q*p):= + @make_WF (p*q) (q*p) (fun s t => + (* have blocks H_ij, p by q of them, and each is q by p *) + let i := (s / q)%nat in let j := (t / p)%nat in + let k := (s mod q)%nat in let l := (t mod p) in + (* let k := (s - q * i)%nat in let l := (t - p * t)%nat in *) + if (i =? l) && (j =? k) then C1 else C0 + (* s/q =? t mod p /\ t/p =? s mod q *) +). + +Lemma WF_kron_comm p q : WF_Matrix (kron_comm p q). +Proof. unfold kron_comm; + rewrite Nat.mul_comm; + trivial with wf_db. Qed. +#[export] Hint Resolve WF_kron_comm : wf_db. + +(* Lemma test_kron : kron_comm 2 3 = Matrix.Zero. +Proof. + apply mat_equiv_eq; unfold kron_comm; auto with wf_db. + print_LHS_matU. +*) + +Lemma kron_comm_transpose_mat_equiv : forall p q, + (kron_comm p q) ⊤ ≡ kron_comm q p. +Proof. + intros p q. + intros i j Hi Hj. + unfold kron_comm, transpose, make_WF. + rewrite andb_comm, Nat.mul_comm. + rewrite (andb_comm (_ =? _)). + easy. +Qed. + +Lemma kron_comm_transpose : forall p q, + (kron_comm p q) ⊤ = kron_comm q p. +Proof. + intros p q. + apply mat_equiv_eq; auto with wf_db. + apply kron_comm_transpose_mat_equiv. +Qed. + +Lemma kron_comm_1_r_mat_equiv : forall p, + (kron_comm p 1) ≡ Matrix.I p. +Proof. + intros p. + intros s t Hs Ht. + unfold kron_comm. + unfold make_WF. + unfold Matrix.I. + rewrite Nat.mul_1_r, Nat.div_1_r, Nat.mod_1_r, Nat.div_small, Nat.mod_small by lia. + bdestructΩ'. +Qed. + +Lemma kron_comm_1_r : forall p, + (kron_comm p 1) = Matrix.I p. +Proof. + intros p. + apply mat_equiv_eq; [|rewrite Nat.mul_1_l, Nat.mul_1_r|]; auto with wf_db. + apply kron_comm_1_r_mat_equiv. +Qed. + +Lemma kron_comm_1_l_mat_equiv : forall p, + (kron_comm 1 p) ≡ Matrix.I p. +Proof. + intros p. + intros s t Hs Ht. + unfold kron_comm. + unfold make_WF. + unfold Matrix.I. + rewrite Nat.mul_1_l, Nat.div_1_r, Nat.mod_1_r, Nat.div_small, Nat.mod_small by lia. + bdestructΩ'. +Qed. + +Lemma kron_comm_1_l : forall p, + (kron_comm 1 p) = Matrix.I p. +Proof. + intros p. + apply mat_equiv_eq; [|rewrite Nat.mul_1_l, Nat.mul_1_r|]; auto with wf_db. + apply kron_comm_1_l_mat_equiv. +Qed. + +Definition mx_to_vec {n m} (A : Matrix n m) : Vector (m * n) := + make_WF (fun i j => A (i mod n)%nat (i / n)%nat + (* Note: goes columnwise. Rowwise would be: + make_WF (fun i j => A (i / m)%nat (i mod n)%nat + *) +). + +Lemma WF_mx_to_vec {n m} (A : Matrix n m) : WF_Matrix (mx_to_vec A). +Proof. unfold mx_to_vec; auto with wf_db. Qed. +#[export] Hint Resolve WF_mx_to_vec : wf_db. + +(* Compute vec_to_list (mx_to_vec (Matrix.I 2)). *) +From Coq Require Import ZArith. +Ltac Zify.zify_post_hook ::= PreOmega.Z.div_mod_to_equations. + +Lemma kron_comm_mx_to_vec_helper : forall i p q, (i < p * q)%nat -> + (p * (i mod q) + i / q < p * q)%nat. +Proof. + intros i p q Hi. + show_moddy_lt. +Qed. + +Lemma mx_to_vec_additive_mat_equiv {n m} (A B : Matrix n m) : + mx_to_vec (A .+ B) ≡ mx_to_vec A .+ mx_to_vec B. +Proof. + intros i j Hi Hj. + replace j with O by lia; clear dependent j. + unfold mx_to_vec, make_WF, Mplus. + bdestructΩ'. +Qed. + +Lemma mx_to_vec_additive {n m} (A B : Matrix n m) : + mx_to_vec (A .+ B) = mx_to_vec A .+ mx_to_vec B. +Proof. + apply mat_equiv_eq; auto with wf_db. + apply mx_to_vec_additive_mat_equiv. +Qed. + +Lemma if_mult_dist_r (b : bool) (z : C) : + (if b then C1 else C0) * z = + if b then z else C0. +Proof. + destruct b; lca. +Qed. + +Lemma if_mult_dist_l (b : bool) (z : C) : + z * (if b then C1 else C0) = + if b then z else C0. +Proof. + destruct b; lca. +Qed. + +Lemma if_mult_and (b c : bool) : + (if b then C1 else C0) * (if c then C1 else C0) = + if (b && c) then C1 else C0. +Proof. + destruct b; destruct c; lca. +Qed. + +Lemma kron_comm_mx_to_vec_mat_equiv : forall p q (A : Matrix p q), + kron_comm p q × mx_to_vec A ≡ mx_to_vec (A ⊤). +Proof. + intros p q A. + intros i j Hi Hj. + replace j with O by lia; clear dependent j. + unfold transpose, mx_to_vec, kron_comm, make_WF, Mmult. + rewrite (Nat.mul_comm q p). + replace_bool_lia (i . + destruct p; [lia|]. + destruct q; [lia|]. + split. + + rewrite Nat.add_comm, Nat.mul_comm. + rewrite Nat.Div0.mod_add by easy. + rewrite Nat.mod_small; [lia|]. + show_moddy_lt. + + rewrite Nat.mul_comm, Nat.div_add_l by easy. + rewrite Nat.div_small; [lia|]. + show_moddy_lt. + - intros [Hmodp Hdivp]. + rewrite (Nat.div_mod_eq k p). + lia. + } + apply big_sum_unique. + exists (p * (i mod q) + i / q)%nat; repeat split; + [apply kron_comm_mx_to_vec_helper; easy | rewrite Nat.eqb_refl | intros; bdestructΩ'simp]. + destruct p; [lia|]; + destruct q; [lia|]. + f_equal. + - rewrite Nat.add_comm, Nat.mul_comm, Nat.Div0.mod_add, Nat.mod_small; try easy. + show_moddy_lt. + - rewrite Nat.mul_comm, Nat.div_add_l by easy. + rewrite Nat.div_small; [lia|]. + show_moddy_lt. +Qed. + +Lemma kron_comm_mx_to_vec : forall p q (A : Matrix p q), + kron_comm p q × mx_to_vec A = mx_to_vec (A ⊤). +Proof. + intros p q A. + apply mat_equiv_eq; auto with wf_db. + apply kron_comm_mx_to_vec_mat_equiv. +Qed. + +Lemma kron_comm_ei_kron_ei_sum_mat_equiv : forall p q, + kron_comm p q ≡ + big_sum (G:=Matrix (p*q) (q*p)) + (fun i => big_sum (fun j => + (@e_i p i ⊗ @e_i q j) × ((@e_i q j ⊗ @e_i p i) ⊤)) + q) p. +Proof. + intros p q. + intros i j Hi Hj. + rewrite Msum_Csum. + erewrite big_sum_eq_bounded. + 2: { + intros k Hk. + rewrite Msum_Csum. + erewrite big_sum_eq_bounded. + 2: { + intros l Hl. + unfold Mmult, kron, transpose, e_i. + erewrite big_sum_eq_bounded. + 2: { + intros m Hm. + (* replace m with O by lia. *) + rewrite Nat.div_1_r, Nat.mod_1_r. + replace_bool_lia (m =? 0) true; rewrite 4!andb_true_r. + rewrite 3!if_mult_and. + match goal with + |- context[if ?b then _ else _] => + replace b with ((i =? k * q + l) && (j =? l * p + k)) + end. + 1: reflexivity. (* set our new function *) + clear dependent m. + rewrite eq_iff_eq_true, 8!andb_true_iff, + 6!Nat.eqb_eq, 4!Nat.ltb_lt. + split. + - intros [Hieq Hjeq]. + subst i j. + rewrite 2!Nat.div_add_l, Nat.div_small, Nat.add_0_r by lia. + rewrite Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small, + Nat.div_small, Nat.add_0_r by lia. + rewrite Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small by lia. + easy. + - intros [[[] []] [[] []]]. + split. + + rewrite (Nat.div_mod_eq i q) by lia; lia. + + rewrite (Nat.div_mod_eq j p) by lia; lia. + } + simpl; rewrite Cplus_0_l. + reflexivity. + } + apply big_sum_unique. + exists (i mod q). + split; [|split]. + - apply Nat.mod_upper_bound; lia. + - reflexivity. + - intros l Hl Hnmod. + bdestructΩ'simp. + exfalso; apply Hnmod. + rewrite Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small by lia; lia. + } + symmetry. + apply big_sum_unique. + exists (j mod p). + repeat split. + - apply Nat.mod_upper_bound; lia. + - unfold kron_comm, make_WF. + replace_bool_lia (i big_sum (fun j => + (@e_i p i ⊗ @e_i q j) × ((@e_i q j ⊗ @e_i p i) ⊤)) + q) p. +Proof. + intros p q. + apply mat_equiv_eq; auto with wf_db. + apply kron_comm_ei_kron_ei_sum_mat_equiv. +Qed. + +Lemma kron_comm_ei_kron_ei_sum'_mat_equiv : forall p q, + kron_comm p q ≡ + big_sum (fun ij => + let i := (ij / q)%nat in let j := (ij mod q) in + ((@e_i p i ⊗ @e_i q j) × ((@e_i q j ⊗ @e_i p i) ⊤))) (p*q). +Proof. + intros p q. + rewrite kron_comm_ei_kron_ei_sum, big_sum_double_sum, Nat.mul_comm. + reflexivity. +Qed. + +(* TODO: put somewhere sensible *) +Lemma big_sum_mat_equiv_bounded : forall {o p} (f g : nat -> Matrix o p) (n : nat), + (forall x : nat, (x < n)%nat -> f x ≡ g x) -> big_sum f n ≡ big_sum g n. +Proof. + intros. + induction n. + - easy. + - simpl. + rewrite IHn, H; [easy|lia|auto]. +Qed. + +Lemma kron_comm_Hij_sum_mat_equiv : forall p q, + kron_comm p q ≡ + big_sum (fun i => big_sum (fun j => + @kron p q q p (@e_i p i × ((@e_i q j) ⊤)) + ((@Mmult p 1 q (@e_i p i) (((@e_i q j) ⊤))) ⊤)) q) p. +Proof. + intros p q. + rewrite kron_comm_ei_kron_ei_sum_mat_equiv. + apply big_sum_mat_equiv_bounded; intros i Hi. + apply big_sum_mat_equiv_bounded; intros j Hj. + rewrite kron_transpose, kron_mixed_product. + rewrite Mmult_transpose, transpose_involutive. + easy. +Qed. + +Lemma kron_comm_Hij_sum : forall p q, + kron_comm p q = + big_sum (fun i => big_sum (fun j => + e_i i × (e_i j) ⊤ ⊗ + (e_i i × (e_i j) ⊤) ⊤) q) p. +Proof. + intros p q. + apply mat_equiv_eq; [auto with wf_db.. | ]. + apply kron_comm_Hij_sum_mat_equiv. +Qed. + + +Lemma kron_comm_ei_kron_ei_sum' : forall p q, + kron_comm p q = + big_sum (fun ij => + let i := (ij / q)%nat in let j := (ij mod q) in + ((e_i i ⊗ e_i j) × ((e_i j ⊗ e_i i) ⊤))) (p*q). +Proof. + intros p q. + rewrite kron_comm_ei_kron_ei_sum, big_sum_double_sum, Nat.mul_comm. + reflexivity. +Qed. + +Local Notation H := (fun i j => e_i i × (e_i j)⊤). + +Lemma kron_comm_Hij_sum'_mat_equiv : forall p q, + kron_comm p q ≡ + big_sum ( fun ij => + let i := (ij / q)%nat in let j := (ij mod q) in + H i j ⊗ (H i j) ⊤) (p*q). +Proof. + intros p q. + rewrite kron_comm_Hij_sum_mat_equiv, big_sum_double_sum, Nat.mul_comm. + easy. +Qed. + +Lemma kron_comm_Hij_sum' : forall p q, + kron_comm p q = + big_sum (fun ij => + let i := (ij / q)%nat in let j := (ij mod q) in + H i j ⊗ (H i j) ⊤) (p*q). +Proof. + intros p q. + rewrite kron_comm_Hij_sum, big_sum_double_sum, Nat.mul_comm. + easy. +Qed. + + +Lemma div_eq_iff : forall a b c, b <> O -> + (a / b)%nat = c <-> (b * c <= a /\ a < b * (S c))%nat. +Proof. + intros a b c Hb. + split. + intros Hadivb. + split; + subst c. + - rewrite (Nat.div_mod_eq a b) at 2; lia. + - now apply Nat.mul_succ_div_gt. + - intros [Hge Hlt]. + symmetry. + apply (Nat.div_unique _ _ _ (a - b*c)); lia. +Qed. + +Lemma div_eqb_iff : forall a b c, b <> O -> + (a / b)%nat =? c = ((b * c <=? a) && (a + (o <> O) -> (m <> O) -> + (@e_i n k)⊤ ⊗ A = (fun i j => + if (i + (o <> O) -> (m <> O) -> + (@e_i n k)⊤ ⊗ A ≡ (fun i j => + if (i + (@e_i n k)⊤ ⊗ A ≡ (fun i j => + if (i + (o <> O) -> (m <> O) -> + (@e_i n k) ⊗ A = (fun i j => + if (j + (o <> O) -> (m <> O) -> + (@e_i n k) ⊗ A ≡ (fun i j => + if (j + (@e_i n k) ⊗ A ≡ (fun i j => + if (j + (o <> O) -> (m <> O) -> + (@e_i n k)⊤ ⊗ A = (fun i j => + if (i ((j/o)%nat=k)) by lia; + rewrite Hrw; clear Hrw. + symmetry. + rewrite div_eq_iff by lia. + lia. + - replace (i / m =? 0) with false. + rewrite andb_false_r; easy. + symmetry. + rewrite Nat.eqb_neq. + rewrite Nat.div_small_iff; lia. +Qed. + +Lemma kron_e_i_transpose_l'_mat_equiv : forall k n m o (A : Matrix m o), (k < n)%nat -> + (o <> O) -> (m <> O) -> + (@e_i n k)⊤ ⊗ A ≡ (fun i j => + if (i + (@e_i n k)⊤ ⊗ A ≡ (fun i j => + if (i + (o <> O) -> (m <> O) -> + (@e_i n k) ⊗ A = (fun i j => + if (j ((i/m)%nat=k)) by lia; + rewrite Hrw; clear Hrw. + symmetry. + rewrite div_eq_iff by lia. + lia. + - replace (j / o =? 0) with false. + rewrite andb_false_r; easy. + symmetry. + rewrite Nat.eqb_neq. + rewrite Nat.div_small_iff; lia. +Qed. + +Lemma kron_e_i_l'_mat_equiv : forall k n m o (A : Matrix m o), (k < n)%nat -> + (o <> O) -> (m <> O) -> + (@e_i n k) ⊗ A ≡ (fun i j => + if (j + (o <> O) -> (m <> O) -> + (@e_i n k) ⊗ A ≡ (fun i j => + if (j + (o <> O) -> (m <> O) -> + A ⊗ (@e_i n k) = (fun i j => + if (i mod n =? k) then A (i / n)%nat j else 0). +Proof. + intros k n m o A Hk Ho Hm. + apply functional_extensionality; intros i; + apply functional_extensionality; intros j. + unfold kron, e_i. + rewrite if_mult_dist_l, Nat.div_1_r. + rewrite Nat.mod_1_r, Nat.eqb_refl, andb_true_r. + replace (i mod n + (o <> O) -> (m <> O) -> + A ⊗ (@e_i n k) ≡ (fun i j => + if (i mod n =? k) then A (i / n)%nat j else 0). +Proof. + intros. + rewrite kron_e_i_r; easy. +Qed. + +Lemma kron_e_i_r_mat_equiv' : forall k n m o (A : Matrix m o), (k < n)%nat -> + A ⊗ (@e_i n k) ≡ (fun i j => + if (i mod n =? k) then A (i / n)%nat j else 0). +Proof. + intros. + destruct m; [|destruct o]; + try (intros i j Hi Hj; lia). + rewrite kron_e_i_r; easy. +Qed. + +Lemma kron_e_i_transpose_r : forall k n m o (A : Matrix m o), (k < n)%nat -> + (o <> O) -> (m <> O) -> + A ⊗ (@e_i n k) ⊤ = (fun i j => + if (j mod n =? k) then A i (j / n)%nat else 0). +Proof. + intros k n m o A Hk Ho Hm. + apply functional_extensionality; intros i; + apply functional_extensionality; intros j. + unfold kron, transpose, e_i. + rewrite if_mult_dist_l, Nat.div_1_r. + rewrite Nat.mod_1_r, Nat.eqb_refl, andb_true_r. + replace (j mod n + (o <> O) -> (m <> O) -> + A ⊗ (@e_i n k) ⊤ ≡ (fun i j => + if (j mod n =? k) then A i (j / n)%nat else 0). +Proof. + intros. + rewrite kron_e_i_transpose_r; easy. +Qed. + +Lemma kron_e_i_transpose_r_mat_equiv' : forall k n m o (A : Matrix m o), (k < n)%nat -> + A ⊗ (@e_i n k) ⊤ ≡ (fun i j => + if (j mod n =? k) then A i (j / n)%nat else 0). +Proof. + intros. + destruct m; [|destruct o]; + try (intros i j Hi Hj; lia). + rewrite kron_e_i_transpose_r; easy. +Qed. + +Lemma ei_kron_I_kron_ei : forall m n k, (k < n)%nat -> m <> O -> + (@e_i n k) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n k) = + (fun i j => if (i mod n =? k) && (j / m =? k)%nat + && (i / n =? j - k * m) && (i / n m <> O -> + (@e_i n k) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n k) ≡ + (fun i j => if (i mod n =? k) && (j / m =? k)%nat + && (i / n =? j - k * m) && (i / n + (@e_i n k) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n k) ≡ + (fun i j => if (i mod n =? k) && (j / m =? k)%nat + && (i / n =? j - k * m) && (i / n + (@e_i n j) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n j)) n. +Proof. + intros m n. + intros i j Hi Hj. + rewrite Msum_Csum. + erewrite big_sum_eq_bounded. + 2: { + intros ij Hij. + rewrite ei_kron_I_kron_ei by lia. + reflexivity. + } + unfold kron_comm, make_WF. + do 2 simplify_bools_lia_one_kernel. + replace (i / n (@e_i n j) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n j)) n. +Proof. + intros m n. + apply mat_equiv_eq; + [|eapply WF_Matrix_dim_change; [lia..|]|]; + [auto with wf_db..|]. + apply kron_comm_kron_form_sum_mat_equiv; easy. +Qed. + +Lemma kron_comm_kron_form_sum' : forall m n, + kron_comm m n = big_sum (fun i => + (@e_i m i) ⊗ (Matrix.I n) ⊗ (@e_i m i)⊤) m. +Proof. + intros. + rewrite <- (kron_comm_transpose n m). + rewrite (kron_comm_kron_form_sum n m). + replace (n * m)%nat with (1 * n * m)%nat by lia. + replace (m * n)%nat with (m * n * 1)%nat by lia. + rewrite (Nat.mul_1_r (m * n * 1)). + etransitivity; + [apply Msum_transpose|]. + apply big_sum_eq_bounded. + intros k Hk. + restore_dims. + rewrite !kron_transpose. + now rewrite id_transpose_eq, transpose_involutive. +Qed. + +Lemma kron_comm_kron_form_sum'_mat_equiv : forall m n, + kron_comm m n ≡ big_sum (fun i => + (@e_i m i) ⊗ (Matrix.I n) ⊗ (@e_i m i)⊤) m. +Proof. + intros. + rewrite kron_comm_kron_form_sum'; easy. +Qed. + +Lemma e_i_dot_is_component_mat_equiv : forall p k (x : Vector p), + (k < p)%nat -> + (@e_i p k) ⊤ × x ≡ x k O .* Matrix.I 1. +Proof. + intros p k x Hk. + intros i j Hi Hj; + replace i with O by lia; + replace j with O by lia; + clear i Hi; + clear j Hj. + unfold Mmult, transpose, scale, e_i, Matrix.I. + simpl_bools. + rewrite Cmult_1_r. + apply big_sum_unique. + exists k. + split; [easy|]. + bdestructΩ'simp. + rewrite Cmult_1_l. + split; [easy|]. + intros l Hl Hkl. + bdestructΩ'simp. +Qed. + +Lemma e_i_dot_is_component : forall p k (x : Vector p), + (k < p)%nat -> WF_Matrix x -> + (@e_i p k) ⊤ × x = x k O .* Matrix.I 1. +Proof. + intros p k x Hk HWF. + apply mat_equiv_eq; auto with wf_db. + apply e_i_dot_is_component_mat_equiv; easy. +Qed. + +Lemma kron_e_i_e_i : forall p q k l, + (k < p)%nat -> (l < q)%nat -> + @e_i q l ⊗ @e_i p k = @e_i (p*q) (l*p + k). +Proof. + intros p q k l Hk Hl. + apply functional_extensionality; intro i. + apply functional_extensionality; intro j. + unfold kron, e_i. + rewrite Nat.mod_1_r, Nat.div_1_r. + rewrite if_mult_and. + apply f_equal_if; [|easy..]. + rewrite Nat.eqb_refl, andb_true_r. + destruct (j =? 0); [|rewrite 2!andb_false_r; easy]. + rewrite 2!andb_true_r. + rewrite eq_iff_eq_true, 4!andb_true_iff, 3!Nat.eqb_eq, 3!Nat.ltb_lt. + split. + - intros [[] []]. + rewrite (Nat.div_mod_eq i p). + split; nia. + - intros []. + subst i. + rewrite Nat.div_add_l, Nat.div_small, Nat.add_0_r, + Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small by lia. + easy. +Qed. + +Lemma kron_e_i_e_i_mat_equiv : forall p q k l, + (k < p)%nat -> (l < q)%nat -> + @e_i q l ⊗ @e_i p k ≡ @e_i (p*q) (l*p + k). +Proof. + intros p q k l; intros. + rewrite (kron_e_i_e_i p q); easy. +Qed. + +Lemma kron_eq_sum_mat_equiv : forall p q (x : Vector q) (y : Vector p), + y ⊗ x ≡ big_sum (fun ij => + let i := (ij / q)%nat in let j := ij mod q in + (x j O * y i O) .* (@e_i p i ⊗ @e_i q j)) (p * q). +Proof. + intros p q x y. + erewrite big_sum_eq_bounded. + 2: { + intros ij Hij. + simpl. + rewrite (@kron_e_i_e_i q p) by + (try apply Nat.mod_upper_bound; try apply Nat.Div0.div_lt_upper_bound; lia). + rewrite (Nat.mul_comm (ij / q) q). + rewrite <- (Nat.div_mod_eq ij q). + reflexivity. + } + intros i j Hi Hj. + replace j with O by lia; clear j Hj. + simpl. + rewrite Msum_Csum. + symmetry. + apply big_sum_unique. + exists i. + split; [lia|]. + unfold e_i; split. + - unfold scale, kron; bdestructΩ'simp. + - intros j Hj Hij. + unfold scale, kron; bdestructΩ'simp. +Qed. + +Lemma kron_eq_sum : forall p q (x : Vector q) (y : Vector p), + WF_Matrix x -> WF_Matrix y -> + y ⊗ x = big_sum (fun ij => + let i := (ij / q)%nat in let j := ij mod q in + (x j O * y i O) .* (@e_i p i ⊗ @e_i q j)) (p * q). +Proof. + intros p q x y Hwfx Hwfy. + apply mat_equiv_eq; [| |]; auto with wf_db. + apply kron_eq_sum_mat_equiv. +Qed. + +Lemma kron_comm_commutes_vectors_l_mat_equiv : forall p q (x : Vector q) (y : Vector p), + kron_comm p q × (x ⊗ y) ≡ (y ⊗ x). +Proof. + intros p q x y. + rewrite kron_comm_ei_kron_ei_sum'_mat_equiv, Mmult_Msum_distr_r. + + rewrite (big_sum_mat_equiv_bounded _ + (fun k => x (k mod q) 0 * y (k / q) 0 .* (e_i (k / q) ⊗ e_i (k mod q)))%nat); + [rewrite <- kron_eq_sum_mat_equiv; easy|]. + intros k Hk. + simpl. + rewrite Mmult_assoc. + change 1%nat with (1 * 1)%nat. + restore_dims. + rewrite (kron_transpose' (@e_i q (k mod q)) (@e_i p (k / q))). + rewrite kron_mixed_product. + rewrite 2!(e_i_dot_is_component_mat_equiv) by show_moddy_lt. + rewrite Mscale_kron_dist_l, Mscale_kron_dist_r, Mscale_assoc. + rewrite kron_1_l, Mscale_mult_dist_r, Mmult_1_r by auto with wf_db. + reflexivity. +Qed. + +Lemma kron_comm_commutes_vectors_l : forall p q (x : Vector q) (y : Vector p), + WF_Matrix x -> WF_Matrix y -> + kron_comm p q × (x ⊗ y) = (y ⊗ x). +Proof. + intros p q x y Hwfx Hwfy. + apply mat_equiv_eq; auto with wf_db. + apply kron_comm_commutes_vectors_l_mat_equiv. +Qed. + +Lemma kron_basis_vector_basis_vector : forall p q k l, + (k < p)%nat -> (l < q)%nat -> + basis_vector q l ⊗ basis_vector p k = basis_vector (p*q) (l*p + k). +Proof. + intros p q k l Hk Hl. + apply functional_extensionality; intros i. + apply functional_extensionality; intros j. + unfold kron, basis_vector. + rewrite Nat.mod_1_r, Nat.div_1_r, Nat.eqb_refl, andb_true_r, if_mult_and. + pose proof (Nat.div_mod_eq i p). + bdestructΩ'simp. + rewrite Nat.div_add_l, Nat.div_small in * by lia. + lia. +Qed. + +Lemma kron_basis_vector_basis_vector_mat_equiv : forall p q k l, + (k < p)%nat -> (l < q)%nat -> + basis_vector q l ⊗ basis_vector p k ≡ basis_vector (p*q) (l*p + k). +Proof. + intros. + rewrite (kron_basis_vector_basis_vector p q); easy. +Qed. + +Lemma kron_extensionality_mat_equiv : forall n m s t (A B : Matrix (n*m) (s*t)), + (forall (x : Vector s) (y :Vector t), + A × (x ⊗ y) ≡ B × (x ⊗ y)) -> + A ≡ B. +Proof. + intros n m s t A B Hext. + apply mat_equiv_of_equiv_on_ei. + intros i Hi. + + pose proof (Nat.Div0.div_lt_upper_bound i t s ltac:(lia)). + pose proof (Nat.mod_upper_bound i s ltac:(lia)). + pose proof (Nat.mod_upper_bound i t ltac:(lia)). + + specialize (Hext (@e_i s (i / t)) (@e_i t (i mod t))). + rewrite (kron_e_i_e_i_mat_equiv t s) in Hext by lia. + (* simpl in Hext. *) + rewrite (Nat.mul_comm (i/t) t), <- (Nat.div_mod_eq i t) in Hext. + rewrite (Nat.mul_comm t s) in Hext. easy. +Qed. + +Lemma kron_extensionality : forall n m s t (A B : Matrix (n*m) (s*t)), + WF_Matrix A -> WF_Matrix B -> + (forall (x : Vector s) (y :Vector t), + WF_Matrix x -> WF_Matrix y -> + A × (x ⊗ y) = B × (x ⊗ y)) -> + A = B. +Proof. + intros n m s t A B HwfA HwfB Hext. + apply equal_on_basis_vectors_implies_equal; try easy. + intros i Hi. + + pose proof (Nat.Div0.div_lt_upper_bound i t s ltac:(lia)). + pose proof (Nat.mod_upper_bound i s ltac:(lia)). + pose proof (Nat.mod_upper_bound i t ltac:(lia)). + + specialize (Hext (basis_vector s (i / t)) (basis_vector t (i mod t)) + ltac:(apply basis_vector_WF; easy) + ltac:(apply basis_vector_WF; easy) + ). + rewrite (kron_basis_vector_basis_vector t s) in Hext by lia. + + simpl in Hext. + rewrite (Nat.mul_comm (i/t) t), <- (Nat.div_mod_eq i t) in Hext. + rewrite (Nat.mul_comm t s) in Hext. easy. +Qed. + +Lemma kron_comm_commutes_mat_equiv : forall n s m t + (A : Matrix n s) (B : Matrix m t), + kron_comm m n × (A ⊗ B) × (kron_comm s t) ≡ (B ⊗ A). +Proof. + intros n s m t A B. + apply kron_extensionality_mat_equiv. + intros x y. + rewrite (Mmult_assoc (_ × _)). + rewrite kron_comm_commutes_vectors_l_mat_equiv. + rewrite Mmult_assoc, kron_mixed_product. + rewrite kron_comm_commutes_vectors_l_mat_equiv. + rewrite <- kron_mixed_product. + easy. +Qed. + +Lemma kron_comm_commutes : forall n s m t + (A : Matrix n s) (B : Matrix m t), + WF_Matrix A -> WF_Matrix B -> + kron_comm m n × (A ⊗ B) × (kron_comm s t) = (B ⊗ A). +Proof. + intros n s m t A B HwfA HwfB. + apply kron_extensionality; + auto with wf_db. + intros x y Hwfx Hwfy. + rewrite (Mmult_assoc (_ × _)). + rewrite kron_comm_commutes_vectors_l by easy. + rewrite Mmult_assoc, kron_mixed_product. + rewrite kron_comm_commutes_vectors_l by auto with wf_db. + rewrite <- kron_mixed_product. + easy. +Qed. + +Lemma commute_kron_mat_equiv : forall n s m t + (A : Matrix n s) (B : Matrix m t), + (A ⊗ B) ≡ kron_comm n m × (B ⊗ A) × (kron_comm t s). +Proof. + intros n s m t A B. + now rewrite kron_comm_commutes_mat_equiv. +Qed. + + +Lemma commute_kron : forall n s m t + (A : Matrix n s) (B : Matrix m t), + WF_Matrix A -> WF_Matrix B -> + (A ⊗ B) = kron_comm n m × (B ⊗ A) × (kron_comm t s). +Proof. + intros n s m t A B HA HB. + now rewrite kron_comm_commutes. +Qed. + +(* TODO: Move to the right place *) +Lemma WF_Matrix_dim_change_iff m n m' n' (A : Matrix m n) : + m = m' -> n = n' -> + @WF_Matrix m' n' A <-> WF_Matrix A. +Proof. + intros. + now subst. +Qed. + +Lemma kron_comm_pows2_eq_perm_to_matrix_rotr n o : + kron_comm (2^o) (2^n) = perm_to_matrix (n + o) (rotr (n + o) n). +Proof. + symmetry. + apply equal_on_basis_states_implies_equal; + [|rewrite WF_Matrix_dim_change_iff by show_pow2_le |]; + [auto with wf_db..|]. + intros f. + rewrite perm_to_matrix_permutes_qubits by auto with perm_db. + rewrite (f_to_vec_split'_eq _ _ f). + restore_dims. + rewrite kron_comm_commutes_vectors_l by auto with wf_db. + rewrite Nat.add_comm, f_to_vec_split'_eq. + f_equal; apply f_to_vec_eq; intros i Hi; f_equal; + unfold rotr; simplify_bools_lia; solve_simple_mod_eqns. +Qed. + +Lemma kron_comm_eq_perm_mat_of_kron_comm_perm p q : + kron_comm p q = perm_mat (p * q) (kron_comm_perm p q). +Proof. + apply mat_equiv_eq; auto using WF_Matrix_dim_change with wf_db zarith. + apply mat_equiv_of_equiv_on_ei. + intros k Hk. + rewrite (Nat.div_mod_eq k p) at 1. + rewrite (Nat.mul_comm p (k/p)), (Nat.mul_comm q p). + rewrite <- (kron_e_i_e_i p q) at 1 by show_moddy_lt. + restore_dims. + rewrite kron_comm_commutes_vectors_l by auto with wf_db. + rewrite perm_mat_permutes_ei_r by show_moddy_lt. + rewrite (kron_e_i_e_i q p) by show_moddy_lt. + rewrite Nat.mul_comm. + unfold kron_comm_perm. + bdestructΩ'. +Qed. + +Lemma kron_comm_mul_inv_mat_equiv : forall p q, + kron_comm p q × kron_comm q p ≡ Matrix.I (p * q). +Proof. + intros p q. + rewrite (kron_comm_eq_perm_mat_of_kron_comm_perm p q). + rewrite (kron_comm_eq_perm_mat_of_kron_comm_perm q p). + rewrite Nat.mul_comm. + rewrite perm_mat_Mmult by auto with perm_db. + cleanup_perm_inv. + now rewrite perm_mat_idn. +Qed. + +Lemma kron_comm_mul_inv : forall p q, + kron_comm p q × kron_comm q p = Matrix.I _. +Proof. + intros p q. + apply mat_equiv_eq; auto with wf_db. + rewrite kron_comm_mul_inv_mat_equiv; easy. +Qed. + +Lemma kron_comm_mul_transpose_r_mat_equiv : forall p q, + kron_comm p q × (kron_comm p q) ⊤ ≡ Matrix.I _. +Proof. + intros p q. + rewrite (kron_comm_transpose p q). + apply kron_comm_mul_inv_mat_equiv. +Qed. + +Lemma kron_comm_mul_transpose_r : forall p q, + kron_comm p q × (kron_comm p q) ⊤ = Matrix.I _. +Proof. + intros p q. + rewrite (kron_comm_transpose p q). + apply kron_comm_mul_inv. +Qed. + +Lemma kron_comm_mul_transpose_l_mat_equiv : forall p q, + (kron_comm p q) ⊤ × kron_comm p q ≡ Matrix.I _. +Proof. + intros p q. + rewrite <- (kron_comm_transpose q p). + rewrite (transpose_involutive _ _ (kron_comm q p)). + apply kron_comm_mul_transpose_r_mat_equiv. +Qed. + +Lemma kron_comm_mul_transpose_l : forall p q, + (kron_comm p q) ⊤ × kron_comm p q = Matrix.I _. +Proof. + intros p q. + rewrite <- (kron_comm_transpose q p). + rewrite (transpose_involutive _ _ (kron_comm q p)). + apply kron_comm_mul_transpose_r. +Qed. + +Lemma kron_comm_commutes_l_mat_equiv : forall n s m t + (A : Matrix n s) (B : Matrix m t), + kron_comm m n × (A ⊗ B) ≡ (B ⊗ A) × (kron_comm t s). +Proof. + intros n s m t A B. + match goal with |- ?A ≡ ?B => + rewrite <- (Mmult_1_r_mat_eq _ _ A), <- (Mmult_1_r_mat_eq _ _ B) + end. + rewrite (Nat.mul_comm t s). + rewrite <- (kron_comm_mul_transpose_r), <- 2!Mmult_assoc. + rewrite (kron_comm_commutes_mat_equiv n s m t). + apply Mmult_simplify_mat_equiv; [|easy]. + rewrite Mmult_assoc. + restore_dims. + rewrite (kron_comm_mul_inv_mat_equiv t s), Mmult_1_r_mat_eq. + easy. +Qed. + +Lemma kron_comm_commutes_l : forall n s m t + (A : Matrix n s) (B : Matrix m t), + WF_Matrix A -> WF_Matrix B -> + kron_comm m n × (A ⊗ B) = (B ⊗ A) × (kron_comm t s). +Proof. + intros n s m t A B HwfA HwfB. + apply mat_equiv_eq; auto with wf_db. + apply kron_comm_commutes_l_mat_equiv. +Qed. + +Lemma kron_comm_commutes_r_mat_equiv : forall n s m t + (A : Matrix n s) (B : Matrix m t), + (A ⊗ B) × kron_comm s t ≡ (kron_comm n m) × (B ⊗ A). +Proof. + intros. + rewrite kron_comm_commutes_l_mat_equiv; easy. +Qed. + +Lemma kron_comm_commutes_r : forall n s m t + (A : Matrix n s) (B : Matrix m t), + WF_Matrix A -> WF_Matrix B -> + (A ⊗ B) × kron_comm s t = (kron_comm n m) × (B ⊗ A). +Proof. + intros n s m t A B HA HB. + rewrite kron_comm_commutes_l; easy. +Qed. + + + +(* Lemma kron_comm_commutes_r : forall n s m t + (A : Matrix n s) (B : Matrix m t), + WF_Matrix A -> WF_Matrix B -> + kron_comm m n × (A ⊗ B) = (B ⊗ A) × (kron_comm t s). +Proof. + intros n s m t A B HwfA HwfB. + match goal with |- ?A = ?B => + rewrite <- (Mmult_1_r _ _ A), <- (Mmult_1_r _ _ B) ; auto with wf_db + end. + rewrite (Nat.mul_comm t s). + rewrite <- (kron_comm_mul_transpose_r), <- 2!Mmult_assoc. + rewrite (kron_comm_commutes n s m t) by easy. + apply Mmult_simplify; [|easy]. + rewrite Mmult_assoc. + rewrite (Nat.mul_comm s t), (kron_comm_mul_inv t s), Mmult_1_r by auto with wf_db. + easy. +Qed. *) + + +Lemma vector_eq_basis_comb_mat_equiv : forall n (y : Vector n), + y ≡ big_sum (fun i => y i O .* @e_i n i) n. +Proof. + intros n y. + intros i j Hi Hj. + replace j with O by lia; clear j Hj. + symmetry. + rewrite Msum_Csum. + apply big_sum_unique. + exists i. + repeat split; try easy. + - unfold ".*", e_i; bdestructΩ'simp. + - intros l Hl Hnk. + unfold ".*", e_i; bdestructΩ'simp. +Qed. + + +Lemma vector_eq_basis_comb : forall n (y : Vector n), + WF_Matrix y -> + y = big_sum (G:=Vector n) (fun i => y i O .* @e_i n i) n. +Proof. + intros n y Hwfy. + apply mat_equiv_eq; auto with wf_db. + apply vector_eq_basis_comb_mat_equiv. +Qed. + +(* Lemma kron_vecT_matrix_vec : forall m n o p + (P : Matrix m o) (y : Vector n) (z : Vector p), + WF_Matrix y -> WF_Matrix z -> WF_Matrix P -> + (z⊤) ⊗ P ⊗ y = @Mmult (m*n) (m*n) (o*p) (kron_comm m n) ((y × (z⊤)) ⊗ P). +Proof. + intros m n o p P y z Hwfy Hwfz HwfP. + match goal with |- ?A = ?B => + rewrite <- (Mmult_1_l _ _ A) ; auto with wf_db + end. + rewrite Nat.mul_1_l. + rewrite <- (kron_comm_mul_transpose_r), Mmult_assoc at 1. + rewrite Nat.mul_1_r, (Nat.mul_comm o p). + apply Mmult_simplify; [easy|]. + rewrite kron_comm_kron_form_sum. + rewrite Msum_transpose. + rewrite Mmult_Msum_distr_r. + erewrite big_sum_eq_bounded. + 2: { + intros k Hk. + pose proof (kron_transpose _ _ _ _ ((@e_i n k) ⊤ ⊗ Matrix.I m) (@e_i n k)) as H; + rewrite Nat.mul_1_l, Nat.mul_1_r, (Nat.mul_comm m n) in *; + rewrite H; clear H. + pose proof (kron_transpose _ _ _ _ ((@e_i n k) ⊤) (Matrix.I m)) as H; + rewrite Nat.mul_1_l in *; + rewrite H; clear H. + restore_dims. + rewrite 2!kron_mixed_product. + rewrite id_transpose_eq, Mmult_1_l by easy. + rewrite e_i_dot_is_component, transpose_involutive by easy. + (* rewrite <- Mmult_transpose. *) + rewrite Mscale_kron_dist_r, <- 2!Mscale_kron_dist_l. + rewrite kron_1_r. + rewrite <- Mscale_mult_dist_l. + reflexivity. + } + rewrite <- (kron_Msum_distr_r n _ P). + rewrite <- (Mmult_Msum_distr_r). + rewrite <- vector_eq_basis_comb by easy. + easy. +Qed. +*) + +Lemma kron_vecT_matrix_vec_mat_equiv : forall m n o p + (P : Matrix m o) (y : Vector n) (z : Vector p), + (z⊤) ⊗ P ⊗ y ≡ kron_comm m n × ((y × (z⊤)) ⊗ P). +Proof. + intros m n o p P y z. + match goal with |- ?A ≡ ?B => + rewrite <- (Mmult_1_l_mat_eq _ _ A) + end. + rewrite Nat.mul_1_l. + rewrite <- (kron_comm_mul_transpose_r_mat_equiv), Mmult_assoc at 1. + rewrite Nat.mul_1_r. + apply Mmult_simplify_mat_equiv; [easy|]. + rewrite kron_comm_kron_form_sum_mat_equiv. + replace (m * n)%nat with (1 * m * n)%nat by lia. + replace (n * m)%nat with (n * m * 1)%nat by lia. + rewrite (Msum_transpose (1*m*n) (n*m*1) n). + restore_dims. + rewrite Mmult_Msum_distr_r. + replace (n * m * 1)%nat with (1 * m * n)%nat by lia. + replace (p * o)%nat with (p * o * 1)%nat by lia. + rewrite (Nat.mul_1_r (p * o * 1)). + erewrite (big_sum_mat_equiv_bounded _ _ n). + 2: { + intros k Hk. + unshelve (instantiate (1:=_)). + refine (fun k : nat => y k 0%nat .* e_i k × (z) ⊤ ⊗ P); exact n. + pose proof (kron_transpose _ _ _ _ ((@e_i n k) ⊤ ⊗ Matrix.I m) (@e_i n k)) as H; + rewrite Nat.mul_1_l, Nat.mul_1_r, (Nat.mul_comm m n) in *; + rewrite H; clear H. + pose proof (kron_transpose _ _ _ _ ((@e_i n k) ⊤) (Matrix.I m)) as H; + rewrite Nat.mul_1_l in *; + rewrite H; clear H. + restore_dims. + rewrite 2!kron_mixed_product. + rewrite (id_transpose_eq m). + rewrite Mscale_mult_dist_l, transpose_involutive. + rewrite <- (kron_1_r _ _ P) at 2. + rewrite Mscale_kron_dist_l, <- !Mscale_kron_dist_r. + match goal with + |- (?A ⊗ ?B ⊗ ?C) ≡ _ => pose proof (kron_assoc_mat_equiv A B C) as H + end; + rewrite 4!Nat.mul_1_r in H; rewrite H by easy; clear H. + apply kron_simplify_mat_equiv; [easy|]. + epose proof (Mscale_kron_dist_r _ _ _ _ _ P (Matrix.I 1)) as H; + rewrite 2Nat.mul_1_r in H; + rewrite <- H; clear H. + match goal with + |- (?A ⊗ ?B) ≡ (?C ⊗ ?D) => pose proof (kron_simplify_mat_equiv A C B D) as H + end; + rewrite 2!Nat.mul_1_r in H. apply H. + - rewrite Mmult_1_l_mat_eq; easy. + - rewrite (e_i_dot_is_component_mat_equiv); easy. + } + rewrite <- (kron_Msum_distr_r n _ P). + rewrite <- (Mmult_Msum_distr_r). + replace (1*m*n)%nat with (n*m)%nat by lia. + replace (p*o*1)%nat with (p*o)%nat by lia. + apply kron_simplify_mat_equiv; [|easy]. + apply Mmult_simplify_mat_equiv; [|easy]. + symmetry. + apply vector_eq_basis_comb_mat_equiv. +Qed. + +Lemma kron_vecT_matrix_vec : forall m n o p + (P : Matrix m o) (y : Vector n) (z : Vector p), + WF_Matrix y -> WF_Matrix z -> WF_Matrix P -> + (z⊤) ⊗ P ⊗ y = kron_comm m n × ((y × (z⊤)) ⊗ P). +Proof. + intros m n o p P y z Hwfy Hwfz HwfP. + apply mat_equiv_eq; + [|rewrite ?Nat.mul_1_l, ?Nat.mul_1_r; apply WF_mult|]; + auto with wf_db. + apply kron_vecT_matrix_vec_mat_equiv. +Qed. + +Lemma kron_vec_matrix_vecT : forall m n o p + (Q : Matrix n o) (x : Vector m) (z : Vector p), + WF_Matrix x -> WF_Matrix z -> WF_Matrix Q -> + x ⊗ Q ⊗ (z⊤) = kron_comm m n × (Q ⊗ (x × z⊤)). +Proof. + intros m n o p Q x z Hwfx Hwfz HwfQ. + match goal with |- ?A = ?B => + rewrite <- (Mmult_1_l _ _ A) ; auto with wf_db + end. + rewrite Nat.mul_1_r. + rewrite <- (kron_comm_mul_transpose_r), Mmult_assoc at 1. + rewrite Nat.mul_1_l. + apply Mmult_simplify; [easy|]. + rewrite kron_comm_kron_form_sum'. + rewrite (Msum_transpose (m*n) (n*m) m). + restore_dims. + rewrite Mmult_Msum_distr_r. + erewrite big_sum_eq_bounded. + 2: { + intros k Hk. + restore_dims. + replace (@transpose (m*n) (n*m)) with + (@transpose (m*n*1) (1*n*m)) by (f_equal; lia). + rewrite kron_transpose. + rewrite kron_transpose, transpose_involutive. + restore_dims. + rewrite 2!kron_mixed_product. + rewrite id_transpose_eq, Mmult_1_l by easy. + rewrite e_i_dot_is_component, transpose_involutive by easy. + rewrite 2!Mscale_kron_dist_l, kron_1_l, <-Mscale_kron_dist_r by easy. + rewrite <- Mscale_mult_dist_l. + restore_dims. + reflexivity. + } + erewrite big_sum_eq_bounded. + 2: { + intros k Hk. + rewrite transpose_involutive. + reflexivity. + } + rewrite <- (kron_Msum_distr_l m _ Q). + rewrite <- (Mmult_Msum_distr_r). + rewrite <- vector_eq_basis_comb by easy. + easy. +Qed. + +(* TODO: Relocate *) +Lemma kron_1_l_mat_equiv : forall {n m} (A : Matrix n m), + Matrix.I 1 ⊗ A ≡ A. +Proof. + intros n m A. + intros i j Hi Hj. + unfold kron, I. + rewrite 2!Nat.div_small, 2!Nat.mod_small by lia. + rewrite Cmult_1_l. + easy. +Qed. + +Lemma kron_1_r_mat_equiv : forall {n m} (A : Matrix n m), + A ⊗ Matrix.I 1 ≡ A. +Proof. + intros n m A. + intros i j Hi Hj. + unfold kron, I. + rewrite 2!Nat.div_1_r, 2!Nat.mod_1_r by lia. + rewrite Cmult_1_r. + easy. +Qed. + +Lemma kron_vec_matrix_vecT_mat_equiv : forall m n o p + (Q : Matrix n o) (x : Vector m) (z : Vector p), + x ⊗ Q ⊗ (z⊤) ≡ kron_comm m n × (Q ⊗ (x × z⊤)). +Proof. + intros m n o p Q x z. + match goal with |- ?A ≡ ?B => + rewrite <- (Mmult_1_l_mat_eq _ _ A) + end. + rewrite Nat.mul_1_r. + rewrite <- (kron_comm_mul_transpose_r_mat_equiv), Mmult_assoc at 1. + rewrite Nat.mul_1_l. + apply Mmult_simplify_mat_equiv; [easy|]. + rewrite kron_comm_kron_form_sum'. + replace (@transpose (m*n) (n*m)) with + (@transpose (m*n*1) (1*n*m)) by (f_equal; lia). + rewrite (Msum_transpose (m*n*1) (1*n*m) m). + restore_dims. + rewrite Mmult_Msum_distr_r. + replace (@mat_equiv (n*m) (o*p)) + with (@mat_equiv (m*n*1) (1*o*p)) by (f_equal; lia). + erewrite (big_sum_mat_equiv_bounded). + 2: { + intros k Hk. + unshelve (instantiate (1:=(fun k : nat => + @kron n o m p Q + (@Mmult m 1 p (@scale m 1 (x k 0%nat) (@e_i m k)) + (@transpose p 1 z))))). + rewrite 2!kron_transpose. + restore_dims. + rewrite 2!kron_mixed_product. + rewrite id_transpose_eq, transpose_involutive. + rewrite Mscale_mult_dist_l, Mscale_kron_dist_r, <- Mscale_kron_dist_l. + replace (m*n*1)%nat with (1*n*m)%nat by lia. + replace (@kron n o m p) with (@kron (1*n) (1*o) m p) by (f_equal; lia). + apply kron_simplify_mat_equiv; [|easy]. + intros i j Hi Hj. + unfold kron. + rewrite (Mmult_1_l_mat_eq _ _ Q) by (apply Nat.mod_upper_bound; lia). + (* revert i j Hi Hj. *) + rewrite (e_i_dot_is_component_mat_equiv m k x Hk) by (apply Nat.Div0.div_lt_upper_bound; lia). + set (a:= (@kron 1 1 n o ((x k 0%nat .* Matrix.I 1)) Q) i j). + match goal with + |- ?A = _ => change A with a + end. + unfold a. + clear a. + rewrite Mscale_kron_dist_l. + unfold scale. + rewrite kron_1_l_mat_equiv by lia. + easy. + } + rewrite <- (kron_Msum_distr_l m _ Q). + rewrite <- (Mmult_Msum_distr_r). + rewrite (Nat.mul_comm m n). + rewrite Nat.mul_1_r, Nat.mul_1_l. + rewrite <- vector_eq_basis_comb_mat_equiv. + easy. +Qed. + +Lemma kron_comm_triple_cycle_mat : forall m n s t p q (A : Matrix m n) + (B : Matrix s t) (C : Matrix p q), + A ⊗ B ⊗ C ≡ (kron_comm (m*s) p) × (C ⊗ A ⊗ B) × (kron_comm q (t*n)). +Proof. + intros m n s t p q A B C. + rewrite (commute_kron_mat_equiv _ _ _ _ (A ⊗ B) C) by auto with wf_db. + rewrite (Nat.mul_comm n t), (Nat.mul_comm q (t*n)). + apply Mmult_simplify_mat_equiv; [|easy]. + apply Mmult_simplify_mat_equiv; [easy|]. + rewrite (Nat.mul_comm t n). + intros i j Hi Hj; + rewrite <- (kron_assoc_mat_equiv C A B); + [easy|lia|lia]. +Qed. + +Lemma kron_comm_triple_cycle : forall m n s t p q (A : Matrix m n) + (B : Matrix s t) (C : Matrix p q), WF_Matrix A -> WF_Matrix B -> WF_Matrix C -> + A ⊗ B ⊗ C = (kron_comm (m*s) p) × (C ⊗ A ⊗ B) × (kron_comm q (t*n)). +Proof. + intros m n s t p q A B C HA HB HC. + rewrite (commute_kron _ _ _ _ (A ⊗ B) C) by auto with wf_db. + rewrite kron_assoc by easy. + f_equal; try lia; f_equal; lia. +Qed. + +Lemma kron_comm_triple_cycle2_mat_equiv : forall m n s t p q (A : Matrix m n) + (B : Matrix s t) (C : Matrix p q), + A ⊗ (B ⊗ C) ≡ (kron_comm m (s*p)) × (B ⊗ C ⊗ A) × (kron_comm (q*t) n). +Proof. + intros m n s t p q A B C. + rewrite kron_assoc_mat_equiv. + intros i j Hi Hj. + rewrite (commute_kron_mat_equiv _ _ _ _ A (B ⊗ C)) by lia. + rewrite (Nat.mul_comm t q). + apply Mmult_simplify_mat_equiv; [|easy + lia..]. + apply Mmult_simplify_mat_equiv; [easy|]. + rewrite (Nat.mul_comm q t). + apply kron_assoc_mat_equiv. +Qed. + +Lemma kron_comm_triple_cycle2 : forall m n s t p q (A : Matrix m n) + (B : Matrix s t) (C : Matrix p q), WF_Matrix A -> WF_Matrix B -> WF_Matrix C -> + A ⊗ (B ⊗ C) = (kron_comm m (s*p)) × (B ⊗ C ⊗ A) × (kron_comm (q*t) n). +Proof. + intros m n s t p q A B C HA HB HC. + apply mat_equiv_eq; auto with wf_db. + apply kron_comm_triple_cycle2_mat_equiv. +Qed. + + + + + +(* #[export] Instance big_sum_mat_equiv_morphism {n m : nat} : + Proper (pointwise_relation nat (@mat_equiv n m) + ==> pointwise_relation nat (@mat_equiv n m)) + (@big_sum (Matrix n m) (M_is_monoid n m)) := big_sum_mat_equiv. *) + +(* Instance forall_mat_equiv_morphism {A: Type} {n m : nat} {f g : A -> Matrix m n}: + pointwise_relation A mat_equiv (fun x => f x) (fun x => f x). + +Instance forall_mat_equiv_morphism `{Equivalence A eqA, Equivalence B eqB} : + Proper ((eqA ==> eqB) ==> list_equiv eqA ==> list_equiv eqB) (@map A B). + +Goal (forall_relation (fun n:nat => @mat_equiv m m)) (fun n => Matrix.I m × direct_sum' (@Zero 0 0) (Matrix.I m)) (fun n => Matrix.I m). +setoid_rewrite Mmult_1_l_mat_eq. *) + + +Lemma id_eq_sum_kron_e_is_mat_equiv : forall n, + Matrix.I n ≡ big_sum (G:=Square n) (fun i => @e_i n i ⊗ (@e_i n i) ⊤) n. +Proof. + intros n. + symmetry. + intros i j Hi Hj. + rewrite Msum_Csum. + erewrite big_sum_eq_bounded. + 2: { + intros k Hk. + rewrite kron_e_i_l by lia. + unfold transpose, e_i. + rewrite <- andb_if. + replace_bool_lia (j @e_i n i ⊗ (@e_i n i) ⊤) n. +Proof. + intros n. + apply mat_equiv_eq; auto with wf_db. + apply id_eq_sum_kron_e_is_mat_equiv. +Qed. + +Lemma kron_comm_cycle_indices : forall t s n, + kron_comm (t*s) n = @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) + (kron_comm s (n*t)) (kron_comm t (s*n)). +Proof. + intros t s n. + rewrite kron_comm_kron_form_sum. + erewrite big_sum_eq_bounded. + 2: { + intros j Hj. + rewrite (Nat.mul_comm t s), <- id_kron, <- kron_assoc by auto with wf_db. + restore_dims. + rewrite kron_assoc by auto with wf_db. + (* rewrite (kron_assoc ((@e_i n j)⊤ ⊗ Matrix.I t) (Matrix.I s) (@e_i n j)) by auto with wf_db. *) + lazymatch goal with + |- ?A ⊗ ?B = _ => rewrite (commute_kron _ _ _ _ A B) by auto with wf_db + end. + (* restore_dims. *) + reflexivity. + } + (* rewrite ?Nat.mul_1_r, ?Nat.mul_1_l. *) + (* rewrite <- Mmult_Msum_distr_r. *) + + rewrite <- (Mmult_Msum_distr_r n _ (kron_comm (t*1) (n*s))). + rewrite <- Mmult_Msum_distr_l. + erewrite big_sum_eq_bounded. + 2: { + intros j Hj. + rewrite <- kron_assoc, (kron_assoc (Matrix.I t)) by auto with wf_db. + restore_dims. + reflexivity. + } + (* rewrite Nat.mul_1_l *) + rewrite <- (kron_Msum_distr_r n _ (Matrix.I s)). + rewrite <- (kron_Msum_distr_l n _ (Matrix.I t)). + rewrite 2!Nat.mul_1_r, 2!Nat.mul_1_l. + rewrite <- (id_eq_sum_kron_e_is n). + rewrite 2!id_kron. + restore_dims. + rewrite Mmult_1_r by auto with wf_db. + rewrite (Nat.mul_comm t n), (Nat.mul_comm n s). + easy. +Qed. + +Lemma kron_comm_cycle_indices_mat_equiv : forall t s n, + (kron_comm (t*s) n ≡ @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n))). +Proof. + intros t s n. + rewrite kron_comm_cycle_indices; easy. +Qed. + +Lemma kron_comm_cycle_indices_rev : forall t s n, + @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) = kron_comm (t*s) n. +Proof. + intros. + rewrite <- kron_comm_cycle_indices. + easy. +Qed. + +Lemma kron_comm_cycle_indices_rev_mat_equiv : forall t s n, + @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) ≡ kron_comm (t*s) n. +Proof. + intros. + rewrite <- kron_comm_cycle_indices. + easy. +Qed. + +Lemma kron_comm_triple_id : forall t s n, + (kron_comm (t*s) n) × (kron_comm (s*n) t) × (kron_comm (n*t) s) = Matrix.I (t*s*n). +Proof. + intros t s n. + rewrite kron_comm_cycle_indices. + restore_dims. + rewrite (Mmult_assoc (kron_comm s (n*t))). + restore_dims. + rewrite (kron_comm_mul_inv t (s*n)). + restore_dims. + rewrite Mmult_1_r by auto with wf_db. + rewrite (kron_comm_mul_inv). + f_equal; lia. +Qed. + +Lemma kron_comm_triple_id_mat_equiv : forall t s n, + (kron_comm (t*s) n) × (kron_comm (s*n) t) × (kron_comm (n*t) s) ≡ Matrix.I (t*s*n). +Proof. + intros t s n. + setoid_rewrite kron_comm_triple_id; easy. +Qed. + +Lemma kron_comm_triple_id' : forall n t s, + (kron_comm n (t*s)) × (kron_comm t (s*n)) × (kron_comm s (n*t)) = Matrix.I (t*s*n). +Proof. + intros n t s. + apply transpose_matrices. + rewrite 2!Mmult_transpose. + rewrite (kron_comm_transpose s (n*t)). + rewrite (kron_comm_transpose n (t*s)). + restore_dims. + rewrite (Nat.mul_assoc s n t), <- (Nat.mul_assoc t s n). + + rewrite (kron_comm_transpose t (s*n)). + rewrite Nat.mul_assoc. + replace (t*(s*n))%nat with (n*t*s)%nat by lia. + rewrite id_transpose_eq. + replace (n*t*s)%nat with (t*n*s)%nat by lia. + rewrite <- (kron_comm_triple_id t n s). + rewrite Mmult_assoc. + restore_dims. + replace (s*(t*n))%nat with (s*(n*t))%nat by lia. + replace (n*(t*s))%nat with (n*(s*t))%nat by lia. + replace (n*t*s)%nat with (t*n*s)%nat by lia. + apply Mmult_simplify; [f_equal; lia|]. + repeat (f_equal; try lia). +Qed. + +Lemma kron_comm_triple_id'_mat_equiv : forall t s n, + (kron_comm n (t*s)) × (kron_comm t (s*n)) × (kron_comm s (n*t)) = Matrix.I (t*s*n). +Proof. + intros t s n. + rewrite (kron_comm_triple_id' n t s). + easy. +Qed. + +Lemma kron_comm_triple_id'C : forall n t s, + (kron_comm n (s*t)) × (kron_comm t (n*s)) × (kron_comm s (t*n)) = Matrix.I (t*s*n). +Proof. + intros n t s. + rewrite <- (kron_comm_triple_id' n t s). + rewrite (Nat.mul_comm s t), (Nat.mul_comm n s), + (Nat.mul_comm t n). + easy. +Qed. + +Lemma kron_comm_triple_id'C_mat_equiv : forall n t s, + (kron_comm n (s*t)) × (kron_comm t (n*s)) × (kron_comm s (t*n)) ≡ Matrix.I (t*s*n). +Proof. + intros n t s. + rewrite <- (kron_comm_triple_id'C n t s). + easy. +Qed. + +Tactic Notation "restore_dims" "in" ident(H) := + match type of H with + | ?A => let A' := restore_dims_rec A in + replace A with A' in H by unify_matrix_dims + ltac:((repeat rewrite Nat.pow_1_l); try ring; unify_pows_two; simpl; lia) + end. + +Lemma kron_comm_triple_indices_collapse_mat_equiv : forall s n t, + @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) + ≡ (kron_comm (t*s) n). +Proof. + intros s n t. + rewrite <- (Mmult_1_r_mat_eq _ _ (_ × _)). + (* replace (t*(s*n))%nat with (n*(t*s))%nat by lia. *) + rewrite <- (kron_comm_mul_inv_mat_equiv). + rewrite <- Mmult_assoc. + (* restore_dims. *) + pose proof (kron_comm_triple_id'C s t n) as Hrw. + apply (f_equal (fun A => A × kron_comm (t*s) n)) in Hrw. + replace (t*n*s)%nat with (t*s*n)%nat in Hrw by lia. + restore_dims in Hrw. + rewrite (Mmult_1_l _ _ (kron_comm (t*s) n)) in Hrw by auto with wf_db. + rewrite <- Hrw. + rewrite !Mmult_assoc. + restore_dims. + replace (n*(t*s))%nat with (t*(s*n))%nat by lia. + apply Mmult_simplify_mat_equiv; [easy|]. + replace (n*t*s)%nat with (t*(s*n))%nat by lia. + apply Mmult_simplify_mat_equiv; [easy|]. + restore_dims. + rewrite 2!kron_comm_mul_inv. + now replace (t*(s*n))%nat with (n*(t*s))%nat by lia. +Qed. + +Lemma kron_comm_triple_indices_collapse : forall s n t, + @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) + = (kron_comm (t*s) n). +Proof. + intros s n t. + apply mat_equiv_eq; + [restore_dims; apply WF_Matrix_dim_change; [lia..|]..|]; + auto with wf_db. + apply kron_comm_triple_indices_collapse_mat_equiv. +Qed. + +Lemma kron_comm_triple_indices_collapse_mat_equivC : forall s n t, + @Mmult (s*(t*n)) (s*(t*n)) (t*(n*s)) (kron_comm s (t*n)) (kron_comm t (n*s)) + ≡ (kron_comm (t*s) n). +Proof. + intros s n t. + rewrite (Nat.mul_comm t n), (Nat.mul_comm n s). + rewrite kron_comm_triple_indices_collapse_mat_equiv. + easy. +Qed. + +Lemma kron_comm_triple_indices_collapseC : forall s n t, + @Mmult (s*(t*n)) (s*(t*n)) (t*(n*s)) (kron_comm s (t*n)) (kron_comm t (n*s)) + = (kron_comm (t*s) n). +Proof. + intros s n t. + apply mat_equiv_eq; + [restore_dims; apply WF_Matrix_dim_change; [lia..|]..|]; + auto with wf_db. + apply kron_comm_triple_indices_collapse_mat_equivC. +Qed. + +(* +Not sure what this is, or if it's true: +Lemma kron_comm_triple_indices_commute : forall t s n, + @Mmult (s*t*n) (s*t*n) (t*(s*n)) (kron_comm (s*t) n) (kron_comm t (s*n)) = + @Mmult (t*(s*n)) (t*(s*n)) (s*t*n) (kron_comm t (s*n)) (kron_comm (s*t) n). *) +Lemma kron_comm_triple_indices_commute_mat_equiv : forall t s n, + @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) ≡ + @Mmult (t*(s*n)) (t*(s*n)) (s*(n*t)) (kron_comm t (s*n)) (kron_comm s (n*t)). +Proof. + intros t s n. + rewrite kron_comm_triple_indices_collapse_mat_equiv. + rewrite (Nat.mul_comm t s). + rewrite <- (kron_comm_triple_indices_collapseC t n s). + easy. +Qed. + +Lemma kron_comm_triple_indices_commute : forall t s n, + @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) = + @Mmult (t*(s*n)) (t*(s*n)) (s*(n*t)) (kron_comm t (s*n)) (kron_comm s (n*t)). +Proof. + intros t s n. + apply mat_equiv_eq; + [restore_dims; apply WF_Matrix_dim_change; [lia..|]..|]; + auto with wf_db. + apply kron_comm_triple_indices_commute_mat_equiv. +Qed. + +Lemma kron_comm_triple_indices_commute_mat_equivC : forall t s n, + @Mmult (s*(t*n)) (s*(t*n)) (t*(n*s)) (kron_comm s (t*n)) (kron_comm t (n*s)) ≡ + @Mmult (t*(s*n)) (t*(s*n)) (s*(n*t)) (kron_comm t (s*n)) (kron_comm s (n*t)). +Proof. + intros t s n. + rewrite (Nat.mul_comm t n), (Nat.mul_comm n s). + apply kron_comm_triple_indices_commute_mat_equiv. +Qed. + +Lemma kron_comm_triple_indices_commuteC : forall t s n, + @Mmult (s*(t*n)) (s*(t*n)) (t*(n*s)) (kron_comm s (t*n)) (kron_comm t (n*s)) = + @Mmult (t*(s*n)) (t*(s*n)) (s*(n*t)) (kron_comm t (s*n)) (kron_comm s (n*t)). +Proof. + intros t s n. + rewrite (Nat.mul_comm t n), (Nat.mul_comm n s). + apply kron_comm_triple_indices_commute. +Qed. + +Lemma kron_comm_kron_of_mult_commute1_mat_equiv : forall m n p q s t + (A : Matrix m n) (B : Matrix p q) (C : Matrix q s) (D : Matrix n t), + @mat_equiv (m*p) (s*t) ((kron_comm m p) × ((B × C) ⊗ (A × D))) + ((A ⊗ B) × kron_comm n q × (C ⊗ D)). +Proof. + intros m n p q s t A B C D. + rewrite <- kron_mixed_product. + rewrite (Nat.mul_comm p m), <- Mmult_assoc. + rewrite kron_comm_commutes_r_mat_equiv. + match goal with (* TODO: Make a lemma *) + |- ?A ≡ ?B => enough (H : A = B) by (rewrite H; easy) + end. + repeat (f_equal; try lia). +Qed. + +Lemma kron_comm_kron_of_mult_commute2_mat_equiv : forall m n p q s t + (A : Matrix m n) (B : Matrix p q) (C : Matrix q s) (D : Matrix n t), + ((A ⊗ B) × kron_comm n q × (C ⊗ D)) ≡ (A × D ⊗ (B × C)) × kron_comm t s. +Proof. + intros m n p q s t A B C D. + rewrite Mmult_assoc, kron_comm_commutes_l_mat_equiv, <-Mmult_assoc, + <- kron_mixed_product. + easy. +Qed. + +Lemma kron_comm_kron_of_mult_commute3_mat_equiv : forall m n p q s t + (A : Matrix m n) (B : Matrix p q) (C : Matrix q s) (D : Matrix n t), + (A × D ⊗ (B × C)) × kron_comm t s ≡ + (Matrix.I m) ⊗ (B × C) × kron_comm m s × (Matrix.I s ⊗ (A × D)). +Proof. + intros m n p q s t A B C D. + rewrite <- 2!kron_comm_commutes_l_mat_equiv, Mmult_assoc. + restore_dims. + rewrite kron_mixed_product. + rewrite Mmult_1_r_mat_eq, Mmult_1_l_mat_eq. + easy. +Qed. + +Lemma kron_comm_kron_of_mult_commute4_mat_equiv : forall m n p q s t + (A : Matrix m n) (B : Matrix p q) (C : Matrix q s) (D : Matrix n t), + @mat_equiv (m*p) (s*t) + ((Matrix.I m) ⊗ (B × C) × kron_comm m s × (Matrix.I s ⊗ (A × D))) + ((A × D) ⊗ (Matrix.I p) × kron_comm t p × ((B × C) ⊗ Matrix.I t)). +Proof. + intros m n p q s t A B C D. + rewrite <- 2!kron_comm_commutes_l_mat_equiv, 2!Mmult_assoc. + restore_dims. + rewrite 2!kron_mixed_product. + rewrite (Nat.mul_comm m p), 2!Mmult_1_r_mat_eq. + rewrite 2!Mmult_1_l_mat_eq. + easy. +Qed. + +Lemma trace_mmult_trans : forall m n (A B : Matrix m n), + trace (A⊤ × B) = Σ (fun j => Σ (fun i => A i j * B i j) m) n. +Proof. + intros m n A B. + apply big_sum_eq_bounded. + intros j Hj. + apply big_sum_eq_bounded. + intros i Hi; reflexivity. +Qed. + +Lemma trace_mmult_trans' : forall m n (A B : Matrix m n), + trace (A⊤ × B) = Σ (fun ij => let j := (ij / m)%nat in + let i := ij mod m in + A i j * B i j) (m*n). +Proof. + intros m n A B. + rewrite trace_mmult_trans, big_sum_double_sum. + reflexivity. +Qed. + +Lemma trace_0_l : forall (A : Square 0), + trace A = 0. +Proof. + intros A. + unfold trace. + easy. +Qed. + +Lemma trace_0_r : forall n, + trace (@Zero n n) = 0. +Proof. + intros A. + unfold trace. + rewrite big_sum_0; easy. +Qed. + +Lemma trace_mplus : forall n (A B : Square n), + trace (A .+ B) = trace A + trace B. +Proof. + intros n A B. + induction n. + - rewrite 3!trace_0_l; lca. + - unfold trace in *. + rewrite <- 3!big_sum_extend_r. + setoid_rewrite (IHn A B). + lca. +Qed. + +Lemma trace_big_sum : forall n k f, + trace (big_sum (G:=Square n) f k) = Σ (fun x => trace (f x)) k. +Proof. + intros n k f. + induction k. + - rewrite trace_0_r; easy. + - rewrite <- 2!big_sum_extend_r, <-IHk. + setoid_rewrite trace_mplus. + easy. +Qed. + +Lemma Hij_decomp_mat_equiv : forall n m (A : Matrix n m), + A ≡ big_sum (G:=Matrix n m) (fun ij => + let i := (ij/m)%nat in let j := ij mod m in + A i j .* H i j) (n*m). +Proof. + intros n m A. + intros i j Hi Hj. + rewrite Msum_Csum. + symmetry. + apply big_sum_unique. + exists (i*m + j)%nat. + simpl. + repeat split. + - nia. + - rewrite Nat.div_add_l, Nat.div_small, Nat.add_0_r by lia. + rewrite Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small by lia. + unfold scale, Mmult. + erewrite big_sum_unique, Cmult_1_r; [easy|]. + exists O; repeat split; auto; + unfold transpose, e_i; + intros; + rewrite !Nat.eqb_refl; + simpl_bools; + bdestructΩ'simp. + - intros ab Hab Habneq. + unfold scale, Mmult, transpose, e_i. + simpl. + rewrite Cplus_0_l. + simpl_bools. + bdestructΩ'simp. + exfalso; apply Habneq. + symmetry. + rewrite (Nat.div_mod_eq ab m) at 1 by lia. + lia. +Qed. + +Lemma Mmult_Hij_Hij_mat_equiv : forall n m o i j k l, (j < m)%nat -> + @Mmult n m o (H i j) (H k l) ≡ (if (j =? k) then H i l else Zero). +Proof. + intros n m o i j k l Hj. + intros a b Ha Hb. + unfold Mmult, transpose, e_i. + simpl. + bdestruct (j =? k). + - subst k. + rewrite Cplus_0_l. + bdestruct (a =? i); simpl; + bdestruct (b =? l); simpl; + Csimpl. + 1: simpl_bools; + replace_bool_lia (a (j < m)%nat -> + (H i j : Matrix n m) × A ≡ big_sum (G:=Matrix n o) + (fun kl : nat => A (kl / o)%nat (kl mod o) + .* (if j =? kl / o then @e_i n i × (@e_i o (kl mod o)) ⊤ else Zero)) (m * o). +Proof. + intros n m o A i j Hi Hj. + rewrite (Hij_decomp_mat_equiv _ _ A) at 1. + rewrite Mmult_Msum_distr_l. + simpl. + set (f := fun a b => A a b .* (if j =? a then @e_i n i × (@e_i o (b)) ⊤ else Zero)). + rewrite (big_sum_mat_equiv_bounded _ (fun kl => f (kl/o)%nat (kl mod o))). + 2:{ + intros kl Hkl. + rewrite Mscale_mult_dist_r. + rewrite Mmult_Hij_Hij_mat_equiv by easy. + easy. + } + easy. +Qed. + +Lemma Hij_elem : forall n m i j k l, + ((H i j) : Matrix n m) k l = if (k=?i)&&(l=?j)&&(i (j < m)%nat -> + trace (H i j × (A⊤)) = A i j. +Proof. + intros n m A i j Hi Hj. + rewrite (Hij_decomp_mat_equiv _ _ A) at 1. + rewrite (Msum_transpose n m (n*m)). + simpl. + rewrite Mmult_Hij_l_mat_equiv by easy. + erewrite big_sum_eq_bounded. + 2: { + intros ij Hij. + rewrite Msum_Csum. + erewrite big_sum_eq_bounded. + 2: { + intros k Hk. + unfold scale, transpose, Mmult, e_i. + simpl; rewrite Cplus_0_l. + rewrite if_mult_and. + replace (ij / n Σ (fun j => A i j * B j i) m) n. +Proof. + reflexivity. +Qed. + +Lemma trace_mmult_eq_comm : forall {n m} (A : Matrix n m) (B : Matrix m n), + trace (A×B) = trace (B×A). +Proof. + intros n m A B. + rewrite 2!trace_mmult_eq_ptwise. + rewrite big_sum_swap_order. + do 2 (apply big_sum_eq_bounded; intros). + apply Cmult_comm. +Qed. + +Lemma trace_transpose : forall {n} (A : Square n), + trace (A ⊤) = trace A. +Proof. + reflexivity. +Qed. + +Lemma trace_mmult_transpose_Hij_l : forall {n m} (A: Matrix m n) i j, + (i < m)%nat -> (j < n)%nat -> + trace ((H i j)⊤ × A) = A i j. +Proof. + intros n m A i j Hi Hj. + rewrite trace_mmult_eq_comm, <- trace_transpose, 3!Mmult_transpose, + 2!transpose_involutive, trace_mmult_Hij_transpose_l; try easy. +Qed. + + +Lemma trace_kron : forall {n p} (A : Square n) (B : Square p), + trace (A ⊗ B) = trace A * trace B. +Proof. + intros n p A B. + destruct p; + [rewrite Nat.mul_0_r, 2!trace_0_l; lca|]. + unfold trace. + simpl_rewrite big_sum_product; [|easy]. + reflexivity. +Qed. + +Lemma trace_kron_comm_kron : forall m n (A B : Matrix m n), + trace (kron_comm m n × (A ⊤ ⊗ B)) = trace (A⊤ × B). +Proof. + intros m n A B. + rewrite kron_comm_Hij_sum'. + rewrite Mmult_Msum_distr_r. + rewrite trace_mmult_trans', trace_big_sum. + set (f:= fun a b => A a b * B a b). + erewrite big_sum_eq_bounded. + 2:{ + intros ij Hij. + simpl. + rewrite kron_mixed_product' by lia. + rewrite trace_kron, trace_mmult_Hij_transpose_l by + (try apply Nat.Div0.div_lt_upper_bound; try apply Nat.mod_upper_bound; lia). + rewrite trace_mmult_transpose_Hij_l by + (try apply Nat.Div0.div_lt_upper_bound; try apply Nat.mod_upper_bound; lia). + fold (f (ij/n)%nat (ij mod n)). + reflexivity. + } + rewrite (Nat.mul_comm m n), <- (big_sum_double_sum f). + rewrite big_sum_swap_order. + rewrite big_sum_double_sum. + rewrite Nat.mul_comm. + easy. +Qed. + + +(* TODO: put a normal place *) +Lemma kron_comm_mx_to_vec_r_mat_equiv : forall p q (A : Matrix p q), + (mx_to_vec (A ⊤)) ⊤ × kron_comm p q ≡ (mx_to_vec A) ⊤. +Proof. + intros p q A. + match goal with + |- ?B ≡ ?C => rewrite <- (transpose_involutive _ _ B), <- (transpose_involutive _ _ C) + end. + apply transpose_simplify_mat_equiv. + rewrite Mmult_transpose. + rewrite kron_comm_transpose_mat_equiv. + rewrite 2!transpose_involutive. + apply (kron_comm_mx_to_vec_mat_equiv q p (A⊤)). +Qed. + +Lemma trace_mmult_eq_dot_mx_to_vec : forall {m n} (A B : Matrix m n), + trace (A⊤ × B) = mx_to_vec A ∘ mx_to_vec B. +Proof. + intros m n A B. + rewrite trace_mmult_eq_ptwise. + rewrite big_sum_double_sum. + unfold dot, mx_to_vec. + rewrite Nat.mul_comm. + apply big_sum_eq_bounded. + intros ij Hij. + unfold make_WF. + replace_bool_lia (ij enough (C ≡ D) by auto + end. + rewrite kron_comm_mx_to_vec_r_mat_equiv. + easy. +Qed. + +Lemma gcd_grow : forall n m, + Nat.gcd (S n) m = Nat.gcd (m mod S n) (S n). +Proof. reflexivity. Qed. + +Lemma gcd_le : forall n m, + (Nat.gcd (S n) (S m) <= S n /\ Nat.gcd (S n) (S m) <= S m)%nat. +Proof. + intros n m. + pose proof (Nat.gcd_divide (S n) (S m)). + split; apply Nat.divide_pos_le; try easy; lia. +Qed. + +Lemma div_mul_combine : forall a b c d, + Nat.divide b a -> Nat.divide d c -> + (a / b * (c / d) = (a * c) / (b * d))%nat. +Proof. + intros a b c d [a' Ha'] [c' Hc']. + subst a c. + destruct b; + [rewrite ?Nat.mul_0_r, ?Nat.mul_0_l; easy|]. + rewrite Nat.div_mul by easy. + destruct d; + [rewrite ?Nat.mul_0_r, ?Nat.mul_0_l; easy|]. + rewrite Nat.div_mul by easy. + rewrite <- Nat.mul_assoc, (Nat.mul_comm (S b)), <- Nat.mul_assoc, + Nat.mul_assoc, (Nat.mul_comm (S d)), Nat.div_mul by lia. + easy. +Qed. + +Lemma prod_eq_gcd_lcm : forall n m, + (S n * S m = Nat.gcd (S n) (S m) * Nat.lcm (S n) (S m))%nat. +Proof. + intros n m. + unfold Nat.lcm. + rewrite <- 2!Nat.Lcm0.divide_div_mul_exact, (Nat.mul_comm (Nat.gcd _ _)), + Nat.div_mul; try easy; + try (try apply Nat.divide_mul_r; apply Nat.gcd_divide; lia); + rewrite Nat.gcd_eq_0; lia. +Qed. + +Lemma gcd_eq_div_lcm : forall n m, + (Nat.gcd (S n) (S m) = (S n * S m) / (Nat.lcm (S n) (S m)))%nat. +Proof. + intros n m. + rewrite prod_eq_gcd_lcm, Nat.div_mul; try easy. + rewrite Nat.lcm_eq_0; lia. +Qed. + + + +Lemma times_n_C1 : forall n, + times_n C1 n = RtoC (INR n). +Proof. + induction n; [easy|]. + rewrite S_INR, RtoC_plus, <- IHn, Cplus_comm. + easy. +Qed. + + +Lemma div_0_r : forall n, + (n / 0 = 0)%nat. +Proof. + intros n. + easy. +Qed. + +Lemma div_divides : forall n m, + Nat.divide m n -> (n / m <> 0)%nat -> + Nat.divide (n / m) n. +Proof. + intros n m Hdiv Hnz. + assert (H: m <> O) by (intros Hfalse; subst m; rewrite div_0_r in *; lia). + exists m. + rewrite <- Nat.Lcm0.divide_div_mul_exact, Nat.mul_comm, Nat.div_mul; easy. +Qed. + +Lemma div_div : forall n m, + Nat.divide m n -> (n / m <> 0)%nat -> + (n / (n / m) = m)%nat. +Proof. + intros n m Hdiv Hnz. + rewrite <- (Nat.mul_cancel_r _ _ (n/m)) by easy. + rewrite Nat.mul_comm. + + assert (H: m <> O) by (intros Hfalse; subst m; rewrite div_0_r in *; lia). + rewrite <- Nat.Lcm0.divide_div_mul_exact, Nat.mul_comm, Nat.div_mul + by (try apply div_divides; easy). + now rewrite <- Nat.Lcm0.divide_div_mul_exact, Nat.mul_comm, Nat.div_mul. +Qed. \ No newline at end of file diff --git a/src/Permutations/MatEquivSetoid.v b/src/Permutations/MatEquivSetoid.v new file mode 100644 index 0000000..fca3f79 --- /dev/null +++ b/src/Permutations/MatEquivSetoid.v @@ -0,0 +1,382 @@ +Require Export Setoid. +Require Export Morphisms. + +From Coq Require Export ZArith. +Ltac Zify.zify_post_hook ::= PreOmega.Z.div_mod_to_equations. + +(* Require Import PermutationAutomation. *) +From QuantumLib Require Import Matrix. + +(* This file was originally MatrixExampleBase from the ViCAR examples. + It contains instances relating to the Setoid of mat_equiv, especially + proofs that many of the common operations respect this relation. + It also contains a redefinition of direct_sum, called direct_sum' + which now respects mat_equiv. *) + +Open Scope matrix_scope. + +Definition direct_sum' {n m o p : nat} (A : Matrix n m) (B : Matrix o p) : + Matrix (n+o) (m+p) := + (fun i j => if (i WF_Matrix B -> + A .⊕' B = A .⊕ B. +Proof. + intros n m o p A B HA HB. + apply mat_equiv_eq; [|apply WF_direct_sum|]; auto with wf_db. + intros i j Hi Hj. + unfold direct_sum, direct_sum'. + bdestruct_all; try lia + easy; + rewrite HA by lia; easy. +Qed. + +Lemma direct_sum'_simplify_mat_equiv {n m o p} : forall (A B : Matrix n m) + (C D : Matrix o p), A ≡ B -> C ≡ D -> direct_sum' A C ≡ direct_sum' B D. +Proof. + intros A B C D HAB HCD i j Hi Hj. + unfold direct_sum'. + bdestruct (i (n <= n')%nat -> (m <= m')%nat -> + @WF_Matrix n' m' A. +Proof. + intros Ha Hn Hm i j Hij. + apply Ha; lia. +Qed. + +Lemma WF_Matrix_if {n m} (A B : Matrix n m) (b : bool) : + WF_Matrix A -> WF_Matrix B -> + WF_Matrix (if b then A else B). +Proof. + now destruct b. +Qed. + +#[export] Hint Resolve WF_Matrix_if : wf_db. + +Lemma direct_sum_0_r {n m} (A : Matrix n m) o p : + WF_Matrix A -> + @direct_sum' n m o p A Zero = A. +Proof. + intros HA. + apply mat_equiv_eq; + [auto with wf_db| + eapply WF_Matrix_monotone; auto with wf_db; lia| ]. + intros i j Hi Hj. + unfold direct_sum', Zero. + bdestruct_all; simpl; [easy|..]; + symmetry; apply HA; lia. +Qed. + +Lemma direct_sum_Mscale {n m p q} (A : Matrix n m) + (B : Matrix p q) (c : C) : + (c .* A) .⊕' (c .* B) = c .* (A .⊕' B). +Proof. + apply mat_equiv_eq; auto with wf_db. + intros i j Hi Hj. + autounfold with U_db. + bdestruct_all; simpl; now Csimpl. +Qed. + +Lemma ei_direct_sum_split n m k : + @e_i (n + m) k = + (if k B ≡ A. +Proof. + intros n m A B HAB i j Hi Hj. + rewrite HAB by easy. + easy. +Qed. + +Lemma mat_equiv_trans : forall {n m : nat} (A B C : Matrix n m), + A ≡ B -> B ≡ C -> A ≡ C. +Proof. + intros n m A B C HAB HBC i j Hi Hj. + rewrite HAB, HBC by easy. + easy. +Qed. + +Add Parametric Relation {n m} : (Matrix n m) mat_equiv + reflexivity proved by (mat_equiv_refl _ _) + symmetry proved by (mat_equiv_sym) + transitivity proved by (mat_equiv_trans) + as mat_equiv_rel. + +Lemma mat_equiv_eq_iff {n m} : forall (A B : Matrix n m), + WF_Matrix A -> WF_Matrix B -> A ≡ B <-> A = B. +Proof. + intros; split; try apply mat_equiv_eq; + intros; try subst A; easy. +Qed. + +Lemma Mmult_simplify_mat_equiv : forall {n m o} + (A B : Matrix n m) (C D : Matrix m o), + A ≡ B -> C ≡ D -> A × C ≡ B × D. +Proof. + intros n m o A B C D HAB HCD. + intros i j Hi Hj. + unfold Mmult. + apply big_sum_eq_bounded. + intros k Hk. + rewrite HAB, HCD by easy. + easy. +Qed. + +Add Parametric Morphism {n m o} : (@Mmult n m o) + with signature (@mat_equiv n m) ==> (@mat_equiv m o) ==> (@mat_equiv n o) + as mmult_mat_equiv_morph. +Proof. intros; apply Mmult_simplify_mat_equiv; easy. Qed. + +Lemma kron_simplify_mat_equiv {n m o p} : forall (A B : Matrix n m) + (C D : Matrix o p), A ≡ B -> C ≡ D -> A ⊗ C ≡ B ⊗ D. +Proof. + intros A B C D HAB HCD i j Hi Hj. + unfold kron. + rewrite HAB, HCD; try easy. + 1,2: apply Nat.mod_upper_bound; lia. + 1,2: apply Nat.div_lt_upper_bound; lia. +Qed. + +Add Parametric Morphism {n m o p} : (@kron n m o p) + with signature (@mat_equiv n m) ==> (@mat_equiv o p) + ==> (@mat_equiv (n*o) (m*p)) as kron_mat_equiv_morph. +Proof. intros; apply kron_simplify_mat_equiv; easy. Qed. + +Lemma Mplus_simplify_mat_equiv : forall {n m} + (A B C D : Matrix n m), + A ≡ B -> C ≡ D -> A .+ C ≡ B .+ D. +Proof. + intros n m A B C D HAB HCD. + intros i j Hi Hj; unfold ".+"; + rewrite HAB, HCD; try easy. +Qed. + +Add Parametric Morphism {n m} : (@Mplus n m) + with signature (@mat_equiv n m) ==> (@mat_equiv n m) ==> (@mat_equiv n m) + as Mplus_mat_equiv_morph. +Proof. intros; apply Mplus_simplify_mat_equiv; easy. Qed. + +Lemma scale_simplify_mat_equiv : forall {n m} + (x y : C) (A B : Matrix n m), + x = y -> A ≡ B -> x .* A ≡ y .* B. +Proof. + intros n m x y A B Hxy HAB i j Hi Hj. + unfold scale. + rewrite Hxy, HAB; easy. +Qed. + +Add Parametric Morphism {n m} : (@scale n m) + with signature (@eq C) ==> (@mat_equiv n m) ==> (@mat_equiv n m) + as scale_mat_equiv_morph. +Proof. intros; apply scale_simplify_mat_equiv; easy. Qed. + +Lemma Mopp_simplify_mat_equiv : forall {n m} (A B : Matrix n m), + A ≡ B -> Mopp A ≡ Mopp B. +Proof. + intros n m A B HAB i j Hi Hj. + unfold Mopp, scale. + rewrite HAB; easy. +Qed. + +Add Parametric Morphism {n m} : (@Mopp n m) + with signature (@mat_equiv n m) ==> (@mat_equiv n m) + as Mopp_mat_equiv_morph. +Proof. intros; apply Mopp_simplify_mat_equiv; easy. Qed. + +Lemma Mminus_simplify_mat_equiv : forall {n m} + (A B C D : Matrix n m), + A ≡ B -> C ≡ D -> Mminus A C ≡ Mminus B D. +Proof. + intros n m A B C D HAB HCD. + intros i j Hi Hj; unfold Mminus, Mopp, Mplus, scale; + rewrite HAB, HCD; try easy. +Qed. + +Add Parametric Morphism {n m} : (@Mminus n m) + with signature (@mat_equiv n m) ==> (@mat_equiv n m) ==> (@mat_equiv n m) + as Mminus_mat_equiv_morph. +Proof. intros; apply Mminus_simplify_mat_equiv; easy. Qed. + +Lemma dot_simplify_mat_equiv : forall {n} (A B : Vector n) + (C D : Vector n), A ≡ B -> C ≡ D -> dot A C = dot B D. +Proof. + intros n A B C D HAB HCD. + apply big_sum_eq_bounded. + intros k Hk. + rewrite HAB, HCD; unfold "<"%nat; easy. +Qed. + +Add Parametric Morphism {n} : (@dot n) + with signature (@mat_equiv n 1) ==> (@mat_equiv n 1) ==> (@eq C) + as dot_mat_equiv_morph. +Proof. intros; apply dot_simplify_mat_equiv; easy. Qed. + +Add Parametric Morphism {n m o p} : (@direct_sum' n m o p) + with signature (@mat_equiv n m) ==> (@mat_equiv o p) + ==> (@mat_equiv (n+o) (m+p)) as direct_sum'_mat_equiv_morph. +Proof. intros; apply direct_sum'_simplify_mat_equiv; easy. Qed. + +(* Search (Matrix ?n ?m -> ?Matrix ?n ?m). *) +Lemma transpose_simplify_mat_equiv {n m} : forall (A B : Matrix n m), + A ≡ B -> A ⊤ ≡ B ⊤. +Proof. + intros A B HAB i j Hi Hj. + unfold transpose; auto. +Qed. + +Lemma transpose_simplify_mat_equiv_inv {n m} : forall (A B : Matrix n m), + A ⊤ ≡ B ⊤ -> A ≡ B. +Proof. + intros A B HAB i j Hi Hj. + unfold transpose in *; auto. +Qed. + +Add Parametric Morphism {n m} : (@transpose n m) + with signature (@mat_equiv n m) ==> (@mat_equiv m n) + as transpose_mat_equiv_morph. +Proof. intros; apply transpose_simplify_mat_equiv; easy. Qed. + +Lemma adjoint_simplify_mat_equiv {n m} : forall (A B : Matrix n m), + A ≡ B -> A † ≡ B †. +Proof. + intros A B HAB i j Hi Hj. + unfold adjoint; + rewrite HAB by easy; easy. +Qed. + +Add Parametric Morphism {n m} : (@adjoint n m) + with signature (@mat_equiv n m) ==> (@mat_equiv m n) + as adjoint_mat_equiv_morph. +Proof. intros; apply adjoint_simplify_mat_equiv; easy. Qed. + +Lemma trace_of_mat_equiv : forall n (A B : Square n), + A ≡ B -> trace A = trace B. +Proof. + intros n A B HAB. + (* unfold trace. *) + apply big_sum_eq_bounded; intros i Hi. + rewrite HAB; auto. +Qed. + +Add Parametric Morphism {n} : (@trace n) + with signature (@mat_equiv n n) ==> (eq) + as trace_mat_equiv_morph. +Proof. intros; apply trace_of_mat_equiv; easy. Qed. + + +Lemma Mmult_assoc_mat_equiv : forall {n m o p} + (A : Matrix n m) (B : Matrix m o) (C : Matrix o p), + A × B × C ≡ A × (B × C). +Proof. + intros n m o p A B C. + rewrite Mmult_assoc. + easy. +Qed. + +Lemma mat_equiv_equivalence : forall {n m}, + equivalence (Matrix n m) mat_equiv. +Proof. + intros n m. + constructor. + - intros A. apply (mat_equiv_refl). + - intros A; apply mat_equiv_trans. + - intros A; apply mat_equiv_sym. +Qed. + + + +Lemma big_sum_mat_equiv : forall {o p} (f g : nat -> Matrix o p) + (Eq_on: forall x : nat, f x ≡ g x) (n : nat), big_sum f n ≡ big_sum g n. +Proof. + intros o p f g Eq_on n. + induction n. + - easy. + - simpl. + rewrite IHn, Eq_on; easy. +Qed. + +Add Parametric Morphism {n m} : (@big_sum (Matrix n m) (M_is_monoid n m)) + with signature + (pointwise_relation nat (@mat_equiv n m)) ==> (@eq nat) ==> + (@mat_equiv n m) + as big_sum_mat_equiv_morph. +Proof. intros f g Eq_on k. apply big_sum_mat_equiv; easy. Qed. \ No newline at end of file diff --git a/src/Permutations/PermMatrixFacts.v b/src/Permutations/PermMatrixFacts.v new file mode 100644 index 0000000..66da0ab --- /dev/null +++ b/src/Permutations/PermMatrixFacts.v @@ -0,0 +1,612 @@ +Require Import PermutationAutomation. +Require Import PermutationAuxiliary. +Require Import MatEquivSetoid. +Require Import PermutationFacts PermutationInstances. + +(* This file contains what was originally MatrixPermBase from the + ViCAR examples. It has been modified to fix the new perm_eq + notation, and also includes more results. *) + +Lemma perm_mat_permutes_ei_r : forall n f k, (k < n)%nat -> + (perm_mat n f) × (e_i k) = e_i (f k). +Proof. + intros n f k Hk. + rewrite <- mat_equiv_eq_iff by auto with wf_db. + intros i j Hi Hj. + replace j with O by lia; clear j Hj. + unfold e_i. + bdestruct (i =? f k). + - unfold perm_mat, Mmult. + bdestruct_one; [|lia]. + simpl. + apply big_sum_unique. + exists k. + repeat split; [lia | bdestructΩ'simp | ]. + intros k' Hk' Hk'k'. + bdestructΩ'simp. + - simpl. + unfold perm_mat, Mmult. + rewrite big_sum_0_bounded; [easy|]. + intros k' Hk'. + bdestructΩ'simp. +Qed. + +Lemma basis_vector_equiv_e_i : forall n k, + basis_vector n k ≡ e_i k. +Proof. + intros n k i j Hi Hj. + unfold basis_vector, e_i. + bdestructΩ'simp. +Qed. + +Lemma basis_vector_eq_e_i : forall n k, (k < n)%nat -> + basis_vector n k = e_i k. +Proof. + intros n k Hk. + rewrite <- mat_equiv_eq_iff by auto with wf_db. + apply basis_vector_equiv_e_i. +Qed. + +Lemma perm_mat_permutes_basis_vectors_r : forall n f k, (k < n)%nat -> + (perm_mat n f) × (basis_vector n k) = e_i (f k). +Proof. + intros n f k Hk. + rewrite basis_vector_eq_e_i by easy. + apply perm_mat_permutes_ei_r; easy. +Qed. + +Lemma mat_equiv_of_equiv_on_ei : forall {n m} (A B : Matrix n m), + (forall k, (k < m)%nat -> A × e_i k ≡ B × e_i k) -> + A ≡ B. +Proof. + intros n m A B Heq. + intros i j Hi Hj. + specialize (Heq j Hj). + rewrite <- 2!(matrix_by_basis _ _ Hj) in Heq. + specialize (Heq i O Hi ltac:(lia)). + unfold get_vec in Heq. + rewrite Nat.eqb_refl in Heq. + easy. +Qed. + +(* FIXME: Temp; only until pull mx stuff out of ZXExample *) +Lemma vector_eq_basis_comb : forall n (y : Vector n), + WF_Matrix y -> + y = big_sum (G:=Vector n) (fun i => y i O .* @e_i n i) n. +Proof. + intros n y Hwfy. + apply mat_equiv_eq; auto with wf_db. + intros i j Hi Hj. + replace j with O by lia; clear j Hj. + symmetry. + rewrite Msum_Csum. + apply big_sum_unique. + exists i. + repeat split; try easy. + - unfold ".*", e_i; bdestructΩ'simp. + - intros l Hl Hnk. + unfold ".*", e_i; bdestructΩ'simp. +Qed. + +Lemma vector_equiv_basis_comb : forall n (y : Vector n), + y ≡ big_sum (G:=Vector n) (fun i => y i O .* @e_i n i) n. +Proof. + intros n y. + intros i j Hi Hj. + replace j with O by lia; clear j Hj. + symmetry. + rewrite Msum_Csum. + apply big_sum_unique. + exists i. + repeat split; try easy. + - unfold ".*", e_i; bdestructΩ'simp. + - intros l Hl Hnk. + unfold ".*", e_i; bdestructΩ'simp. +Qed. + +Lemma perm_mat_permutes_matrix_r : forall n m f (A : Matrix n m), + permutation n f -> + (perm_mat n f) × A ≡ (fun i j => A (perm_inv n f i) j). +Proof. + intros n m f A Hperm. + apply mat_equiv_of_equiv_on_ei. + intros k Hk. + rewrite Mmult_assoc, <- 2(matrix_by_basis _ _ Hk). + rewrite (vector_equiv_basis_comb _ (get_vec _ _)). + rewrite Mmult_Msum_distr_l. + erewrite big_sum_eq_bounded. + 2: { + intros l Hl. + rewrite Mscale_mult_dist_r, perm_mat_permutes_ei_r by easy. + reflexivity. + } + intros i j Hi Hj; replace j with O by lia; clear j Hj. + rewrite Msum_Csum. + unfold get_vec, scale, e_i. + rewrite Nat.eqb_refl. + apply big_sum_unique. + exists (perm_inv n f i). + repeat split; auto with perm_bounded_db. + - rewrite (perm_inv_is_rinv_of_permutation n f Hperm i Hi), Nat.eqb_refl. + bdestructΩ'simp. + - intros j Hj Hjne. + bdestruct (i =? f j); [|bdestructΩ'simp]. + exfalso; apply Hjne. + apply (permutation_is_injective n f Hperm); auto with perm_bounded_db. + rewrite (perm_inv_is_rinv_of_permutation n f Hperm i Hi); easy. +Qed. + +Lemma perm_mat_equiv_of_perm_eq : forall n f g, + (perm_eq n f g) -> + perm_mat n f ≡ perm_mat n g. +Proof. + intros n f g Heq. + apply mat_equiv_of_equiv_on_ei. + intros k Hk. + rewrite 2!perm_mat_permutes_ei_r, Heq by easy. + easy. +Qed. + +#[export] Hint Resolve perm_mat_equiv_of_perm_eq : perm_inv_db. + +Lemma perm_mat_eq_of_perm_eq : forall n f g, + (perm_eq n f g) -> + perm_mat n f = perm_mat n g. +Proof. + intros. + apply mat_equiv_eq; auto with wf_db. + now apply perm_mat_equiv_of_perm_eq. +Qed. + +#[export] Hint Resolve perm_mat_eq_of_perm_eq : perm_inv_db. + +Lemma perm_mat_equiv_of_perm_eq' : forall n m f g, n = m -> + (perm_eq n f g) -> + perm_mat n f ≡ perm_mat m g. +Proof. + intros; subst n; apply perm_mat_equiv_of_perm_eq; easy. +Qed. + +Lemma perm_mat_transpose {n f} (Hf : permutation n f) : + (perm_mat n f) ⊤ ≡ perm_mat n (perm_inv n f). +Proof. + intros i j Hi Hj. + unfold "⊤". + unfold perm_mat. + simplify_bools_lia. + rewrite <- (@perm_inv_eqb_iff n f) by cleanup_perm. + now rewrite Nat.eqb_sym. +Qed. + +Lemma perm_mat_transpose_eq {n f} (Hf : permutation n f) : + (perm_mat n f) ⊤ = perm_mat n (perm_inv n f). +Proof. + apply mat_equiv_eq; auto with wf_db. + now apply perm_mat_transpose. +Qed. + +Lemma perm_mat_permutes_matrix_l : forall n m f (A : Matrix n m), + permutation m f -> + A × (perm_mat m f) ≡ (fun i j => A i (f j)). +Proof. + intros n m f A Hf. + apply transpose_simplify_mat_equiv_inv. + rewrite Mmult_transpose, perm_mat_transpose by easy. + rewrite perm_mat_permutes_matrix_r by auto with perm_db. + unfold Matrix.transpose. + intros i j Hi Hj. + cleanup_perm_inv. +Qed. + +Lemma make_WF_equiv n m (A : Matrix n m) : + make_WF A ≡ A. +Proof. + unfold make_WF. + intros i j Hi Hj. + bdestructΩ'. +Qed. + +Lemma perm_mat_permutes_matrix_l_eq : forall n m f (A : Matrix n m), + WF_Matrix A -> + permutation m f -> + A × (perm_mat m f) = make_WF (fun i j => A i (f j)). +Proof. + intros n m f A HA Hf. + apply mat_equiv_eq; auto with wf_db. + rewrite make_WF_equiv. + now apply perm_mat_permutes_matrix_l. +Qed. + +Lemma perm_mat_permutes_matrix_r_eq : forall n m f (A : Matrix n m), + WF_Matrix A -> + permutation n f -> + (perm_mat n f) × A = make_WF (fun i j => A (perm_inv n f i) j). +Proof. + intros n m f A HA Hf. + apply mat_equiv_eq; auto with wf_db. + rewrite make_WF_equiv. + now apply perm_mat_permutes_matrix_r. +Qed. + +Lemma Mmult_if_r {n m o} (A : Matrix n m) (B B' : Matrix m o) (b : bool) : + A × (if b then B else B') = + if b then A × B else A × B'. +Proof. + now destruct b. +Qed. + +Lemma Mmult_if_l {n m o} (A A' : Matrix n m) (B : Matrix m o) (b : bool) : + (if b then A else A') × B = + if b then A × B else A' × B. +Proof. + now destruct b. +Qed. + +Lemma perm_mat_idn n : + perm_mat n idn = I n. +Proof. + apply mat_equiv_eq; auto with wf_db. + intros i j Hi Hj. + unfold perm_mat, I. + bdestructΩ'. +Qed. + +Lemma perm_mat_perm_eq_idn n f : + perm_eq n f idn -> + perm_mat n f = I n. +Proof. + intros Heq. + rewrite (perm_mat_eq_of_perm_eq n f idn Heq). + apply perm_mat_idn. +Qed. + +Lemma perm_mat_transpose_rinv {n f} (Hf : permutation n f) : + (perm_mat n f) × (perm_mat n f) ⊤ = I n. +Proof. + rewrite perm_mat_transpose_eq by easy. + rewrite perm_mat_Mmult by auto with perm_db. + apply perm_mat_perm_eq_idn. + cleanup_perm_inv. +Qed. + +Lemma perm_mat_transpose_linv {n f} (Hf : permutation n f) : + (perm_mat n f) ⊤ × (perm_mat n f) = I n. +Proof. + rewrite perm_mat_transpose_eq by easy. + rewrite perm_mat_Mmult by auto with perm_db. + apply perm_mat_perm_eq_idn. + cleanup_perm_inv. +Qed. + +Lemma perm_mat_of_stack_perms n0 n1 f g : + perm_bounded n0 f -> perm_bounded n1 g -> + perm_mat (n0 + n1) (stack_perms n0 n1 f g) = + direct_sum' (perm_mat n0 f) (perm_mat n1 g). +Proof. + intros Hf Hg. + apply mat_equiv_eq; auto with wf_db. + apply mat_equiv_of_equiv_on_ei. + intros k Hk. + rewrite perm_mat_permutes_ei_r by easy. + rewrite 2!ei_direct_sum_split. + rewrite Mmult_if_r. + rewrite (direct_sum'_Mmult _ _ (e_i k) (Zero)). + rewrite (direct_sum'_Mmult _ _ (@Zero n0 0) (e_i (k - n0))). + rewrite 2!Mmult_0_r. + (* rewrite *) + bdestruct (k + @e_i n k ⊗ e_i l = + @e_i (n*m) (k*m + l). +Proof. + intros Hl. + apply mat_equiv_eq; auto with wf_db. + intros i j Hi Hj. + replace j with 0 by lia. + unfold e_i, kron. + do 2 simplify_bools_lia_one_kernel. + do 2 simplify_bools_moddy_lia_one_kernel. + rewrite Cmult_if_if_1_l. + apply f_equal_if; [|easy..]. + symmetry. + rewrite (eqb_iff_div_mod_eqb m). + rewrite mod_add_l, Nat.div_add_l by lia. + rewrite (Nat.mod_small l m Hl), (Nat.div_small l m Hl). + now rewrite Nat.add_0_r, andb_comm. +Qed. + +#[export] Hint Extern 100 (_ < _) => + show_moddy_lt : perm_bounded_db. + +Lemma perm_mat_of_tensor_perms n0 n1 f g : + perm_bounded n1 g -> + perm_mat (n0 * n1) (tensor_perms n0 n1 f g) = + perm_mat n0 f ⊗ perm_mat n1 g. +Proof. + intros Hg. + apply mat_equiv_eq; auto with wf_db. + apply mat_equiv_of_equiv_on_ei. + intros k Hk. + rewrite perm_mat_permutes_ei_r by easy. + symmetry. + rewrite ei_kron_split. + restore_dims. + rewrite kron_mixed_product. + unfold tensor_perms. + simplify_bools_lia_one_kernel. + rewrite 2!perm_mat_permutes_ei_r by show_moddy_lt. + now rewrite ei_kron_join by cleanup_perm. +Qed. + +Lemma perm_mat_inj_mat_equiv n f g + (Hf : perm_bounded n f) (Hg : perm_bounded n g) : + perm_mat n f ≡ perm_mat n g -> + perm_eq n f g. +Proof. + intros Hequiv. + intros i Hi. + generalize (Hequiv (f i) i (Hf i Hi) Hi). + unfold perm_mat. + pose proof (Hf i Hi). + pose proof C1_nonzero. + bdestructΩ'. +Qed. + +Lemma perm_mat_inj n f g + (Hf : perm_bounded n f) (Hg : perm_bounded n g) : + perm_mat n f = perm_mat n g -> + perm_eq n f g. +Proof. + rewrite <- mat_equiv_eq_iff by auto with wf_db. + now apply perm_mat_inj_mat_equiv. +Qed. + +Lemma perm_mat_determinant_sqr n f (Hf : permutation n f) : + (Determinant (perm_mat n f) ^ 2)%C = 1%R. +Proof. + simpl. + Csimpl. + rewrite Determinant_transpose at 1. + rewrite Determinant_multiplicative. + rewrite perm_mat_transpose_linv by easy. + now rewrite Det_I. +Qed. + + + + + + + + +Lemma perm_mat_perm_eq_of_proportional n f g : + (exists c, perm_mat n f = c .* perm_mat n g /\ c <> 0%R) -> + perm_bounded n f -> + perm_eq n f g. +Proof. + intros (c & Heq & Hc) Hf. + rewrite <- mat_equiv_eq_iff in Heq by auto with wf_db. + intros i Hi. + pose proof (Hf i Hi) as Hfi. + generalize (Heq (f i) i Hfi Hi). + unfold perm_mat, scale. + do 3 simplify_bools_lia_one_kernel. + rewrite Cmult_if_1_r. + pose proof C1_nonzero. + bdestructΩ'. +Qed. + +Lemma perm_mat_eq_of_proportional n f g : + (exists c, perm_mat n f = c .* perm_mat n g /\ c <> 0%R) -> + perm_bounded n f -> + perm_mat n f = perm_mat n g. +Proof. + intros H Hf. + apply perm_mat_eq_of_perm_eq. + now apply perm_mat_perm_eq_of_proportional. +Qed. + + + + + + + + + + +Lemma perm_to_matrix_perm_eq n f g : + perm_eq n f g -> + perm_to_matrix n f ≡ perm_to_matrix n g. +Proof. + intros Hfg. + apply perm_mat_equiv_of_perm_eq. + now apply qubit_perm_to_nat_perm_perm_eq. +Qed. + +#[export] Hint Resolve perm_to_matrix_perm_eq : perm_inv_db. + +Lemma perm_to_matrix_eq_of_perm_eq n f g : + perm_eq n f g -> + perm_to_matrix n f = perm_to_matrix n g. +Proof. + intros Hfg. + apply mat_equiv_eq; auto with wf_db. + now apply perm_to_matrix_perm_eq. +Qed. + +#[export] Hint Resolve perm_to_matrix_eq_of_perm_eq : perm_inv_db. + +Lemma perm_to_matrix_transpose {n f} (Hf : permutation n f) : + (perm_to_matrix n f) ⊤ ≡ perm_to_matrix n (perm_inv n f). +Proof. + unfold perm_to_matrix. + rewrite perm_mat_transpose by auto with perm_db. + cleanup_perm_inv. +Qed. + +Lemma perm_to_matrix_transpose_eq {n f} (Hf : permutation n f) : + (perm_to_matrix n f) ⊤ = perm_to_matrix n (perm_inv n f). +Proof. + apply mat_equiv_eq; auto with wf_db. + now apply perm_to_matrix_transpose. +Qed. + +Lemma perm_to_matrix_transpose' {n f} (Hf : permutation n f) : + (perm_to_matrix n f) ⊤ ≡ perm_to_matrix n (perm_inv' n f). +Proof. + rewrite perm_to_matrix_transpose by easy. + apply perm_to_matrix_perm_eq. + cleanup_perm_inv. +Qed. + +Lemma perm_to_matrix_transpose_eq' {n f} (Hf : permutation n f) : + (perm_to_matrix n f) ⊤ = perm_to_matrix n (perm_inv' n f). +Proof. + apply mat_equiv_eq; auto with wf_db. + now apply perm_to_matrix_transpose'. +Qed. + +Lemma perm_to_matrix_permutes_qubits_l n p f + (Hp : permutation n p) : + (f_to_vec n f) ⊤ × perm_to_matrix n p = + (f_to_vec n (fun x => f (perm_inv n p x))) ⊤. +Proof. + rewrite <- (transpose_involutive _ _ (perm_to_matrix _ _)). + rewrite <- Mmult_transpose. + rewrite perm_to_matrix_transpose_eq by easy. + f_equal. + apply perm_to_matrix_permutes_qubits. + now apply perm_inv_permutation. +Qed. + +#[export] Hint Resolve perm_to_matrix_perm_eq + perm_to_matrix_eq_of_perm_eq : perm_inv_db. + +Lemma perm_to_matrix_of_stack_perms n0 n1 f g + (Hf : permutation n0 f) (Hg : permutation n1 g) : + perm_to_matrix (n0 + n1) (stack_perms n0 n1 f g) = + perm_to_matrix n0 f ⊗ perm_to_matrix n1 g. +Proof. + unfold perm_to_matrix. + rewrite <- perm_mat_of_tensor_perms by cleanup_perm. + rewrite <- Nat.pow_add_r. + cleanup_perm. +Qed. + +#[export] Hint Rewrite perm_to_matrix_of_stack_perms : perm_cleanup_db. + +Lemma perm_to_matrix_idn n : + perm_to_matrix n idn = I (2^n). +Proof. + rewrite <- perm_mat_idn. + apply perm_mat_eq_of_perm_eq. + cleanup_perm_inv. +Qed. + +Lemma perm_to_matrix_compose n f g : + permutation n f -> permutation n g -> + perm_to_matrix n (f ∘ g) = + perm_to_matrix n g × perm_to_matrix n f. +Proof. + intros Hf Hg. + unfold perm_to_matrix. + rewrite perm_mat_Mmult by auto with perm_db. + now rewrite qubit_perm_to_nat_perm_compose. +Qed. + +#[export] Hint Rewrite perm_to_matrix_compose : perm_cleanup_db. + +Lemma qubit_perm_to_nat_perm_inj n f g + (Hf : perm_bounded n f) : + perm_eq (2^n) (qubit_perm_to_nat_perm n f) (qubit_perm_to_nat_perm n g) -> + perm_eq n f g. +Proof. + intros H i Hi. + specialize (H (2^(n - S (f i))) ltac:(apply Nat.pow_lt_mono_r; + auto with perm_bounded_db)). + unfold qubit_perm_to_nat_perm in H. + rewrite <- funbool_to_nat_eq_iff in H. + specialize (H i Hi). + revert H. + unfold compose. + rewrite Bits.nat_to_funbool_eq. + pose proof (Hf i Hi). + simplify_bools_lia_one_kernel. + rewrite 2!Nat.pow2_bits_eqb. + bdestructΩ'. +Qed. + +Lemma perm_to_matrix_inj_mat_equiv n f g + (Hf : perm_bounded n f) (Hg : perm_bounded n g) : + perm_to_matrix n f ≡ perm_to_matrix n g -> + perm_eq n f g. +Proof. + intros Hequiv. + apply qubit_perm_to_nat_perm_inj; [easy|]. + apply perm_mat_inj_mat_equiv; [auto with perm_bounded_db..|]. + exact Hequiv. +Qed. + +Lemma perm_to_matrix_inj n f g + (Hf : perm_bounded n f) (Hg : perm_bounded n g) : + perm_to_matrix n f = perm_to_matrix n g -> + perm_eq n f g. +Proof. + rewrite <- mat_equiv_eq_iff by auto with wf_db. + now apply perm_to_matrix_inj_mat_equiv. +Qed. + + +Lemma perm_to_matrix_perm_eq_of_proportional n f g : + (exists c, perm_to_matrix n f = + c .* perm_to_matrix n g /\ c <> 0%R) -> + perm_bounded n f -> + perm_eq n f g. +Proof. + intros H Hf. + pose proof (perm_mat_perm_eq_of_proportional _ _ _ H). + apply qubit_perm_to_nat_perm_inj; auto with perm_bounded_db. +Qed. + +Lemma perm_to_matrix_eq_of_proportional n f g : + (exists c, perm_to_matrix n f = + c .* perm_to_matrix n g /\ c <> 0%R) -> + perm_bounded n f -> + perm_to_matrix n f = perm_to_matrix n g. +Proof. + intros H Hf. + apply perm_to_matrix_eq_of_perm_eq. + now apply perm_to_matrix_perm_eq_of_proportional. +Qed. diff --git a/src/Permutations/PermutationAutomation.v b/src/Permutations/PermutationAutomation.v new file mode 100644 index 0000000..ff7625a --- /dev/null +++ b/src/Permutations/PermutationAutomation.v @@ -0,0 +1,1465 @@ +Require Export ZXCore. +Require Export PermutationDefinitions. +Require Export QuantumLib.Permutations. +Require Export CoreRules.CoreAutomation. +Require Export ZXperm. + + + + +Create HintDb perm_cleanup_db. +Create HintDb perm_of_zx_cleanup_db. + +Create HintDb zxperm_db. +#[export] Hint Constructors ZXperm : zxperm_db. + +#[export] Hint Resolve + permutation_is_bounded + permutation_is_injective + permutation_is_surjective : perm_db. + +(* Tactic Notation "tryeasylia" := + try easy; try lia. *) + + + +Ltac replace_bool_lia b0 b1 := + first [ + replace b0 with b1 by (bdestruct b0; lia || (destruct b1 eqn:?; lia)) | + replace b0 with b1 by (bdestruct b1; lia || (destruct b0 eqn:?; lia)) | + replace b0 with b1 by (bdestruct b0; bdestruct b1; lia) + ]. + +Ltac show_permutation := + repeat first [ + split + | simpl; solve [auto with perm_db] + | subst; solve [auto with perm_db] + | solve [eauto using permutation_compose with perm_db] + | easy + | lia + ]. + + + +Ltac bdestruct_one := + let fail_if_iffy H := + match H with + | context[if _ then _ else _] => fail 1 + | _ => idtac + end + in + match goal with + | |- context [ ?a fail_if_iffy a; fail_if_iffy b; bdestruct (a fail_if_iffy a; fail_if_iffy b; bdestruct (a <=? b) + | |- context [ ?a =? ?b ] => fail_if_iffy a; fail_if_iffy b; bdestruct (a =? b) + | |- context[if ?b then _ else _] + => fail_if_iffy b; destruct b eqn:? + end. + + +Ltac bdestructΩ' := + let tryeasylia := try easy; try lia in + repeat (bdestruct_one; subst; tryeasylia); + tryeasylia. + + +Ltac apply_f H k := + unfold compose in H; + apply (f_equal (fun x => x k)) in H. + +Lemma is_inv_iff_inv_is n f finv : + (forall k, k < n -> finv k < n /\ f k < n /\ f (finv k) = k /\ finv (f k) = k)%nat + <-> (forall k, k < n -> f k < n /\ finv k < n /\ finv (f k) = k /\ f (finv k) = k)%nat. +Proof. + split; intros H k Hk; specialize (H k Hk); easy. +Qed. + + +#[export] Hint Rewrite is_inv_iff_inv_is : perm_inv_db. + +Ltac cleanup_perm_inv := + auto with perm_inv_db perm_db perm_bounded_db WF_Perm_db; + autorewrite with perm_inv_db; + auto with perm_inv_db perm_db perm_bounded_db WF_Perm_db. + +Ltac cleanup_perm := + auto with perm_inv_db perm_cleanup_db perm_db perm_bounded_db WF_Perm_db; + autorewrite with perm_inv_db perm_cleanup_db; + auto with perm_inv_db perm_cleanup_db perm_db perm_bounded_db WF_Perm_db. + +Ltac cleanup_perm_of_zx := + autounfold with zxperm_db; + autorewrite with perm_of_zx_cleanup_db perm_inv_db perm_cleanup_db; + auto with perm_of_zx_cleanup_db perm_inv_db perm_cleanup_db + perm_db perm_bounded_db WF_Perm_db. + +Lemma compose_id_of_compose_idn {f g : nat -> nat} + (H : (f ∘ g)%prg = (fun n => n)) {k : nat} : f (g k) = k. +Proof. + apply (f_equal_inv k) in H. + easy. +Qed. + +Ltac perm_by_inverse finv := + let tryeasylia := try easy; try lia in + exists finv; + intros k Hk; repeat split; + only 3,4 : + (try apply compose_id_of_compose_idn; cleanup_perm; tryeasylia) + || cleanup_perm; tryeasylia; + only 1,2 : auto with perm_bounded_db; tryeasylia. + +Ltac solve_stack_perm n0 n1 := + let tryeasylia := try easy; try lia in + apply functional_extensionality; intros k; + unfold stack_perms; + bdestruct (k nat) (n : nat) + {finv finv' : nat -> nat} (Hf : permutation n f) : + perm_eq n (finv ∘ f)%prg idn -> + perm_eq n (finv' ∘ f)%prg idn -> + perm_eq n finv finv'. +Proof. + apply perm_linv_injective_of_surjective. + auto with perm_db. +Qed. + +Ltac perm_eq_by_inv_inj f n := + let tryeasylia := (try easy); (try lia) in + apply (perm_inv_perm_eq_injective f n); [ + tryeasylia; auto with perm_db | + try solve [cleanup_perm; auto] | + try solve [cleanup_perm; auto]]; + tryeasylia. + +Ltac eq_by_WF_perm_eq n := + apply (eq_of_WF_perm_eq n); + auto with WF_Perm_db. + +Section ComposeLemmas. + +Local Open Scope prg. + +(* Helpers for rewriting with compose and perm_eq *) +Lemma compose_rewrite_l {f g h : nat -> nat} + (H : f ∘ g = h) : forall (i : nat -> nat), + i ∘ f ∘ g = i ∘ h. +Proof. + intros; + now rewrite compose_assoc, H. +Qed. + +Lemma compose_rewrite_l_to_2 {f g h i : nat -> nat} + (H : f ∘ g = h ∘ i) : forall (j : nat -> nat), + j ∘ f ∘ g = j ∘ h ∘ i. +Proof. + intros; + now rewrite !compose_assoc, H. +Qed. + +Lemma compose_rewrite_l_to_Id {f g : nat -> nat} + (H : f ∘ g = idn) : forall (h : nat -> nat), + h ∘ f ∘ g = h. +Proof. + intros; + now rewrite compose_assoc, H, compose_idn_r. +Qed. + +Lemma compose_rewrite_r {f g h : nat -> nat} + (H : f ∘ g = h) : forall (i : nat -> nat), + f ∘ (g ∘ i) = h ∘ i. +Proof. + intros; + now rewrite <- compose_assoc, H. +Qed. + +Lemma compose_rewrite_r_to_2 {f g h i : nat -> nat} + (H : f ∘ g = h ∘ i) : forall (j : nat -> nat), + f ∘ (g ∘ j) = h ∘ (i ∘ j). +Proof. + intros; + now rewrite <- !compose_assoc, H. +Qed. + +Lemma compose_rewrite_r_to_Id {f g : nat -> nat} + (H : f ∘ g = idn) : forall (h : nat -> nat), + f ∘ (g ∘ h) = h. +Proof. + intros; + now rewrite <- compose_assoc, H, compose_idn_l. +Qed. + +End ComposeLemmas. + +Ltac make_compose_assoc_rewrite_l lem := + lazymatch type of lem with + | forall a : ?A, @?f a => + constr:(fun a : A => ltac:( + let r := make_compose_assoc_rewrite_l (lem a) in + exact r)) + | (?F ∘ ?G)%prg = idn => + constr:(compose_rewrite_l_to_Id lem) + | (?F ∘ ?G)%prg = (?F' ∘ ?G')%prg => + constr:(compose_rewrite_l_to_2 lem) + | (?F ∘ ?G)%prg = ?H => + constr:(compose_rewrite_l lem) + end. + +Ltac make_compose_assoc_rewrite_l' lem := + lazymatch type of lem with + | forall a : ?A, @?f a => + constr:(fun a : A => ltac:( + let r := make_compose_assoc_rewrite_l' (lem a) in + exact r)) + | idn = (?F ∘ ?G)%prg => + constr:(compose_rewrite_l_to_Id (eq_sym lem)) + | (?F ∘ ?G)%prg = (?F' ∘ ?G')%prg => + constr:(compose_rewrite_l_to_2 (eq_sym lem)) + | ?H = (?F ∘ ?G)%prg => + constr:(compose_rewrite_l (eq_sym lem)) + end. + +Ltac rewrite_compose_assoc_l lem := + let lem' := make_compose_assoc_rewrite_l lem in + rewrite lem' || rewrite lem. + +Ltac rewrite_compose_assoc_l' lem := + let lem' := make_compose_assoc_rewrite_l' lem in + rewrite lem' || rewrite <- lem. + +Ltac make_compose_assoc_rewrite_r lem := + lazymatch type of lem with + | forall a : ?A, @?f a => + constr:(fun a : A => ltac:( + let r := make_compose_assoc_rewrite_r (lem a) in + exact r)) + | (?F ∘ ?G)%prg = idn => + constr:(compose_rewrite_r_to_Id lem) + | (?F ∘ ?G)%prg = (?F' ∘ ?G')%prg => + constr:(compose_rewrite_r_to_2 lem) + | (?F ∘ ?G)%prg = ?H => + constr:(compose_rewrite_r lem) + end. + +Ltac make_compose_assoc_rewrite_r' lem := + lazymatch type of lem with + | forall a : ?A, @?f a => + constr:(fun a : A => ltac:( + let r := make_compose_assoc_rewrite_r' (lem a) in + exact r)) + | idn = (?F ∘ ?G)%prg => + constr:(compose_rewrite_r_to_Id (eq_sym lem)) + | (?F ∘ ?G)%prg = (?F' ∘ ?G')%prg => + constr:(compose_rewrite_r_to_2 (eq_sym lem)) + | ?H = (?F ∘ ?G)%prg => + constr:(compose_rewrite_r (eq_sym lem)) + end. + +Ltac rewrite_compose_assoc_r lem := + let lem' := make_compose_assoc_rewrite_r lem in + rewrite lem' || rewrite lem. + +Ltac rewrite_compose_assoc_r' lem := + let lem' := make_compose_assoc_rewrite_r' lem in + rewrite lem' || rewrite <- lem. + + +Section PermComposeLemmas. + +Local Open Scope prg. + +Lemma perm_eq_compose_rewrite_l {n} {f g h : nat -> nat} + (H : perm_eq n (f ∘ g) (h)) : forall (i : nat -> nat), + perm_eq n (i ∘ f ∘ g) (i ∘ h). +Proof. + intros i k Hk. + unfold compose in *. + now rewrite H. +Qed. + +Lemma perm_eq_compose_rewrite_l_to_2 {n} {f g h i : nat -> nat} + (H : perm_eq n (f ∘ g) (h ∘ i)) : forall (j : nat -> nat), + perm_eq n (j ∘ f ∘ g) (j ∘ h ∘ i). +Proof. + intros j k Hk. + unfold compose in *. + now rewrite H. +Qed. + +Lemma perm_eq_compose_rewrite_l_to_Id {n} {f g : nat -> nat} + (H : perm_eq n (f ∘ g) idn) : forall (h : nat -> nat), + perm_eq n (h ∘ f ∘ g) h. +Proof. + intros h k Hk. + unfold compose in *. + now rewrite H. +Qed. + +Lemma perm_eq_compose_rewrite_r {n} {f g h : nat -> nat} + (H : perm_eq n (f ∘ g) h) : forall (i : nat -> nat), + perm_bounded n i -> + perm_eq n (f ∘ (g ∘ i)) (h ∘ i). +Proof. + intros i Hi k Hk. + unfold compose in *. + now rewrite H by auto. +Qed. + +Lemma perm_eq_compose_rewrite_r_to_2 {n} {f g h i : nat -> nat} + (H : perm_eq n (f ∘ g) (h ∘ i)) : forall (j : nat -> nat), + perm_bounded n j -> + perm_eq n (f ∘ (g ∘ j)) (h ∘ (i ∘ j)). +Proof. + intros j Hj k Hk. + unfold compose in *. + now rewrite H by auto. +Qed. + +Lemma perm_eq_compose_rewrite_r_to_Id {n} {f g : nat -> nat} + (H : perm_eq n (f ∘ g) idn) : forall (h : nat -> nat), + perm_bounded n h -> + perm_eq n (f ∘ (g ∘ h)) h. +Proof. + intros h Hh k Hk. + unfold compose in *. + now rewrite H by auto. +Qed. + +End PermComposeLemmas. + +Lemma perm_eq_sym {n} {f g : nat -> nat} : + perm_eq n f g -> perm_eq n g f. +Proof. + intros; symmetry; auto. +Qed. + +Lemma perm_eq_trans {n} {f g h : nat -> nat} : + perm_eq n f g -> perm_eq n g h -> perm_eq n f h. +Proof. + intros Hfg Hgh **; + rewrite Hfg; auto. +Qed. + +Ltac make_perm_eq_compose_assoc_rewrite_l lem := + lazymatch type of lem with + | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = idn l => + constr:(perm_eq_compose_rewrite_l_to_Id lem) + | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = (?F' ∘ ?G')%prg l => + constr:(perm_eq_compose_rewrite_l_to_2 lem) + | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = ?H _ => + constr:(perm_eq_compose_rewrite_l lem) + | forall a : ?A, @?f a => + constr:(fun a : A => ltac:( + let r := make_perm_eq_compose_assoc_rewrite_l (lem a) in + exact r)) + end. + +Ltac make_perm_eq_compose_assoc_rewrite_l' lem := + lazymatch type of lem with + | forall l, Nat.lt l ?n -> idn l = (?F ∘ ?G)%prg l => + constr:(perm_eq_compose_rewrite_l_to_Id (perm_eq_sym lem)) + | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = (?F' ∘ ?G')%prg l => + constr:(perm_eq_compose_rewrite_l_to_2 (perm_eq_sym lem)) + | forall l, Nat.lt l ?n -> ?H _ = (?F ∘ ?G)%prg l => + constr:(perm_eq_compose_rewrite_l (perm_eq_sym lem)) + | forall a : ?A, @?f a => + constr:(fun a : A => ltac:( + let r := make_perm_eq_compose_assoc_rewrite_l' (lem a) in + exact r)) + end. + +Ltac rewrite_perm_eq_compose_assoc_l lem := + let lem' := make_perm_eq_compose_assoc_rewrite_l lem in + rewrite lem' || rewrite lem. + +Ltac rewrite_perm_eq_compose_assoc_l' lem := + let lem' := make_perm_eq_compose_assoc_rewrite_l' lem in + rewrite lem' || rewrite <- lem. + +Ltac make_perm_eq_compose_assoc_rewrite_r lem := + lazymatch type of lem with + | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = idn l => + constr:(perm_eq_compose_rewrite_r_to_Id lem) + | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = (?F' ∘ ?G')%prg l => + constr:(perm_eq_compose_rewrite_r_to_2 lem) + | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = ?H _ => + constr:(perm_eq_compose_rewrite_r lem) + | forall a : ?A, @?f a => + constr:(fun a : A => ltac:( + let r := make_perm_eq_compose_assoc_rewrite_r (lem a) in + exact r)) + end. + +Ltac make_perm_eq_compose_assoc_rewrite_r' lem := + lazymatch type of lem with + | forall l, Nat.lt l ?n -> idn l = (?F ∘ ?G)%prg l => + constr:(perm_eq_compose_rewrite_r_to_Id (perm_eq_sym lem)) + | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = (?F' ∘ ?G')%prg l => + constr:(perm_eq_compose_rewrite_r_to_2 (perm_eq_sym lem)) + | forall l, Nat.lt l ?n -> ?H _ = (?F ∘ ?G)%prg l => + constr:(perm_eq_compose_rewrite_r (perm_eq_sym lem)) + | forall a : ?A, @?f a => + constr:(fun a : A => ltac:( + let r := make_perm_eq_compose_assoc_rewrite_r' (lem a) in + exact r)) + end. + +Ltac rewrite_perm_eq_compose_assoc_r lem := + let lem' := make_perm_eq_compose_assoc_rewrite_r lem in + rewrite lem' || rewrite lem. + +Ltac rewrite_perm_eq_compose_assoc_r' lem := + let lem' := make_perm_eq_compose_assoc_rewrite_r' lem in + rewrite lem' || rewrite <- lem. + + + + + + + + + +Lemma mod_add_n_r : forall m n, + (m + n) mod n = m mod n. +Proof. + intros m n. + replace (m + n)%nat with (m + 1 * n)%nat by lia. + destruct n. + - cbn; easy. + - apply Nat.Div0.mod_add. +Qed. + +Lemma mod_eq_sub : forall m n, + m mod n = (m - n * (m / n))%nat. +Proof. + intros m n. + pose proof (Nat.div_mod_eq m n). + lia. +Qed. + +Lemma mod_of_scale : forall m n q, + (n * q <= m < n * S q)%nat -> m mod n = (m - q * n)%nat. +Proof. + intros m n q [Hmq HmSq]. + rewrite mod_eq_sub. + replace (m/n)%nat with q; [lia|]. + apply Nat.le_antisymm. + - apply Nat.div_le_lower_bound; lia. + - pose proof (Nat.Div0.div_lt_upper_bound m n (S q)). + lia. +Qed. + +Lemma mod_n_to_2n : forall m n, + (n <= m < 2 * n)%nat -> m mod n = (m - n)%nat. +Proof. + intros. + pose proof (mod_of_scale m n 1). + lia. +Qed. + +Lemma mod_n_to_n_plus_n : forall m n, + (n <= m < n + n)%nat -> m mod n = (m - n)%nat. +Proof. + intros. + apply mod_n_to_2n; lia. +Qed. + +Ltac simplify_mods_of a b := + first [ + rewrite (Nat.mod_small a b) in * by lia + | rewrite (mod_n_to_2n a b) in * by lia + ]. + +Ltac solve_simple_mod_eqns := + let __fail_if_has_mods a := + match a with + | context[_ mod _] => fail 1 + | _ => idtac + end + in + match goal with + | |- context[if _ then _ else _] => fail 1 "Cannot solve equation with if" + | _ => + repeat first [ + easy + | lia + | match goal with + | |- context[?a mod ?b] => __fail_if_has_mods a; __fail_if_has_mods b; + simplify_mods_of a b + | H: context[?a mod ?b] |- _ => __fail_if_has_mods a; __fail_if_has_mods b; + simplify_mods_of a b + end + | match goal with + | |- context[?a mod ?b] => (* idtac a b; *) bdestruct (a + match type of zx1 with ZX ?n1 ?n1 => + apply (PermStack (n0:=n0) (n1:=n1)) + end end. + +#[export] Hint Extern 0 (ZXperm _ (?zx0 ↕ ?zx1)) => __cleanup_stack_perm zx0 zx1 : zxperm_db. + +(* Making proportional_of_eq_perm usable, mostly through a series of tactics to + deal with the absolute nightmare that is definitional equality casts. *) +Lemma prop_iff_double_cast : forall {n0 m0} n1 m1 (zx0 zx1 : ZX n0 m0) + (prfn: n1 = n0) (prfm : m1 = m0), + Proportional.proportional zx0 zx1 <-> + Proportional.proportional (cast n1 m1 prfn prfm zx0) (cast _ _ prfn prfm zx1). +Proof. + intros. + subst. + reflexivity. +Qed. + +Ltac __cast_prop_sides_to_square := + match goal with + | |- Proportional.proportional ?zx0 ?zx1 => + match type of zx0 with + | ZX ?n ?n => idtac + | ZX ?n ?m => + let Hm0n := fresh "Hm0n" in + assert (Hm0n : n = m) by lia; + rewrite (prop_iff_double_cast n n zx0 zx1 (eq_refl) (Hm0n)) + end + end. + +Lemma cast_compose_eq : forall n0 n1 m o0 o1 (zx0 : ZX n0 m) (zx1 : ZX m o0) Hn0n1 Ho0o1, + cast n1 o1 Hn0n1 Ho0o1 (zx0 ⟷ zx1) = + (cast n1 m Hn0n1 (@eq_refl _ m) zx0) ⟷ (cast m o1 (@eq_refl _ m) Ho0o1 zx1). +Proof. + intros. + subst. + reflexivity. +Qed. + +Lemma cast_cast_eq : forall n0 m0 n1 m1 n2 m2 (zx : ZX n0 m0) Hn0n1 Hm0m1 Hn1n2 Hm1m2, + let Hn0n2 := eq_trans Hn1n2 Hn0n1 in + let Hm0m2 := eq_trans Hm1m2 Hm0m1 in + cast n2 m2 Hn1n2 Hm1m2 (cast n1 m1 Hn0n1 Hm0m1 zx) = + cast n2 m2 Hn0n2 Hm0m2 zx. +Proof. + intros; subst. + reflexivity. +Qed. + +Lemma cast_id_eq : forall n m (prfn : n = n) (prfm : m = m) zx, + cast n m prfn prfm zx = zx. +Proof. + intros; subst. + rewrite (Eqdep_dec.UIP_refl_nat n prfn). (* Replace prfn with (@eq_refl nat n) *) + rewrite (Eqdep_dec.UIP_refl_nat m prfm). (* Replace prfn with (@eq_refl nat m) *) + reflexivity. +Qed. + +Lemma zxperm_iff_cast' : forall n0 n1 zx (H H' : n1 = n0), + ZXperm n1 (cast n1 n1 H H' zx) <-> ZXperm n0 zx. +Proof. + intros. + subst; rewrite cast_id_eq. + reflexivity. +Qed. + +#[export] Hint Resolve <- zxperm_iff_cast' : zxperm_db. + +Ltac simpl_permlike_zx := + let simpl_casts_eq := first [ + rewrite cast_id_eq | + rewrite cast_cast_eq ] + in + repeat (match goal with + | |- context[?zx ⟷ cast ?m' ?o' ?prfm ?prfo (n_wire ?o)] => + rewrite (@CastRules.cast_compose_r _ _ _ _ _ prfm prfo zx _); + rewrite (@ComposeRules.nwire_removal_r o) + | |- context[cast ?n' ?m' ?prfn ?prfm (n_wire ?n) ⟷ ?zx] => + rewrite (@CastRules.cast_compose_l _ _ _ _ _ prfn prfm _ zx); + rewrite (@ComposeRules.nwire_removal_l n) + | |- context[@cast ?n' ?m' ?n ?m ?prfn ?prfm ?zx ⟷ cast ?m' ?o' ?prfom ?prfo (n_wire ?o)] => + rewrite (@CastRules.cast_compose_l n n' m m' o' prfn prfm zx (cast m' o' prfom prfo (n_wire o))); + rewrite (cast_cast_eq _ _ _ _ _ _ (n_wire o)); + try rewrite (cast_id_eq _ _ _ _ (zx ⟷ _)) + | |- context[cast ?n ?m' ?prfn ?prfmn (n_wire ?n') ⟷ @cast ?m' ?o' ?m ?o ?prfm ?prfo ?zx] => + rewrite (@CastRules.cast_compose_r n m m' o o' prfm prfo (cast n m prfn prfmn (n_wire n')) zx); + rewrite (cast_cast_eq _ _ _ _ _ _ (n_wire n')); + try rewrite (cast_id_eq _ _ _ _ (zx ⟷ _)) + | |- context[cast ?n1 ?m _ _ ?zx0 ⟷ cast ?m ?o1 _ _ ?zx1] => + rewrite <- (cast_compose_eq _ n1 m _ o1 zx0 zx1) + | |- context[ @cast ?n1 ?m1 ?n0 ?m0 ?prfn0 ?prfm0 ?zx0 ⟷ cast ?m1 ?o1 ?prfm1 ?prfo1 ?zx1 ] => + rewrite (CastRules.cast_compose_mid m0 (eq_sym prfm0) (eq_sym prfm0) (cast n1 m1 prfn0 prfm0 zx0) (cast m1 o1 prfm1 prfo1 zx1)); + rewrite + (cast_cast_eq _ _ _ _ _ _ zx0), (cast_cast_eq _ _ _ _ _ _ zx1), + (cast_id_eq _ _ _ _ zx0) +end; repeat simpl_casts_eq) || (repeat simpl_casts_eq). + +#[export] Hint Extern 2 => + (repeat first [rewrite cast_id_eq | rewrite cast_cast_eq]) : zxperm_db. + +Ltac __one_round_cleanup_zxperm_of_cast := + match goal with + | |- ZXperm _ (cast ?n2 ?m2 ?Hn1n2 ?Hm1m2 (@cast ?n1 ?m1 ?n0 ?m0 ?Hn0n1 ?Hm0m1 ?zx)) => (* idtac "clean_cast_cast"; *) + rewrite (cast_cast_eq n0 m0 n1 m1 n2 m2 zx Hn0n1 Hm0m1 Hn1n2 Hm1m2) + | |- ZXperm ?n (@cast ?n ?n ?n ?n _ _ ?zx) => (* idtac "clean_id"; *) + rewrite (cast_id_eq n n _ _ zx) + | |- ZXperm ?n (@cast ?n ?n ?n' ?m' _ _ (?zx0 ⟷ ?zx1)) => (* idtac "clean_comp"; *) + rewrite (cast_compose_eq _ _ _ _ _ zx0 zx1) by lia; + apply PermComp + | |- ZXperm ?n (@cast ?n ?n ?n' ?m' _ _ (?zx0 ↕ ?zx1)) => (* idtac "clean_stack"; *) + match type of zx0 with ZX ?n0 ?n0 => + match type of zx1 with ZX ?n1 ?n1 => + rewrite <- (zxperm_iff_cast' (n) (n0 + n1) (ltac:(lia)) (ltac:(lia))) + end end + end. + +#[export] Hint Extern 3 (ZXperm _ (cast _ _ _ _ _)) => __one_round_cleanup_zxperm_of_cast : zxperm_db. + +Lemma perm_of_cast_compose_each_square : forall n m a b c d + (zx0 : ZX n n) (zx1 : ZX m m) prfa0 prfb0 prfb1 prfc1 prfd1 prfd2, + ZXperm n zx0 -> ZXperm m zx1 -> + ZXperm d (cast d d prfd1 prfd2 + (cast a b prfa0 prfb0 zx0 ⟷ cast b c prfb1 prfc1 zx1)). +Proof. + intros. + subst. + auto with zxperm_db. +Qed. + +#[export] Hint Resolve perm_of_cast_compose_each_square : zxperm_db. + +(* I don't know if these actually ever help: *) +Lemma perm_of_cast_compose_each_square_l : forall n m c d + (zx0 : ZX n n) (zx1 : ZX m m) prfb1 prfc1 prfd1 prfd2, + ZXperm n zx0 -> ZXperm m zx1 -> + ZXperm d (cast d d prfd1 prfd2 + (zx0 ⟷ cast n c prfb1 prfc1 zx1)). +Proof. + intros. + subst. + auto with zxperm_db. +Qed. + +Lemma perm_of_cast_compose_each_square_r : forall n m a d + (zx0 : ZX n n) (zx1 : ZX m m) prfa0 prfm0 prfd1 prfd2, + ZXperm n zx0 -> ZXperm m zx1 -> + ZXperm d (cast d d prfd1 prfd2 + (cast a m prfa0 prfm0 zx0 ⟷ zx1)). +Proof. + intros. + subst. + auto with zxperm_db. +Qed. + + +(* #[export] Hint Resolve perm_of_cast_compose_each_square_l + perm_of_cast_compose_each_square_r : zxperm_db. *) + + +(* This can't be here because proportional_of_eq_perm is defined later, but keeping + for reference. (This is put in ZXpermSemantics, right after proportional_of_eq_perm.) *) + +(* +Ltac prop_perm_eq := + intros; + simpl_casts; + simpl_permlike_zx; + __cast_prop_sides_to_square; + (* Goal: zx0 ∝ zx1 *) + apply proportional_of_eq_perm; [ + (* New goals: *) + (*1: ZXperm _ zx0 *) auto with zxperm_db | + (*2: ZXperm _ zx1*) auto with zxperm_db | + (*3: perm_of_zx zx0 = perm_of_zx zx1*) cleanup_perm_of_zx; try easy; try lia + ]. +*) + + +Ltac simpl_bools := + repeat (simpl; rewrite ?andb_true_r, ?andb_false_r, ?orb_true_r, ?orb_false_r). + +Ltac simplify_bools_lia_one_free := + let act_T b := ((replace_bool_lia b true || replace_bool_lia b false); simpl) in + let act_F b := ((replace_bool_lia b false || replace_bool_lia b true); simpl) in + match goal with + | |- context[?b && _] => act_F b; rewrite ?andb_true_l, ?andb_false_l + | |- context[_ && ?b] => act_F b; rewrite ?andb_true_r, ?andb_false_r + | |- context[?b || _] => act_T b; rewrite ?orb_true_l, ?orb_false_l + | |- context[_ || ?b] => act_T b; rewrite ?orb_true_r, ?orb_false_r + | |- context[negb ?b] => act_T b; simpl negb + | |- context[if ?b then _ else _] => act_T b + end; simpl_bools. + +Ltac simplify_bools_lia_one_kernel := + let fail_if_iffy H := + match H with + | context [ if _ then _ else _ ] => fail 1 + | _ => idtac + end + in + let fail_if_compound H := + fail_if_iffy H; + match H with + | context [ ?a && ?b ] => fail 1 + | context [ ?a || ?b ] => fail 1 + | _ => idtac + end + in + let act_T b := (fail_if_compound b; + (replace_bool_lia b true || replace_bool_lia b false); simpl) in + let act_F b := (fail_if_compound b; + (replace_bool_lia b false || replace_bool_lia b true); simpl) in + match goal with + | |- context[?b && _] => act_F b; rewrite ?andb_true_l, ?andb_false_l + | |- context[_ && ?b] => act_F b; rewrite ?andb_true_r, ?andb_false_r + | |- context[?b || _] => act_T b; rewrite ?orb_true_l, ?orb_false_l + | |- context[_ || ?b] => act_T b; rewrite ?orb_true_r, ?orb_false_r + | |- context[negb ?b] => act_T b; simpl negb + | |- context[if ?b then _ else _] => act_T b + end; simpl_bools. + +Ltac simplify_bools_lia_many_kernel := + let fail_if_iffy H := + match H with + | context [ if _ then _ else _ ] => fail 1 + | _ => idtac + end + in + let fail_if_compound H := + fail_if_iffy H; + match H with + | context [ ?a && ?b ] => fail 1 + | context [ ?a || ?b ] => fail 1 + | _ => idtac + end + in + let act_T b := (fail_if_compound b; + (replace_bool_lia b true || replace_bool_lia b false); simpl) in + let act_F b := (fail_if_compound b; + (replace_bool_lia b false || replace_bool_lia b true); simpl) in + multimatch goal with + | |- context[?b && _] => act_F b; rewrite ?andb_true_l, ?andb_false_l + | |- context[_ && ?b] => act_F b; rewrite ?andb_true_r, ?andb_false_r + | |- context[?b || _] => act_T b; rewrite ?orb_true_l, ?orb_false_l + | |- context[_ || ?b] => act_T b; rewrite ?orb_true_r, ?orb_false_r + | |- context[negb ?b] => act_T b; simpl negb + | |- context[if ?b then _ else _] => act_T b + end; simpl_bools. + +Ltac simplify_bools_lia_one := + simplify_bools_lia_one_kernel || simplify_bools_lia_one_free. + +Ltac simplify_bools_lia := + repeat simplify_bools_lia_one. + +Ltac bdestruct_one_old := + let fail_if_iffy H := + match H with + | context [ if _ then _ else _ ] => fail 1 + | _ => idtac + end + in + match goal with + | |- context [ ?a + fail_if_iffy a; fail_if_iffy b; bdestruct (a + fail_if_iffy a; fail_if_iffy b; bdestruct (a <=? b) + | |- context [ ?a =? ?b ] => + fail_if_iffy a; fail_if_iffy b; bdestruct (a =? b) + | |- context [ if ?b then _ else _ ] => fail_if_iffy b; destruct b eqn:? + end. + +Ltac bdestruct_one_new := + let fail_if_iffy H := + match H with + | context [ if _ then _ else _ ] => fail 1 + | _ => idtac + end + in + let fail_if_booley H := + fail_if_iffy H; + match H with + | context [ ?a fail 1 + | context [ ?a <=? ?b ] => fail 1 + | context [ ?a =? ?b ] => fail 1 + | context [ ?a && ?b ] => fail 1 + | context [ ?a || ?b ] => fail 1 + | context [ negb ?a ] => fail 1 + | context [ xorb ?a ?b ] => fail 1 + | _ => idtac + end + in + let rec destruct_kernel H := + match H with + | context [ if ?b then _ else _ ] => destruct_kernel b + | context [ ?a + tryif fail_if_booley a then + (tryif fail_if_booley b then bdestruct (a + tryif fail_if_booley a then + (tryif fail_if_booley b then bdestruct (a <=? b) + else destruct_kernel b) else (destruct_kernel a) + | context [ ?a =? ?b ] => + tryif fail_if_booley a then + (tryif fail_if_booley b then bdestruct (a =? b); try subst + else destruct_kernel b) else (destruct_kernel a) + | context [ ?a && ?b ] => + destruct_kernel a || destruct_kernel b + | context [ ?a || ?b ] => + destruct_kernel a || destruct_kernel b + | context [ xorb ?a ?b ] => + destruct_kernel a || destruct_kernel b + | context [ negb ?a ] => + destruct_kernel a + | _ => idtac + end + in + simpl_bools; + match goal with + | |- context [ ?a =? ?b ] => + fail_if_iffy a; fail_if_iffy b; bdestruct (a =? b); try subst + | |- context [ ?a + fail_if_iffy a; fail_if_iffy b; bdestruct (a + fail_if_iffy a; fail_if_iffy b; bdestruct (a <=? b) + | |- context [ if ?b then _ else _ ] => fail_if_iffy b; destruct b eqn:? + end; + simpl_bools. + +Ltac bdestruct_one' := bdestruct_one_new || bdestruct_one_old. + +Ltac bdestructΩ'simp := + let tryeasylia := try easy; try lca; try lia in + tryeasylia; + repeat (bdestruct_one'; subst; simpl_bools; simpl; tryeasylia); tryeasylia. + +Local Open Scope nat. + + + +Lemma pow2_nonzero n : 2 ^ n <> 0. +Proof. + apply Nat.pow_nonzero; lia. +Qed. + +Ltac show_term_nonzero term := + match term with + | 2 ^ ?a => exact (pow2_nonzero a) + | ?a ^ ?b => exact (Nat.pow_nonzero a b ltac:(show_term_nonzero a)) + | _ => lia + | _ => nia + end. + +Ltac show_nonzero := + match goal with + | |- ?t <> 0 => show_term_nonzero t + | |- 0 <> ?t => symmetry; show_term_nonzero t + | |- 0 < ?t => assert (t <> 0) by (show_term_nonzero t); lia + | |- ?t > 0 => assert (t <> 0) by (show_term_nonzero t); lia + | _ => lia + end. + +Ltac get_div_by_pow_2 t pwr := + match t with + | 2 ^ pwr => constr:(1) + | 2 ^ pwr * ?a => constr:(a) + | ?a * 2 ^ pwr => constr:(a) + | ?a * ?b => let ra := get_div_by_pow_2 a pwr in constr:(ra * b) + | ?a * ?b => let rb := get_div_by_pow_2 b pwr in constr:(a * rb) + | 2 ^ (?a + ?b) => + let val := constr:(2 ^ a * 2 ^ b) in + get_div_by_pow_2 val pwr + | ?a + ?b => + let ra := get_div_by_pow_2 a pwr in + let rb := get_div_by_pow_2 b pwr in + constr:(ra + rb) + | ?a - 1 => + let ra := get_div_by_pow_2 a pwr in + constr:(ra - 1) + end. + +Lemma div_mul_l a b : a <> 0 -> + (a * b) / a = b. +Proof. + rewrite Nat.mul_comm; + apply Nat.div_mul. +Qed. + + +Ltac show_div_by_pow2_ge t pwr := + (* Shows t / 2 ^ pwr <= get_div_by_pwr t pwr *) + match t with + | 2 ^ pwr => (* constr:(1) *) + rewrite (Nat.div_same (2^pwr) (pow2_nonzero pwr)); + apply Nat.le_refl + | 2 ^ pwr * ?a => (* constr:(a) *) + rewrite (div_mul_l (2^pwr) a (pow2_nonzero pwr)); + apply Nat.le_refl + | ?a * 2 ^ pwr => (* constr:(a) *) + rewrite (Nat.div_mul a (2^pwr) (pow2_nonzero pwr)); + apply Nat.le_refl + | ?a * (?b * ?c) => + let rval := constr:(a * b * c) in + show_div_by_pow2_ge rval pwr + | ?a * ?b => (* b is not right, so... *) + let rval := constr:(b * a) in + show_div_by_pow2_ge rval pwr + | ?a + ?b => + let ra := get_div_by_pow_2 a pwr in + let rb := get_div_by_pow_2 b pwr in + constr:(ra + rb) + | ?a - 1 => + fail 1 "Case not supported" + | 2 ^ (?a + ?b) => + let val := constr:(2 ^ a * 2 ^ b) in + rewrite (Nat.pow_add_r 2 a b); + show_div_by_pow2_ge val pwr + + end. + + +Ltac get_div_by t val := + match t with + | val => constr:(1) + | val * ?a => constr:(a) + | ?a * val => constr:(a) + | ?a * ?b => let ra := get_div_by a val in constr:(ra * b) + | ?a * ?b => let rb := get_div_by b val in constr:(a * rb) + | 2 ^ (?a + ?b) => + let val' := constr:(2 ^ a * 2 ^ b) in + get_div_by val' val + | ?a + ?b => + let ra := get_div_by a val in + let rb := get_div_by b val in + constr:(ra + rb) + | ?a - 1 => + let ra := get_div_by a val in + constr:(ra - 1) + end. + +Ltac show_div_by_ge t val := + (* Shows t / val <= get_div_by t val *) + match t with + | val => (* constr:(1) *) + rewrite (Nat.div_same val ltac:(show_term_nonzero val)); + apply Nat.le_refl + | val * ?a => (* constr:(a) *) + rewrite (div_mul_l val a ltac:(show_term_nonzero val)); + apply Nat.le_refl + | ?a * val => (* constr:(a) *) + rewrite (Nat.div_mul a val ltac:(show_term_nonzero val)); + apply Nat.le_refl + | ?a * (?b * ?c) => + let rval := constr:(a * b * c) in + show_div_by_ge rval val + | ?a * ?b => (* b is not right, so... *) + let rval := constr:(b * a) in + show_div_by_ge rval val + | ?a + ?b => + let ra := get_div_by a val in + let rb := get_div_by b val in + constr:(ra + rb) + | ?a - 1 => + nia || + fail 1 "Case not supported" + end. + +Ltac get_strict_upper_bound term := + match term with + | ?k mod 0 => let r := get_strict_upper_bound k in constr:(r) + | ?k mod (2 ^ ?a) => constr:(Nat.pow 2 a) + | ?k mod (?a ^ ?b) => constr:(Nat.pow a b) + | ?k mod ?a => + let _ := match goal with |- _ => assert (H: a <> 0) by show_nonzero end in + constr:(a) + | ?k mod ?a => + let _ := match goal with |- _ => assert (H: a = 0) by lia end in + constr:(k + 1) + + | 2 ^ ?a * ?t => let r := get_strict_upper_bound t in + constr:(Nat.mul (Nat.pow 2 a) r) + | ?t * 2 ^ ?a => let r := get_strict_upper_bound t in + constr:(Nat.mul r (Nat.pow 2 a)) + | ?a ^ ?b => constr:(Nat.pow a b + 1) + + | ?a + ?b => + let ra := get_strict_upper_bound a in + let rb := get_strict_upper_bound b in + constr:(ra + rb + 1) + | ?a * ?b => + let ra := get_strict_upper_bound a in + let rb := get_strict_upper_bound b in + constr:(ra * rb + 1) + | ?a / (?b * (?c * ?d)) => let rval := constr:(a / (b * c * d)) in + let r := get_strict_upper_bound rval in constr:(r) + | ?a / (?b * ?c) => let rval := constr:(a / b / c) in + let r := get_strict_upper_bound rval in constr:(r) + | ?a / (2 ^ ?b) => + let ra := get_strict_upper_bound a in + let rr := get_div_by_pow_2 ra b in constr:(rr) + + | ?t => match goal with + | H : t < ?a |- _ => constr:(a) + | H : t <= ?a |- _ => constr:(a + 1) + | _ => constr:(t + 1) + end + end. + +Ltac get_upper_bound term := + match term with + | ?k mod 0 => let r := get_upper_bound k in constr:(r) + | ?k mod (2 ^ ?a) => constr:(Nat.sub (Nat.pow 2 a) 1) + | ?k mod (?a ^ ?b) => constr:(Nat.sub (Nat.pow a b) 1) + | ?k mod ?a => + let H := fresh in + let _ := match goal with |- _ => + assert (H: a <> 0) by show_nonzero; clear H end in + constr:(a - 1) + | ?k mod ?a => + let H := fresh in + let _ := match goal with |- _ => + assert (H: a = 0) by lia; clear H end in + let rk := get_upper_bound k in + constr:(rk) + + | 2 ^ ?a * ?t => let r := get_upper_bound t in + constr:(Nat.mul (Nat.pow 2 a) r) + | ?t * 2 ^ ?a => let r := get_upper_bound t in + constr:(Nat.mul r (Nat.pow 2 a)) + | ?a ^ ?b => constr:(Nat.pow a b) + + | ?a + ?b => + let ra := get_upper_bound a in + let rb := get_upper_bound b in + constr:(ra + rb) + | ?a * ?b => + let ra := get_upper_bound a in + let rb := get_upper_bound b in + constr:(ra * rb) + | ?a / (?b * (?c * ?d)) => let rval := constr:(a / (b * c * d)) in + let r := get_upper_bound rval in constr:(r) + | ?a / (?b * ?c) => let rval := constr:(a / b / c) in + let r := get_upper_bound rval in constr:(r) + | ?a / (2 ^ ?b) => + let ra := get_strict_upper_bound a in + let rr := get_div_by_pow_2 ra b in constr:(rr - 1) + + | ?a / ?b => + let ra := get_strict_upper_bound a in + let rr := get_div_by ra b in constr:(rr - 1) + + | ?t => match goal with + | H : t < ?a |- _ => constr:(a - 1) + | H : t <= ?a |- _ => constr:(a) + | _ => t + end + end. + +Lemma mul_ge_l_of_nonzero p q : q <> 0 -> + p <= p * q. +Proof. + nia. +Qed. + +Lemma mul_ge_r_of_nonzero p q : p <> 0 -> + q <= p * q. +Proof. + nia. +Qed. + +Ltac show_pow2_le := + rewrite ?Nat.pow_add_r, + ?Nat.mul_add_distr_r, ?Nat.mul_add_distr_l, + ?Nat.mul_sub_distr_r, ?Nat.mul_sub_distr_l, + ?Nat.mul_1_r, ?Nat.mul_1_l; + repeat match goal with + |- context [2 ^ ?a] => + tryif assert (2 ^ a <> 0) by assumption + then fail + else pose proof (pow2_nonzero a) + end; + nia || ( + repeat match goal with + | |- context [?p * ?q] => + tryif assert (p <> 0) by assumption + then + (tryif assert (q <> 0) by assumption + then fail + else assert (q <> 0) by nia) + else assert (p <> 0) by nia; + (tryif assert (q <> 0) by assumption + then idtac else assert (q <> 0) by nia) + end; + repeat match goal with + | |- context [?p * ?q] => + tryif assert (p <= p * q) by assumption + then + (tryif assert (q <= p * q) by assumption + then fail + else pose proof (mul_ge_r_of_nonzero p q ltac:(assumption))) + else pose proof (mul_ge_l_of_nonzero p q ltac:(assumption)); + (tryif assert (q <= p * q) by assumption + then idtac + else pose proof (mul_ge_r_of_nonzero p q ltac:(assumption))) + end; + nia). + + +Lemma lt_of_le_sub_1 a b : + b <> 0 -> a <= b - 1 -> a < b. +Proof. lia. Qed. + +Lemma le_sub_1_of_lt a b : + a < b -> a <= b - 1. +Proof. lia. Qed. + + +Ltac show_le_upper_bound term := + lazymatch term with + | ?k mod 0 => + rewrite (Nat.mod_0_r k); + show_le_upper_bound k + | ?k mod (2 ^ ?a) => + exact (le_sub_1_of_lt (k mod (2^a)) (2^a) + (Nat.mod_upper_bound k (2^a) (pow2_nonzero a))) + | ?k mod (?a ^ ?b) => + exact (le_sub_1_of_lt (k mod (2^a)) (a^b) + (Nat.mod_upper_bound k (a^b) + (Nat.pow_nonzero a b ltac:(show_term_nonzero a)))) + | ?k mod ?a => + let H := fresh in + let _ := match goal with |- _ => + assert (H: a <> 0) by show_nonzero end in + exact (le_sub_1_of_lt _ _ (Nat.mod_upper_bound k a H)) + | ?k mod ?a => + let H := fresh in + let _ := match goal with |- _ => + assert (H: a = 0) by lia end in + rewrite H; + show_le_upper_bound k + + | 2 ^ ?a * ?t => let r := get_upper_bound t in + apply (Nat.mul_le_mono_l t _ (2^a)); + show_le_upper_bound t + | ?t * 2 ^ ?a => let r := get_upper_bound t in + apply (Nat.mul_le_mono_r t _ (2^a)); + show_le_upper_bound t + | ?a ^ ?b => + apply Nat.le_refl + + | ?a + ?b => + apply Nat.add_le_mono; + [ + (* match goal with |- ?G => idtac G "should be about" a end; *) + show_le_upper_bound a | + show_le_upper_bound b] + | ?a * ?b => + apply Nat.mul_le_mono; + [ + (* match goal with |- ?G => idtac G "should be about" a end; *) + show_le_upper_bound a | + show_le_upper_bound b] + | ?a / (?b * (?c * ?d)) => + let H := fresh in + pose proof (f_equal (fun x => a / x) (Nat.mul_assoc b c d) : + a / (b * (c * d)) = a / (b * c * d)) as H; + rewrite H; + clear H; + let rval := constr:(a / (b * c * d)) in + show_le_upper_bound rval + | ?a / (?b * ?c) => + let H := fresh in + pose proof (eq_sym (Nat.Div0.div_div a b c) : + a / (b * c) = a / b / c) as H; + rewrite H; + clear H; + let rval := constr:(a / b / c) in + show_le_upper_bound rval + | ?a / (2 ^ ?b) => + let ra := get_upper_bound a in + apply (Nat.le_trans (a / (2^b)) (ra / (2^b)) _); + [apply Nat.Div0.div_le_mono; + show_le_upper_bound a | + tryif show_div_by_pow2_ge ra b then idtac + else + match goal with + | |- (?val - 1) / 2 ^ ?pwr <= ?rhs - 1 => + apply le_sub_1_of_lt, Nat.Div0.div_lt_upper_bound; + tryif nia || show_pow2_le then idtac + else fail 20 "nia failed" "on (" val "- 1) / 2 ^" pwr "<=" rhs "- 1" + | |- ?G => + tryif nia then idtac else + fail 40 "show div failed for" a "/ (2^" b "), ra =" ra + "; full goal:" G + end] + | ?a / ?b => + let ra := get_upper_bound a in + apply (Nat.le_trans (a / b) (ra / b) _); + [apply Nat.Div0.div_le_mono; + show_le_upper_bound a | + tryif show_div_by_ge ra b then idtac + else + match goal with + | |- (?val - 1) / ?den <= ?rhs - 1 => + apply le_sub_1_of_lt, Nat.Div0.div_lt_upper_bound; + tryif nia || show_pow2_le then idtac + else fail 20 "nia failed" "on (" val "- 1) / " den "<=" rhs "- 1" + | |- ?G => + tryif nia then idtac else + fail 40 "show div failed for" a "/ (" b "), ra =" ra + "; full goal:" G + end] + | ?t => match goal with + | _ => nia + end + end. + +Ltac show_moddy_lt := + lazymatch goal with + | |- Bits.funbool_to_nat ?n ?f < ?b => + apply (Nat.lt_le_trans (Bits.funbool_to_nat n f) (2^n) b); + [apply (Bits.funbool_to_nat_bound n f) | show_pow2_le] + | |- Nat.b2n ?b < ?a => + apply (Nat.le_lt_trans (Nat.b2n b) (2^1) a); + [destruct b; simpl; lia | show_pow2_le] + | |- ?a < ?b => + let r := get_upper_bound a in + apply (Nat.le_lt_trans a r b); + [show_le_upper_bound a | show_pow2_le] + | |- ?a <= ?b => (* Likely not to work *) + let r := get_upper_bound a in + apply (Nat.le_trans a r b); + [show_le_upper_bound a | show_pow2_le] + | |- ?a > ?b => + change (b < a); show_moddy_lt + | |- ?a >= ?b => + change (b <= a); show_moddy_lt + | |- (?a + apply (proj2 (Nat.ltb_lt a b)); + show_moddy_lt + | |- true = (?a + symmetry; + apply (proj2 (Nat.ltb_lt a b)); + show_moddy_lt + | |- (?a <=? ?b) = false => + apply (proj2 (Nat.leb_gt a b)); + show_moddy_lt + | |- false = (?a <=? ?b) => + symmetry; + apply (proj2 (Nat.leb_gt a b)); + show_moddy_lt + end. + +Ltac try_show_moddy_lt := + lazymatch goal with + | |- Bits.funbool_to_nat ?n ?f < ?b => + apply (Nat.le_lt_trans (Bits.funbool_to_nat n f) (2^n) b); + [apply (Bits.funbool_to_nat_bound n f) | try show_pow2_le] + | |- Nat.b2n ?b < ?a => + apply (Nat.le_lt_trans (Nat.b2n b) (2^1) a); + [destruct b; simpl; lia | try show_pow2_le] + | |- ?a < ?b => + let r := get_upper_bound a in + apply (Nat.le_lt_trans a r b); + [try show_le_upper_bound a | try show_pow2_le] + | |- ?a <= ?b => (* Likely not to work *) + let r := get_upper_bound a in + apply (Nat.le_trans a r b); + [try show_le_upper_bound a | try show_pow2_le] + | |- ?a > ?b => + change (b < a); try_show_moddy_lt + | |- ?a >= ?b => + change (b <= a); try_show_moddy_lt + | |- (?a + apply (proj2 (Nat.ltb_lt a b)); + try_show_moddy_lt + | |- true = (?a + symmetry; + apply (proj2 (Nat.ltb_lt a b)); + try_show_moddy_lt + | |- (?a <=? ?b) = false => + apply (proj2 (Nat.leb_gt a b)); + try_show_moddy_lt + | |- false = (?a <=? ?b) => + symmetry; + apply (proj2 (Nat.leb_gt a b)); + try_show_moddy_lt + end. + +Ltac replace_bool_moddy_lia b0 b1 := + first + [ replace b0 with b1 + by (show_moddy_lt || bdestruct b0; show_moddy_lt + lia + || (destruct b1 eqn:?; lia)) + | replace b0 with b1 + by (bdestruct b1; lia || (destruct b0 eqn:?; lia)) + | replace b0 with b1 + by (bdestruct b0; bdestruct b1; lia) ]. + +Ltac simpl_bools_nosimpl := + repeat (rewrite ?andb_true_r, ?andb_false_r, ?orb_true_r, ?orb_false_r). + +Ltac simplify_bools_moddy_lia_one_kernel := + let fail_if_iffy H := + match H with + | context [ if _ then _ else _ ] => fail 1 + | _ => idtac + end + in + let fail_if_compound H := + fail_if_iffy H; + match H with + | context [ ?a && ?b ] => fail 1 + | context [ ?a || ?b ] => fail 1 + | _ => idtac + end + in + let act_T b := (fail_if_compound b; + (replace_bool_moddy_lia b true + || replace_bool_moddy_lia b false); simpl) in + let act_F b := (fail_if_compound b; + (replace_bool_moddy_lia b false + || replace_bool_moddy_lia b true); simpl) in + match goal with + | |- context[?b && _] => act_F b; rewrite ?andb_true_l, ?andb_false_l + | |- context[_ && ?b] => act_F b; rewrite ?andb_true_r, ?andb_false_r + | |- context[?b || _] => act_T b; rewrite ?orb_true_l, ?orb_false_l + | |- context[_ || ?b] => act_T b; rewrite ?orb_true_r, ?orb_false_r + | |- context[negb ?b] => act_T b; cbn [negb] + | |- context[if ?b then _ else _] => act_T b + end; simpl_bools_nosimpl. + +(* For VyZX lemmas which create a ton of shelved goals, this solves + them immediately (and ensures they *are* solvable, seemingly + unlike auto_cast_eqns) *) +Tactic Notation "clean_eqns" tactic(tac) := + unshelve (tac); [reflexivity + lia..|]. + + + +(* The following originate from ExamplesAutomation from the ViCAR examples*) +Require Import String. + +Ltac print_hyps := + try (match reverse goal with | H : ?p |- _ => idtac H ":" p; fail end). + +Ltac print_goal := + match reverse goal with |- ?P => idtac P; idtac "" end. + +Ltac print_state := + print_hyps; + idtac "---------------------------------------------------------"; + print_goal. + +Ltac is_C0 x := assert (x = C0) by (cbv; lca). + +Ltac is_C1 x := assert (x = C1) by (cbv; lca). + +Tactic Notation "print_C" constr(x) := (tryif is_C0 x then constr:("0"%string) else + tryif is_C1 x then constr:("1"%string) else constr:("X"%string)). + +Ltac print_LHS_matU := + intros; + (let i := fresh "i" in + let j := fresh "j" in + let Hi := fresh "Hi" in + let Hj := fresh "Hj" in + intros i j Hi Hj; try solve_end; + repeat (* Enumerate rows and columns; see `by_cell` *) + (destruct i as [| i]; [ | apply <- Nat.succ_lt_mono in Hi ]; + try solve_end); clear Hi; + repeat + (destruct j as [| j]; [ | apply <- Nat.succ_lt_mono in Hj ]; + try solve_end); clear Hj + ); + match goal with |- ?x = ?y ?i ?j => autounfold with U_db; simpl; + match goal with + | |- ?x = _ => + tryif is_C0 x then idtac "A[" i "," j "] = 0" else + tryif is_C1 x then idtac "A[" i "," j "] = 1" else + idtac "A[" i "," j "] = X" + end +end. + +Ltac simplify_mods_one := + let __fail_if_has_mods a := + match a with + | context [ _ mod _ ] => fail 1 + | _ => idtac + end + in + match goal with + | |- context [ ?a mod ?b ] => + __fail_if_has_mods a; __fail_if_has_mods b; + simplify_mods_of a b + | H:context [ ?a mod ?b ] |- _ => + __fail_if_has_mods a; __fail_if_has_mods b; + simplify_mods_of a b + end. + +Ltac case_mods_one := + match goal with + | |- context [ ?a mod ?b ] => + bdestruct (a ( + match type of A with Matrix ?m' ?n' => + match type of B with Matrix ?n'' ?o'' => + let Hm' := fresh "Hm'" in let Hn' := fresh "Hn'" in + let Hn'' := fresh "Hn''" in let Ho'' := fresh "Hoo'" in + assert (Hm' : m = m') by lia; + assert (Hn' : n = n') by lia; + assert (Hn'' : n = n'') by lia; + assert (Ho' : o = o'') by lia; + replace (@Mmult m n o A B) with (@Mmult m' n' o A B) + by (first [try (rewrite Hm' at 1); try (rewrite Hn' at 1); reflexivity | f_equal; lia]); + apply WF_mult; [ + auto with wf_db | + apply WF_Matrix_dim_change; + auto with wf_db + ] + end end) : wf_db. + +#[export] Hint Extern 100 (_ < _) => + show_moddy_lt || show_pow2_le : perm_bounded_db. \ No newline at end of file diff --git a/src/Permutations/PermutationAuxiliary.v b/src/Permutations/PermutationAuxiliary.v new file mode 100644 index 0000000..5a646b5 --- /dev/null +++ b/src/Permutations/PermutationAuxiliary.v @@ -0,0 +1,1514 @@ +Require Import PermutationAutomation. + +Section AuxiliaryLemmas. + +Import Bits Bool. + +Section nat_lemmas. + +Import Nat. + +Local Open Scope nat. + +Lemma add_sub' n m : m + n - m = n. +Proof. + lia. +Qed. + +Lemma add_leb_mono_l n m d : + (n + m <=? n + d) = (m <=? d). +Proof. + bdestructΩ'. +Qed. + +Lemma add_ltb_mono_l n m d : + (n + m m <= d. +Proof. lia. Qed. + +Lemma add_lt_cancel_l_iff n m d : + n + m < n + d <-> m < d. +Proof. lia. Qed. + +Lemma add_ge_cancel_l_iff n m d : + n + m >= n + d <-> m >= d. +Proof. lia. Qed. + +Lemma add_gt_cancel_l_iff n m d : + n + m > n + d <-> m > d. +Proof. lia. Qed. + +Lemma sub_lt_iff n m p (Hp : 0 <> p) : + n - m < p <-> n < m + p. +Proof. + split; lia. +Qed. + +Lemma add_assoc_four {a b c d} : a + b + c + d = a + (b + c + d). +Proof. + now rewrite 2!Nat.add_assoc. +Qed. + +Lemma add_assoc_three {a b c} : a + (b + c) = a + b + c. +Proof. + now rewrite Nat.add_assoc. +Qed. + +Lemma sub_eq_iff {a b m} : b <= a -> + a - b = m <-> a = b + m. +Proof. + lia. +Qed. + +Lemma pow_pos (n m : nat) : n <> 0 -> 0 < n ^ m. +Proof. + induction m; simpl; lia. +Qed. + +Lemma n_le_pow_2_n (n : nat) : n <= 2 ^ n. +Proof. + induction n; simpl; [lia|]. + pose proof (pow_pos 2 n). + lia. +Qed. + +Lemma add_sub_four (n m o : nat) : + n + m - o - n = m - o. +Proof. lia. Qed. + +Lemma div_mul_not_exact a b : b <> 0 -> + (a / b) * b = a - (a mod b). +Proof. + intros Hb. + rewrite (Nat.div_mod a b Hb) at 1 2. + rewrite Nat.add_sub. + rewrite (Nat.mul_comm b (a/b)), Nat.add_comm, Nat.div_add by easy. + rewrite Nat.div_small by (apply Nat.mod_upper_bound; easy). + easy. +Qed. + +Lemma mod_div a b : a mod b / b = 0. +Proof. + destruct b; [easy|]. + apply Nat.div_small, Nat.mod_upper_bound; easy. +Qed. + +Lemma mod_add_l a b c : (a * b + c) mod b = c mod b. +Proof. + rewrite Nat.add_comm. + apply Nat.Div0.mod_add. +Qed. + +Lemma min_ltb n m : min n m = if n ; easy|]. + intros. + rewrite (Nat.div_mod_eq i a), (Nat.div_mod_eq j a). + lia. +Qed. + +Lemma eqb_div_mod_pow_2_iff a i j k l : + i mod 2 ^ a + 2 ^ a * j =? k mod 2 ^ a + 2 ^ a * l = + ((i mod 2 ^ a =? k mod 2 ^ a) && + (j =? l)). +Proof. + apply eq_iff_eq_true. + rewrite andb_true_iff, !Nat.eqb_eq. + split; try lia. + rewrite 2!(Nat.mul_comm (2^a)). + intros H. + generalize (f_equal (fun x => x mod 2^a) H). + rewrite 2!Nat.Div0.mod_add, !Nat.Div0.mod_mod. + intros; split; [easy|]. + generalize (f_equal (fun x => x / 2^a) H). + now rewrite 2!Nat.div_add, !Nat.div_small by + (show_nonzero + show_moddy_lt). +Qed. + +Lemma succ_even_lt_even a b : Nat.even a = true -> + Nat.even b = true -> + a < b -> S a < b. +Proof. + intros Ha Hb Hab. + enough (S a <> b) by lia. + intros Hf. + apply (f_equal Nat.even) in Hf. + rewrite Nat.even_succ in Hf. + rewrite <- Nat.negb_even in Hf. + rewrite Ha, Hb in Hf. + easy. +Qed. + +Lemma succ_odd_lt_odd a b : Nat.odd a = true -> + Nat.odd b = true -> + a < b -> S a < b. +Proof. + intros Ha Hb Hab. + enough (S a <> b) by lia. + intros Hf. + apply (f_equal Nat.even) in Hf. + rewrite Nat.even_succ in Hf. + rewrite <- Nat.negb_odd in Hf. + rewrite Ha, Hb in Hf. + easy. +Qed. + +Lemma even_add_same n : Nat.even (n + n) = true. +Proof. + now rewrite Nat.even_add, eqb_reflx. +Qed. + +Lemma even_succ_false n : + Nat.even (S n) = false <-> Nat.even n = true. +Proof. + rewrite Nat.even_succ, <- Nat.negb_even. + now destruct (Nat.even n). +Qed. + +Lemma even_succ_add_same n : Nat.even (S (n + n)) = false. +Proof. + now rewrite even_succ_false, even_add_same. +Qed. + +Lemma odd_succ_false n : + Nat.odd (S n) = false <-> Nat.odd n = true. +Proof. + rewrite Nat.odd_succ, <- Nat.negb_odd. + now destruct (Nat.odd n). +Qed. + +Lemma double_add n m : n + m + (n + m) = n + n + (m + m). +Proof. + lia. +Qed. + +Lemma sub_leb_eq n m p : + n - m <=? p = (n <=? m + p). +Proof. + bdestructΩ'. +Qed. + +Lemma sub_ltb_eq_nonzero n m p : p <> 0 -> + n - m + n - m l < n -> k <> l -> + 2^k + 2^l < 2 ^ n. +Proof. + intros. + bdestruct (2^k + 2^l + n - S (n - S k) = k. +Proof. + lia. +Qed. + +Section testbit_lemmas. + +Lemma testbit_add_pow2_small (i j s n : nat) (Hs : s < n) : + Nat.testbit (i + 2^n * j) s = Nat.testbit i s. +Proof. + rewrite 2!Nat.testbit_eqb. + replace n with (s + (n - s)) by lia. + rewrite Nat.pow_add_r, <- Nat.mul_assoc, Nat.mul_comm, Nat.div_add by + (apply Nat.pow_nonzero; lia). + destruct (n - s) eqn:e; [lia|]. + cbn [Nat.pow]. + rewrite <- Nat.mul_assoc, Nat.mul_comm, Nat.Div0.mod_add by lia. + easy. +Qed. + +Lemma testbit_add_pow2_large (i j s n : nat) (Hs : n <= s) (Hi : i < 2^n) : + Nat.testbit (i + 2^n * j) s = Nat.testbit j (s - n). +Proof. + replace s with (s-n + n) at 1 by lia. + generalize (s - n) as d. + intros d. + rewrite 2!Nat.testbit_eqb. + do 2 f_equal. + rewrite Nat.pow_add_r, (Nat.mul_comm _ (2^_)), Nat.mul_comm, + <- Nat.Div0.div_div, Nat.div_add by + (apply Nat.pow_nonzero; lia). + rewrite (Nat.div_small i) by easy. + easy. +Qed. + +Lemma testbit_add_pow2_split i j n (Hi : i < 2^n) : + forall s, + Nat.testbit (j * 2 ^ n + i) s = + if s + i mod 2^m = j mod 2^m -> i mod 2^n = j mod 2^n. +Proof. + intros Hnm Heq. + replace m with (n + (m - n)) in * by lia. + generalize dependent (m - n). + intros k _. + rewrite Nat.pow_add_r, 2!Nat.Div0.mod_mul_r. + intros H. + apply (f_equal (fun k => k mod 2^n)) in H. + revert H. + rewrite 2!(Nat.mul_comm (2^n)). + rewrite 2!Nat.Div0.mod_add, 2!Nat.Div0.mod_mod. + easy. +Qed. + +Lemma bits_inj_upto i j n : + (forall s, s < n -> Nat.testbit i s = Nat.testbit j s) <-> + i mod 2^n = j mod 2^n. +Proof. + split. + - intros Heq. + induction n; + [now rewrite 2!Nat.mod_1_r|]. + rewrite 2!mod_2_pow_S. + f_equal; [|apply IHn; intros k Hk; apply Heq; lia]. + rewrite Heq by lia. + easy. + - intros Heq s Hs. + rewrite 2!Nat.testbit_eqb. + rewrite (Nat.div_mod i (2^(S s)) ltac:(apply Nat.pow_nonzero; lia)). + rewrite (Nat.div_mod j (2^(S s)) ltac:(apply Nat.pow_nonzero; lia)). + rewrite (mod_pow2_eq_closed_down i j (S s) n ltac:(lia) Heq). + rewrite 2!(Nat.mul_comm (2^ S s)), 2!(Nat.add_comm (_*_)). + rewrite Nat.pow_succ_r by lia. + rewrite 2!Nat.mul_assoc. + rewrite 2!Nat.div_add by (apply Nat.pow_nonzero; lia). + rewrite 2!Nat.Div0.mod_add. + easy. +Qed. + +Lemma lt_pow2_S_log2 i : i < 2 ^ S (Nat.log2 i). +Proof. + destruct i; [cbn; lia|]. + apply Nat.log2_spec; lia. +Qed. + +Lemma bits_inj_upto_small i j n (Hi : i < 2^n) (Hj : j < 2^n) : + (forall s, s < n -> Nat.testbit i s = Nat.testbit j s) <-> + i = j. +Proof. + split; [|intros ->; easy]. + intros H; apply bits_inj_upto in H. + assert (H2n : 2^n <> 0) by (apply Nat.pow_nonzero; lia). + rewrite (Nat.div_mod i (2^n) H2n), (Nat.div_mod j (2^n) H2n). + rewrite 2!Nat.div_small, Nat.mul_0_r by lia. + easy. +Qed. + +Lemma bits_inj i j : + (forall s, Nat.testbit i s = Nat.testbit j s) <-> i = j. +Proof. + split; [|intros ->; easy]. + set (ub := 2^ max (S (Nat.log2 i)) (S (Nat.log2 j))). + assert (Hi : i < ub) by + (enough (i < 2 ^ (S (Nat.log2 i))) by + (pose proof (Nat.pow_le_mono_r 2 (S (Nat.log2 i)) _ + ltac:(easy) (Nat.le_max_l _ (S (Nat.log2 j)))); lia); + apply lt_pow2_S_log2). + assert (Hj : j < ub) by + (enough (j < 2 ^ (S (Nat.log2 j))) by + (pose proof (Nat.pow_le_mono_r 2 (S (Nat.log2 j)) _ + ltac:(easy) (Nat.le_max_r (S (Nat.log2 i)) _)); lia); + apply lt_pow2_S_log2). + intros s. + apply (bits_inj_upto_small i j _ Hi Hj). + intros; easy. +Qed. + +Lemma testbit_make_gap i m k s : + Nat.testbit (i mod 2^m + (i/2^m) * 2^k * (2^m)) s = + if s Prop) n + (H : forall f, P (funbool_to_nat n f)) : + forall i, i < 2 ^ n -> P i. +Proof. + intros i Hi. + rewrite <- (nat_to_funbool_inverse n i Hi). + apply H. +Qed. + +Lemma div_add' n m p : + (n + m) / p = + n / p + m / p + (n mod p + m mod p) / p. +Proof. + rewrite (Nat.div_mod_eq n p) at 1. + rewrite (Nat.div_mod_eq m p) at 1. + bdestruct (p =? 0); [now subst|]. + symmetry. + rewrite Nat.add_comm. + rewrite <- Nat.div_add by easy. + f_equal. + lia. +Qed. + +Lemma sum_eq_lxor_of_bits_disj_l n m : + (forall k, Nat.testbit n k = true -> Nat.testbit m k = false) -> + n + m = Nat.lxor n m. +Proof. + intros Hnm. + apply bits_inj. + intros s. + rewrite lxor_spec. + revert n m Hnm. + induction s; + intros n m Hnm; + [apply Nat.odd_add|]. + simpl. + rewrite !div2_div. + rewrite div_add'. + rewrite <- !bit0_mod. + rewrite (div_small (_ + _)), Nat.add_0_r by + (generalize (Hnm 0); + destruct (testbit n 0), (testbit m 0); + simpl; lia). + apply IHs. + intros k. + rewrite 2!div2_bits; auto. +Qed. + +Lemma testbit_add_disjoint_pow2_l k n : + Nat.testbit n k = false -> + forall i, + Nat.testbit (2^k + n) i = (i =? k) || testbit n i. +Proof. + intros Hn i. + rewrite sum_eq_lxor_of_bits_disj_l, lxor_spec, pow2_bits_eqb, eqb_sym. + - bdestructΩ'. + now rewrite Hn. + - intros s. + rewrite pow2_bits_eqb. + bdestructΩ'. +Qed. + +Lemma testbit_sum_pows_2_ne k l : k <> l -> forall i, + Nat.testbit (2 ^ k + 2 ^ l) i = (i =? k) || (i =? l). +Proof. + intros Hkl i. + rewrite testbit_add_disjoint_pow2_l; + rewrite pow2_bits_eqb; bdestructΩ'. +Qed. + +Lemma testbit_add_disjoint m n : + (forall k, Nat.testbit n k = true -> Nat.testbit m k = false) -> + forall i, + Nat.testbit (n + m) i = testbit n i || testbit m i. +Proof. + intros Hn i. + rewrite sum_eq_lxor_of_bits_disj_l, lxor_spec by easy. + generalize (Hn i). + destruct (testbit n i), (testbit m i); lia + auto. +Qed. + +Lemma testbit_b2n b k : + testbit (b2n b) k = b && (k =? 0). +Proof. + destruct b, k; easy + apply Nat.bits_0. +Qed. + +Lemma testbit_decomp n k : + n = (n / 2 ^ (S k)) * 2 ^ (S k) + + b2n (testbit n k) * 2 ^ k + (n mod 2^k). +Proof. + apply bits_inj. + intros s. + rewrite Nat.pow_succ_r, Nat.mul_assoc, <- Nat.mul_add_distr_r by lia. + rewrite testbit_add_pow2_split by show_moddy_lt. + change 2 with (2^1) at 4. + rewrite testbit_add_pow2_split by (destruct (testbit n k); simpl; lia). + rewrite testbit_b2n. + rewrite <- Nat.pow_succ_r by lia. + rewrite testbit_div_pow2, testbit_mod_pow2. + bdestructΩ'; rewrite ?andb_true_r; f_equal; lia. +Qed. + +End testbit_lemmas. + +End nat_lemmas. + +Import Setoid. + +Section bool_lemmas. + +Lemma eqb_true_l b : eqb true b = b. +Proof. now destruct b. Qed. + +Lemma eqb_true_r b : eqb b true = b. +Proof. now destruct b. Qed. + +Lemma neq_iff_neq_true b c : + b <> c <-> (b = true <-> ~ (c = true)). +Proof. + destruct b, c; split; easy + intros []; auto. + discriminate H0. + easy. +Qed. + +Lemma neq_iff_impls b c : + b <> c <-> + ((b = true -> ~ (c = true)) /\ + (c = true -> ~ (b = true)) /\ + (b = false -> ~ (c = false))). +Proof. + destruct b, c; split; easy + intros (? & ? & ?); auto. +Qed. + +End bool_lemmas. + +Section Assorted_lemmas. + +Lemma if_true {A} b (u v : A) : + b = true -> + (if b then u else v) = u. +Proof. + bdestructΩ'. +Qed. + +Lemma if_false {A} b (u v : A) : + b = false -> + (if b then u else v) = v. +Proof. + bdestructΩ'. +Qed. + +Lemma if_dist' {A B} (f : A -> B) (b : bool) (x y : A) : + f (if b then x else y) = if b then f x else f y. +Proof. + now destruct b. +Qed. + +Lemma orb_if {A} b c (v v' : A) : + (if (b || c) then v else v') = + if b then v else if c then v else v'. +Proof. + bdestructΩ'. +Qed. + +Lemma f_equal_if {A} (b c : bool) (u v x y : A) : + b = c -> u = v -> x = y -> + (if b then u else x) = (if c then v else y). +Proof. + intros; subst; easy. +Qed. + +Lemma f_equal_if_precedent {A} b c (v1 v2 u1 u2 : A) : + b = c -> + (b = true -> c = true -> v1 = v2) -> + (b = false -> c = false -> u1 = u2) -> + (if b then v1 else u1) = (if c then v2 else u2). +Proof. + intros ->. + destruct c; auto. +Qed. + +Lemma f_equal_if_precedent_same {A} b (v1 v2 u1 u2 : A) : + (b = true -> v1 = v2) -> + (b = false -> u1 = u2) -> + (if b then v1 else u1) = (if b then v2 else u2). +Proof. + intros. + apply f_equal_if_precedent; auto. +Qed. + +Lemma and_same (P : Prop) : P /\ P <-> P. +Proof. split; try intros []; auto. Qed. + +Local Open Scope nat_scope. + +Lemma and_andb {P P'} {b b'} : + reflect P b -> reflect P' b' -> + reflect (P /\ P') (b && b'). +Proof. + intros H H'; apply reflect_iff in H, H'. + apply iff_reflect. + rewrite andb_true_iff. + now rewrite H, H'. +Qed. + +Lemma forall_iff {A} (f g : A -> Prop) : + (forall a, (f a <-> g a)) -> + ((forall a, f a) <-> (forall a, g a)). +Proof. + intros ?; split; intros; apply H; auto. +Qed. + +Lemma impl_iff (P Q Q' : Prop) : + ((P -> Q) <-> (P -> Q')) <-> + (P -> (Q <-> Q')). +Proof. + split; + intros ?; split; intros; apply H; auto. +Qed. + +Import Setoid. + +Lemma Forall_forallb {A} (f : A -> bool) (P : A -> Prop) + (Hf : forall a, P a <-> f a = true) : + forall l, Forall P l <-> forallb f l = true. +Proof. + intros l. + induction l; [repeat constructor|]. + simpl. + rewrite andb_true_iff. + rewrite Forall_cons_iff. + apply Morphisms_Prop.and_iff_morphism; easy. +Qed. + +Lemma eq_eqb_iff (b c : bool) : + b = c <-> eqb b c = true. +Proof. + destruct b, c ; easy. +Qed. + +Lemma Forall_seq {start len : nat} f : + Forall f (seq start len) <-> forall k, k < len -> f (start + k). +Proof. + revert start; + induction len; intros start; + [split; constructor + lia|]. + simpl. + rewrite Forall_cons_iff. + split. + - intros [Hfk H]. + rewrite IHlen in H. + intros k Hk. + destruct k. + + rewrite Nat.add_0_r; easy. + + specialize (H k). + rewrite Nat.add_succ_r. + apply H. + lia. + - intros H. + rewrite IHlen; split. + + specialize (H 0). + rewrite Nat.add_0_r in H. + apply H; lia. + + intros k Hk; specialize (H (S k)). + rewrite Nat.add_succ_r in H. + apply H. + lia. +Qed. + +Lemma Forall_seq0 {len : nat} f : + Forall f (seq 0 len) <-> forall k, k < len -> f k. +Proof. + apply (@Forall_seq 0 len f). +Qed. + +Lemma forallb_seq (f : nat -> bool) n m : + forallb f (seq m n) = true <-> + (forall s, s < n -> f (s + m) = true). +Proof. + revert m; + induction n; intros m; [easy|]. + simpl. + rewrite andb_true_iff, IHn. + split. + - intros [Hm Hlt]. + intros s. + destruct s; [easy|]. + setoid_rewrite Nat.add_succ_r in Hlt. + intros. + apply Hlt; lia. + - intros Hlt; split. + + apply (Hlt 0 ltac:(lia)). + + intros s Hs. + rewrite Nat.add_succ_r. + apply (Hlt (S s)). + lia. +Qed. + +Lemma forallb_seq0 (f : nat -> bool) n : + forallb f (seq 0 n) = true <-> + (forall s, s < n -> f s = true). +Proof. + rewrite forallb_seq. + now setoid_rewrite Nat.add_0_r. +Qed. + +Lemma forall_lt_sum_split n m (P : nat -> Prop) : + (forall k, k < n + m -> P k) <-> + (forall k, k < n -> P k) /\ (forall k, k < m -> P (n + k)). +Proof. + split; [intros H; split; intros; apply H; lia|]. + intros [Hlow Hhigh]. + intros. + bdestruct (k G) n : + - big_sum f n = big_sum (fun k => - f k) n. +Proof. + induction n; simpl. + - apply Gopp0. + - rewrite Gopp_plus_distr. + now rewrite Gplus_comm, IHn. +Qed. + +Lemma big_sum_if_or + (ifl ifr : nat -> bool) + (f : nat -> G) (n : nat) : + big_sum (fun k => if ifl k || ifr k then f k else 0) n = + big_sum (fun k => if ifl k then f k else 0) n + + big_sum (fun k => if ifr k then f k else 0) n - + big_sum (fun k => if ifl k && ifr k then f k else 0) n. +Proof. + unfold Gminus. + rewrite big_sum_opp. + rewrite <- 2!big_sum_plus. + apply big_sum_eq_bounded. + intros. + bdestructΩ'; rewrite <- Gplus_assoc, ?Gopp_r, + ?Gopp0, ?Gplus_0_r, ?Gplus_0_l; easy. +Qed. + +Lemma big_sum_if_eq (f : nat -> G) n k : + big_sum (fun x => if x =? k then f x else 0) n = + if k G) n k : + big_sum (fun x => if k =? x then f x else 0) n = + if k G) n k l : k <> l -> + big_sum (fun x => if (x =? k) || (x =? l) then f x else 0) n = + (if k G) (Hi : (i < n)) : + big_sum v n = (big_sum v i) + v i + (big_sum (shift v (i + 1)) (n - 1 - i)). +Proof. + intros. + induction n; [lia|]. + bdestruct (i =? n). + - subst. + replace (S n - 1 - n)%nat with O by lia. + rewrite <- big_sum_extend_r. + simpl. + solve_monoid. + - specialize (IHn ltac:(lia)). + replace (S n - 1 - i)%nat with (S (n - 1 - i))%nat by lia. + rewrite <- !big_sum_extend_r. + rewrite IHn. + unfold shift; simpl. + replace (n - 1 - i + (i + 1))%nat with n by lia. + now rewrite Gplus_assoc. +Qed. + +Lemma big_sum_eq_up_to_fswap n (v : nat -> G) f x y (Hx : x < n) (Hy : y < n) : + big_sum (fun i => v (f i)) n = + big_sum (fun i => v (fswap f x y i)) n. +Proof. + bdestruct (x =? y); + [apply big_sum_eq_bounded; unfold fswap; intros; + bdestructΩ'|]. + bdestruct (x G) f (Hf : permutation n f) : + big_sum v n = big_sum (fun i => v (f i)) n. +Proof. + intros. + generalize dependent f. + induction n. + reflexivity. + intros f [g Hg]. + destruct (Hg n) as [_ [H1' [_ H2']]]; try lia. + symmetry. + rewrite (big_sum_eq_up_to_fswap _ v _ (g n) n) by auto. + repeat rewrite <- big_sum_extend_r. + rewrite fswap_simpl2. + rewrite H2'. + specialize (IHn (fswap f (g n) n)). + rewrite <- IHn; [easy|]. + apply fswap_at_boundary_permutation; auto. + exists g. auto. +Qed. + +Lemma big_sum_product_div_mod_split n m (f : nat -> G) : + big_sum f (n * m) = + big_sum (fun i => big_sum (fun j => f (j + i * n)%nat) n) m. +Proof. + rewrite big_sum_double_sum. + apply big_sum_eq_bounded. + intros k Hk. + f_equal. + rewrite (Nat.div_mod_eq k n) at 1. + lia. +Qed. + +End BigSumLemmas. + + +Section C_lemmas. + + +Local Open Scope C_scope. + +Lemma big_sum_if_eq_C (f : nat -> C) n k : + Σ (fun x => if x =? k then f x else 0%R) n = + (if k C) n k : + Σ (fun x => if k =? x then f x else 0%R) n = + (if k c = false) -> (c = true -> b = false) -> + ((if b then v else 0%R) + (if c then v else 0%R) = + if b || c then v else 0%R)%C. +Proof. + destruct b, c; simpl; intros; lca. +Qed. + +Lemma Cmult_if_l (b : bool) (c d : C) : + (if b then c else 0%R) * d = + if b then c * d else 0%R. +Proof. + destruct b; now Csimpl. +Qed. + +Lemma Cmult_if_r (b : bool) (c d : C) : + d * (if b then c else 0%R) = + if b then d * c else 0%R. +Proof. + destruct b; now Csimpl. +Qed. + +Lemma Cmult_if_andb (b c : bool) (x y : C) : + (if b then x else 0%R) * (if c then y else 0%R) = + if b && c then x * y else 0%R. +Proof. + destruct b,c; now Csimpl. +Qed. + +Lemma Cmult_if_1_l (b : bool) (d : C) : + (if b then C1 else 0%R) * d = + if b then d else 0%R. +Proof. + destruct b; now Csimpl. +Qed. + +Lemma Cmult_if_1_r (b : bool) (d : C) : + d * (if b then C1 else 0%R) = + if b then d else 0%R. +Proof. + destruct b; now Csimpl. +Qed. + +Lemma Cmult_if_if_1_l (b c : bool) (x : C) : + (if b then C1 else 0%R) * (if c then x else 0%R) = + if b && c then x else 0%R. +Proof. + destruct b; now Csimpl. +Qed. + +Lemma Cmult_if_if_1_r (b c : bool) (x : C) : + (if b then x else 0%R) * (if c then C1 else 0%R) = + if b && c then x else 0%R. +Proof. + destruct b,c; now Csimpl. +Qed. + +Lemma Cdiv_mult_r (c d : C) : d <> 0%R -> + c / d * d = c. +Proof. + intros. + C_field_simplify; trivial. +Qed. + +Lemma Cdiv_mult_l (c d : C) : d <> 0%R -> + d * c / d = c. +Proof. + intros. + C_field_simplify; trivial. +Qed. + +Lemma Cdiv_mult_l' (c d : C) : d <> 0%R -> + d * (c / d) = c. +Proof. + intros. + C_field_simplify; trivial. +Qed. + +Lemma Cdiv_nonzero (c d : C) : c <> 0%R -> d <> 0%R -> + c / d <> 0%R. +Proof. + intros Hc Hd Hf; apply Hc. + apply (f_equal (Cmult d)) in Hf. + rewrite Cdiv_mult_l' in Hf; [|easy]. + revert Hf. + now Csimpl. +Qed. + +Lemma C1_nonzero : C1 <> 0%R. +Proof. + unfold C1. + intros H; inversion H. + lra. +Qed. + +Lemma C2_nonzero : C2 <> 0%R. +Proof. + unfold C2. + intros H; inversion H. + lra. +Qed. + +End C_lemmas. + +Local Notation "A ⩧ B" := (mat_equiv A B) (at level 70) : matrix_scope. + +Section matrix_lemmas. + +#[global] Add Parametric Relation {n m} : (Matrix n m) (@mat_equiv n m) + reflexivity proved by ltac:(easy) + symmetry proved by ltac:(intros A B H i j Hi Hj; + symmetry; apply H; easy) + transitivity proved by ltac:(intros A B C H H' i j Hi Hj; + transitivity (B i j); [apply H | apply H']; easy) + as mat_equiv_setoid. + +#[global] Add Parametric Morphism {n m} : (@scale n m) + with signature + eq ==> (@mat_equiv n m) ==> mat_equiv + as scale_mat_equiv_proper. +Proof. + unfold scale. + intros x A B H i j Hi Hj. + rewrite (H i j Hi Hj). + easy. +Qed. + +#[global] Add Parametric Morphism {n m o} : (@Mmult m n o) + with signature + @mat_equiv m n ==> @mat_equiv n o ==> @mat_equiv m o + as Mmult_proper. +Proof. + intros A A' HA B B' HB. + unfold Mmult. + intros i j Hi Hj. + apply big_sum_eq_bounded. + intros k Hk. + now rewrite HA, HB. +Qed. + +#[global] Add Parametric Morphism {n m o p} : (@kron m n o p) + with signature + @mat_equiv m n ==> @mat_equiv o p ==> + @mat_equiv (m*o) (n*p) + as kron_proper. +Proof. + intros A A' HA B B' HB. + unfold kron. + intros i j Hi Hj. + rewrite HA, HB; + [easy|..]; + apply Nat.mod_upper_bound + apply Nat.Div0.div_lt_upper_bound; lia. +Qed. + +#[global] Add Parametric Morphism n m : (@Matrix.transpose n m) + with signature + @mat_equiv n m ==> @mat_equiv m n + as transpose_proper. +Proof. + unfold mat_equiv. + intros A B H i j Hi Hj. + now apply H. +Qed. + +Local Open Scope nat. +Local Open Scope matrix_scope. + + +Lemma transpose_proper_inv {n m} (A B : Matrix n m) : + A ⊤ ⩧ B ⊤ -> A ⩧ B. +Proof. + intros H i j Hi Hj; + now apply H. +Qed. + +Lemma mat_equiv_prop_symm {n m} (A B : Matrix n m) : + (exists c : C, mat_equiv A (c .* B) /\ c <> 0%R) + <-> exists c : C, mat_equiv B (c .* A) /\ c <> 0%R. +Proof. + split; + intros (c & Heq & Hc); + Proportional.prop_exists_nonzero (/ c); auto; + now rewrite Heq, Mscale_assoc, Cmult_comm, Cinv_r, Mscale_1_l. +Qed. + +Lemma kron_I_r {n m p} (A : Matrix n m) : + mat_equiv (A ⊗ I p) + (fun i j => if i mod p =? j mod p then A (i / p) (j / p) else C0). +Proof. + intros i j Hi Hj. + unfold kron, I. + pose proof (Nat.mod_upper_bound i p ltac:(lia)). + bdestructΩ'; lca. +Qed. + +Lemma kron_I_l {n m p} (A : Matrix n m) : + mat_equiv (I p ⊗ A) + (fun i j => if i / n =? j / m then A (i mod n) (j mod m) else C0). +Proof. + intros i j Hi Hj. + unfold kron, I. + rewrite Nat.mul_comm in Hi. + pose proof (Nat.Div0.div_lt_upper_bound _ _ _ Hi). + bdestructΩ'; lca. +Qed. + +Lemma kron_transpose' [m n o p] (A : Matrix m n) (B : Matrix o p) : + forall mo' mp', + @Matrix.transpose mo' mp' (A ⊗ B) = + (@Matrix.transpose m n A) ⊗ (@Matrix.transpose o p B). +Proof. + intros. + apply kron_transpose. +Qed. + +Lemma kron_1_l_mat_equiv {m n} (A : Matrix m n) : + I 1 ⊗ A ⩧ A. +Proof. + intros i j Hi Hj. + unfold kron. + rewrite !Nat.div_small, !Nat.mod_small by lia. + apply Cmult_1_l. +Qed. + +Lemma matrix_times_basis_eq_lt {m n : nat} (A : Matrix m n) (i j : nat) : + j < n -> (A × basis_vector n j) i 0 = A i j. +Proof. + intros Hj. + unfold Mmult. + rewrite (big_sum_eq_bounded _ (fun k => if k =? j then A i j else 0%R)%C). + 2: { + intros k Hk. + unfold basis_vector. + bdestructΩ'; lca. + } + rewrite big_sum_if_eq_C. + bdestructΩ'. +Qed. + +Lemma matrix_times_basis_mat_equiv {m n : nat} (A : Matrix m n) (j : nat) : + j < n -> mat_equiv (A × basis_vector n j) + (get_vec j A). +Proof. + intros Hj i z Hi Hz. + replace z with 0 by lia. + rewrite matrix_times_basis_eq_lt by easy. + unfold get_vec. + bdestructΩ'. +Qed. + +Lemma matrix_conj_basis_eq_lt {m n : nat} (A : Matrix m n) (i j : nat) : + i < m -> j < n -> ((basis_vector m i)⊤ × A × basis_vector n j) 0 0 = A i j. +Proof. + intros Hi Hj. + rewrite matrix_times_basis_mat_equiv by lia. + unfold get_vec. + bdestructΩ'. + unfold Mmult, Matrix.transpose. + rewrite (big_sum_eq_bounded _ (fun k => if k =? i then A i j else 0%R)%C). + 2: { + intros k Hk. + unfold basis_vector. + bdestructΩ'; lca. + } + rewrite big_sum_if_eq_C. + bdestructΩ'. +Qed. + +Lemma mat_equiv_of_all_basis_conj {m n : nat} (A B : Matrix m n) + (H : forall (i j : nat), i < m -> j < n -> + ((basis_vector m i) ⊤ × A × basis_vector n j) 0 0 = + ((basis_vector m i) ⊤ × B × basis_vector n j) 0 0) : + mat_equiv A B. +Proof. + intros i j Hi Hj. + specialize (H i j Hi Hj). + now rewrite 2!matrix_conj_basis_eq_lt in H by easy. +Qed. + +Lemma basis_trans_basis {n} i j : + ((basis_vector n i) ⊤ × basis_vector n j) 0 0 = + if (i =? j) && (i f (m + k)) (* : Matrix _ 1) *))). +Proof. + rewrite <- kron_mixed_product. + rewrite f_to_vec_merge. + Morphisms.f_equiv. + apply f_to_vec_eq. + intros; bdestructΩ'; f_equal; lia. +Qed. + +Lemma f_to_vec_split' n m f : + mat_equiv (f_to_vec (n + m) f) + (f_to_vec n f ⊗ f_to_vec m (fun k => f (n + k))). +Proof. + intros i j Hi Hj. + rewrite f_to_vec_merge. + erewrite f_to_vec_eq; [reflexivity|]. + intros; simpl; bdestructΩ'; f_equal; lia. +Qed. + +Lemma f_to_vec_split'_eq n m f : + (f_to_vec (n + m) f) = + (f_to_vec n f ⊗ f_to_vec m (fun k => f (n + k))). +Proof. + apply mat_equiv_eq; [..|apply f_to_vec_split']; auto with wf_db. +Qed. + +Lemma f_to_vec_1_eq f : + f_to_vec 1 f = if f 0 then ∣1⟩ else ∣0⟩. +Proof. + cbn. + unfold ket. + rewrite kron_1_l by (destruct (f 0); auto with wf_db). + now destruct (f 0). +Qed. + +Lemma f_to_vec_1_mult_r f (A : Matrix (2^1) (2^1)) : + A × f_to_vec 1 f = (fun x j => if j =? 0 then A x (Nat.b2n (f 0)) else 0%R). +Proof. + cbn. + rewrite kron_1_l by auto with wf_db. + apply functional_extensionality; intros i. + apply functional_extensionality; intros j. + unfold Mmult. + simpl. + destruct (f 0); + unfold ket; + simpl; + now destruct j; simpl; Csimpl. +Qed. + +Lemma f_to_vec_1_mult_r_decomp f (A : Matrix (2^1) (2^1)) : + A × f_to_vec 1 f ⩧ + A 0 (Nat.b2n (f 0)) .* ∣0⟩ .+ + A 1 (Nat.b2n (f 0)) .* ∣1⟩. +Proof. + rewrite f_to_vec_1_mult_r. + intros i j Hi Hj. + replace j with 0 by lia. + simpl. + autounfold with U_db. + do 2 (try destruct i); [..| simpl in *; lia]; + now Csimpl. +Qed. + +Lemma f_to_vec_1_mult_r_decomp_eq f (A : Matrix (2^1) (2^1)) : + WF_Matrix A -> + A × f_to_vec 1 f = + A 0 (Nat.b2n (f 0)) .* ∣0⟩ .+ + A 1 (Nat.b2n (f 0)) .* ∣1⟩. +Proof. + intros. + apply mat_equiv_eq; auto with wf_db. + apply f_to_vec_1_mult_r_decomp. +Qed. + +Lemma qubit0_f_to_vec : ∣0⟩ = f_to_vec 1 (fun x => false). +Proof. now rewrite f_to_vec_1_eq. Qed. + +Lemma qubit1_f_to_vec : ∣1⟩ = f_to_vec 1 (fun x => x =? 0). +Proof. now rewrite f_to_vec_1_eq. Qed. + +Lemma ket_f_to_vec b : ∣ Nat.b2n b ⟩ = f_to_vec 1 (fun x => b). +Proof. + destruct b; [apply qubit1_f_to_vec | apply qubit0_f_to_vec]. +Qed. + +Lemma f_to_vec_1_mult_r_decomp_eq' f (A : Matrix (2^1) (2^1)) : + WF_Matrix A -> + A × f_to_vec 1 f = + A 0 (Nat.b2n (f 0)) .* f_to_vec 1 (fun x => false) .+ + A 1 (Nat.b2n (f 0)) .* f_to_vec 1 (fun x => x=?0). +Proof. + intros. + apply mat_equiv_eq; auto with wf_db. + rewrite f_to_vec_1_mult_r_decomp. + rewrite 2!f_to_vec_1_eq. + easy. +Qed. + +Lemma f_to_vec_1_mult_l_decomp f (A : Matrix (2^1) (2^1)) : + (f_to_vec 1 f) ⊤ × A ⩧ + A (Nat.b2n (f 0)) 0 .* (∣0⟩ ⊤) .+ + A (Nat.b2n (f 0)) 1 .* (∣1⟩ ⊤). +Proof. + rewrite <- (transpose_involutive _ _ A). + rewrite <- Mmult_transpose, <- Mscale_trans. + intros i j Hi Hj. + apply (f_to_vec_1_mult_r_decomp f (A ⊤)); easy. +Qed. + +Lemma f_to_vec_1_mult_l_decomp_eq f (A : Matrix (2^1) (2^1)) : + WF_Matrix A -> + (f_to_vec 1 f) ⊤ × A = + A (Nat.b2n (f 0)) 0 .* (∣0⟩ ⊤) .+ + A (Nat.b2n (f 0)) 1 .* (∣1⟩ ⊤). +Proof. + intros. + apply mat_equiv_eq; auto with wf_db. + apply f_to_vec_1_mult_l_decomp. +Qed. + +Lemma f_to_vec_1_mult_l_decomp_eq' f (A : Matrix (2^1) (2^1)) : + WF_Matrix A -> + (f_to_vec 1 f) ⊤ × A = + A (Nat.b2n (f 0)) 0 .* ((f_to_vec 1 (fun x => false)) ⊤) .+ + A (Nat.b2n (f 0)) 1 .* ((f_to_vec 1 (fun x => x =? 0)) ⊤). +Proof. + intros. + apply mat_equiv_eq; auto with wf_db. + rewrite f_to_vec_1_mult_l_decomp_eq by easy. + now rewrite qubit0_f_to_vec, qubit1_f_to_vec. +Qed. + +Lemma funbool_to_nat_add_pow2_join n f g m : + funbool_to_nat n f * 2 ^ m + funbool_to_nat m g = + funbool_to_nat (n + m) (fun k => if k f (n + k - (min n m))). +Proof. + apply bits_inj. + intros s. + rewrite testbit_mod_pow2, 2!testbit_funbool_to_nat. + rewrite min_ltb. + bdestructΩ'; f_equal; lia. +Qed. + +Lemma funbool_to_nat_eq_iff n f g : + (forall k, k < n -> f k = g k) <-> funbool_to_nat n f = funbool_to_nat n g. +Proof. + split; + [apply funbool_to_nat_eq|]. + intros H k Hk. + apply (f_equal (fun f => Nat.testbit f (n - S k))) in H. + revert H. + rewrite 2!testbit_funbool_to_nat. + simplify_bools_lia. + now replace (n - S (n - S k)) with k by lia. +Qed. + +(* For setoid_rewrite *) +Lemma nat_to_funbool_eq' n j k : + nat_to_funbool n j k = + if k <=? n - 1 then Nat.testbit j (n - S k) else false. +Proof. + now rewrite nat_to_funbool_eq. +Qed. + +End QuantumLib_lemmas. + +End matrix_lemmas. + +End AuxiliaryLemmas. diff --git a/src/Permutations/PermutationDefinitions.v b/src/Permutations/PermutationDefinitions.v new file mode 100644 index 0000000..4a50b61 --- /dev/null +++ b/src/Permutations/PermutationDefinitions.v @@ -0,0 +1,91 @@ +Require Export QuantumLib.Permutations. +Require Import CoreData.ZXCore. + +Declare Scope perm_scope. +Delimit Scope perm_scope with perm. + +Section PermutationDefinitions. + +Local Open Scope nat_scope. + +Definition stack_perms (n0 n1 : nat) (f g : nat -> nat) : nat -> nat := + fun n => + if (n nat) : nat -> nat := + fun n => if (n0 * n1 <=? n) then n else + (f (n / n1) * n1 + g (n mod n1)). + +Definition swap_perm a b n := + fun k => if n <=? k then k else + if k =? a then b else + if k =? b then a else k. + + +(* TODO: Implement things for this *) +Fixpoint insertion_sort_list n f := + match n with + | 0 => [] + | S n' => let k := (perm_inv (S n') f n') in + k :: insertion_sort_list n' (Bits.fswap f k n') + end. + +Fixpoint swap_list_spec l : bool := + match l with + | [] => true + | k :: ks => (k idn + | k :: ks => let n := length ks in + (swap_perm k n (S n) ∘ (perm_of_swap_list ks))%prg + end. + +Fixpoint invperm_of_swap_list l := + match l with + | [] => idn + | k :: ks => let n := length ks in + ((invperm_of_swap_list ks) ∘ swap_perm k n (S n))%prg + end. + +Definition perm_inv' n f := + fun k => if n <=? k then k else perm_inv n f k. + +Definition contract_perm f a := + fun k => + if k nat := + swap_perm 0 1 2. + +Definition rotr n m : nat -> nat := + fun k => if n <=? k then k else (k + m) mod n. + +Definition rotl n m : nat -> nat := + fun k => if n <=? k then k else (k + (n - (m mod n))) mod n. + +Definition swap_block_perm padl padm a := + fun k => + if k + if n <=? k then k else n - S k. + +End PermutationDefinitions. + +(* Notation "f '=[' n ']' g" := (perm_eq_upto n f g) + (at level 70, no associativity): perm_scope. + +Notation "'perm_bdd' n f" := (forall k, (k < n%nat)%nat -> (f k < n%nat)%nat) + (at level 10, n at level 9, f at level 9) : perm_scope. *) diff --git a/src/Permutations/PermutationFacts.v b/src/Permutations/PermutationFacts.v new file mode 100644 index 0000000..96b2df0 --- /dev/null +++ b/src/Permutations/PermutationFacts.v @@ -0,0 +1,1797 @@ +Require Import StrongInduction. +Require Import List. +Require Import QuantumLib.Bits. +Require Export PermutationDefinitions. +Require Import PermutationAutomation. +Require (* Import *) PermutationAuxiliary. + + +Open Scope nat. +Open Scope prg. +Open Scope perm_scope. + +Lemma permutation_eqb_iff {n f} a b : permutation n f -> + a < n -> b < n -> + f a =? f b = (a =? b). +Proof. + intros Hperm Hk Hfk. + bdestruct_one. + apply (permutation_is_injective n f Hperm) in H; [bdestruct_one| |]; lia. + bdestruct_one; subst; easy. +Qed. + +Lemma permutation_eq_iff {n f} a b : permutation n f -> + a < n -> b < n -> + f a = f b <-> a = b. +Proof. + intros Hperm Hk Hfk. + generalize (permutation_eqb_iff _ _ Hperm Hk Hfk). + bdestructΩ'. +Qed. + +(* TODO: Move somewhere else *) +Lemma perm_eq_iff_forall n (f g : nat -> nat) : + perm_eq n f g <-> forallb (fun k => f k =? g k) (seq 0 n) = true. +Proof. + rewrite PermutationAuxiliary.forallb_seq0. + now setoid_rewrite Nat.eqb_eq. +Qed. + +Lemma perm_eq_dec n (f g : nat -> nat) : + {perm_eq n f g} + {~ perm_eq n f g}. +Proof. + generalize (perm_eq_iff_forall n f g). + destruct (forallb (fun k => f k =? g k) (seq 0 n)); intros H; + [left | right]; rewrite H; easy. +Qed. + +Lemma not_forallb_seq_exists f start len : + forallb f (seq start len) = false -> + exists n, n < len /\ f (n + start) = false. +Proof. + revert start; induction len; [easy|]. + intros start. + simpl. + rewrite andb_false_iff. + intros [H | H]. + - exists 0. split; [lia | easy]. + - destruct (IHlen (S start) H) as (n & Hn & Hfn). + exists (S n); split; rewrite <- ?Hfn; f_equal; lia. +Qed. + +Lemma not_forallb_seq0_exists f n : + forallb f (seq 0 n) = false -> + exists k, k < n /\ f k = false. +Proof. + intros H. + apply not_forallb_seq_exists in H. + setoid_rewrite Nat.add_0_r in H. + exact H. +Qed. + +Lemma not_perm_eq_not_eq_at n (f g : nat -> nat) : + ~ (perm_eq n f g) -> exists k, k < n /\ f k <> g k. +Proof. + rewrite perm_eq_iff_forall. + rewrite not_true_iff_false. + intros H. + apply not_forallb_seq0_exists in H. + setoid_rewrite Nat.eqb_neq in H. + exact H. +Qed. + +(* Add Parametric Relation n : (nat -> nat) (fun f g => perm_eq n f g) + reflexivity proved by ltac:(easy) + symmetry proved by ltac:(intros; intros k Hk; symmetry; auto) + transitivity proved by ltac:(intros f g h Hfg Hgh k Hk; + transitivity (g k); auto) + as perm_eq_setoid. *) + +Lemma perm_bounded_of_eq {n f g} : + perm_eq n g f -> perm_bounded n f -> + perm_bounded n g. +Proof. + intros Hfg Hf k Hk. + rewrite Hfg; auto. +Qed. + + +(* Section on perm_inv *) +Lemma perm_inv'_eq n f : + perm_eq n (perm_inv' n f) (perm_inv n f). +Proof. + intros k Hk. + unfold perm_inv'. + bdestructΩ'. +Qed. + +#[export] Hint Extern 0 + (perm_eq ?n (perm_inv' ?n ?f) ?g) => + apply (perm_eq_trans (perm_inv'_eq n _)) : perm_inv_db. + +#[export] Hint Extern 0 + (perm_eq ?n ?g (perm_inv' ?n ?f)) => + apply (fun H => perm_eq_trans + H (perm_eq_sym (perm_inv'_eq n _))) : perm_inv_db. + +Lemma perm_inv'_bounded n f : + perm_bounded n (perm_inv' n f). +Proof. + apply (perm_bounded_of_eq (perm_inv'_eq n f)). + auto with perm_bounded_db. +Qed. + +Lemma perm_inv'_WF n f : + WF_Perm n (perm_inv' n f). +Proof. + intros k Hk; + unfold perm_inv'; + bdestructΩ'. +Qed. + +#[export] Hint Resolve perm_inv'_bounded : perm_bounded_db. +#[export] Hint Resolve perm_inv'_WF : WF_Perm_db. + +Lemma permutation_of_le_permutation_WF f m n : (m <= n)%nat -> permutation m f -> + WF_Perm m f -> permutation n f. +Proof. + intros Hmn [finv_m Hfinv_m] HWF. + exists (fun k => if m <=? k then k else finv_m k). + intros k Hk. + bdestruct (m <=? k). + - rewrite !HWF; bdestructΩ'. + - specialize (Hfinv_m _ H). + bdestructΩ'. +Qed. + + +#[export] Hint Rewrite @compose_idn_r @compose_idn_l : perm_cleanup_db. +#[global] Hint Resolve perm_inv'_bounded : perm_bounded_db. +#[export] Hint Resolve perm_inv_permutation : perm_db. + + +Lemma perm_inv_is_linv_of_permutation_compose (n : nat) (f : nat -> nat) : + permutation n f -> + perm_eq n (perm_inv n f ∘ f) idn. +Proof. + apply perm_inv_is_linv_of_permutation. +Qed. + +#[export] Hint Resolve + perm_inv_is_linv_of_permutation + perm_inv_is_linv_of_permutation_compose : perm_inv_db. + +Lemma perm_inv_is_rinv_of_permutation_compose (n : nat) (f : nat -> nat) : + permutation n f -> + perm_eq n (f ∘ perm_inv n f) idn. +Proof. + apply perm_inv_is_rinv_of_permutation. +Qed. + +#[export] Hint Resolve + perm_inv_is_rinv_of_permutation + perm_inv_is_rinv_of_permutation_compose : perm_inv_db. + +Lemma perm_eq_compose_proper n (f f' g g' : nat -> nat) : + perm_bounded n g -> perm_eq n f f' -> perm_eq n g g' -> + perm_eq n (f ∘ g) (f' ∘ g'). +Proof. + intros Hg Hf' Hg' k Hk. + unfold compose. + now rewrite Hf', Hg' by auto. +Qed. + +#[export] Hint Resolve perm_eq_compose_proper : perm_inv_db. + +Lemma perm_inv'_is_linv_of_permutation_compose (n : nat) (f : nat -> nat) : + permutation n f -> + perm_eq n (perm_inv' n f ∘ f) idn. +Proof. + intros Hf k Hk. + unfold compose. + rewrite perm_inv'_eq by auto with perm_db. + auto with perm_inv_db. +Qed. + +#[export] Hint Resolve perm_inv'_is_linv_of_permutation_compose : perm_inv_db. + +Lemma perm_inv'_is_rinv_of_permutation_compose (n : nat) (f : nat -> nat) : + permutation n f -> + perm_eq n (f ∘ perm_inv' n f) idn. +Proof. + intros Hf k Hk. + unfold compose. + rewrite perm_inv'_eq by auto with perm_db. + auto with perm_inv_db. +Qed. + +#[export] Hint Resolve perm_inv'_is_rinv_of_permutation_compose : perm_inv_db. + +Lemma idn_WF_Perm n : WF_Perm n idn. +Proof. easy. Qed. + +#[export] Hint Resolve idn_WF_Perm : WF_Perm_db. +#[export] Hint Resolve compose_WF_Perm : WF_Perm_db. + + +Lemma perm_inv'_linv_of_permutation_WF n f : + permutation n f -> WF_Perm n f -> + perm_inv' n f ∘ f = idn. +Proof. + intros. + eq_by_WF_perm_eq n. + cleanup_perm_inv. +Qed. + +Lemma perm_inv'_rinv_of_permutation_WF n f : + permutation n f -> WF_Perm n f -> + f ∘ perm_inv' n f = idn. +Proof. + intros. + eq_by_WF_perm_eq n. + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite perm_inv'_linv_of_permutation_WF + perm_inv'_rinv_of_permutation_WF + using (solve [auto with perm_db WF_Perm_db]) : perm_inv_db. + +Lemma perm_eq_linv_injective n f finv finv' : permutation n f -> + is_perm_linv n f finv -> is_perm_linv n f finv' -> + perm_eq n finv finv'. +Proof. + intros Hperm Hfinv Hfinv'. + perm_eq_by_inv_inj f n. +Qed. + +Lemma perm_inv_eq_inv n f finv : + (forall x : nat, x < n -> f x < n /\ finv x < n + /\ finv (f x) = x /\ f (finv x) = x) + -> perm_eq n (perm_inv n f) finv. +Proof. + intros Hfinv. + assert (Hperm: permutation n f) by (exists finv; easy). + perm_eq_by_inv_inj f n. + intros; now apply Hfinv. +Qed. + +Lemma perm_inv_is_inv n f : permutation n f -> + forall k : nat, k < n -> perm_inv n f k < n /\ f k < n + /\ f (perm_inv n f k) = k /\ perm_inv n f (f k) = k. +Proof. + intros Hperm k Hk. + repeat split. + - apply perm_inv_bounded, Hk. + - destruct Hperm as [? H]; apply H, Hk. + - rewrite perm_inv_is_rinv_of_permutation; easy. + - rewrite perm_inv_is_linv_of_permutation; easy. +Qed. + +Lemma perm_inv_perm_inv n f : permutation n f -> + perm_eq n (perm_inv n (perm_inv n f)) f. +Proof. + intros Hf. + perm_eq_by_inv_inj (perm_inv n f) n. +Qed. + +#[export] Hint Resolve perm_inv_perm_inv : perm_inv_db. + +Lemma perm_inv_eq_of_perm_eq' n m f g : perm_eq n f g -> m <= n -> + perm_eq n (perm_inv m f) (perm_inv m g). +Proof. + intros Heq Hm. + induction m; [trivial|]. + intros k Hk. + simpl. + rewrite Heq by lia. + rewrite IHm by lia. + easy. +Qed. + +Lemma perm_inv_eq_of_perm_eq n f g : perm_eq n f g -> + perm_eq n (perm_inv n f) (perm_inv n g). +Proof. + intros Heq. + apply perm_inv_eq_of_perm_eq'; easy. +Qed. + +#[export] Hint Resolve perm_inv_eq_of_perm_eq : perm_inv_db. + +Lemma perm_inv'_eq_of_perm_eq n f g : perm_eq n f g -> + perm_inv' n f = perm_inv' n g. +Proof. + intros Heq. + eq_by_WF_perm_eq n. + cleanup_perm_inv. +Qed. + +#[export] Hint Resolve perm_inv_eq_of_perm_eq' : perm_inv_db. + +#[export] Hint Extern 20 + (?f = ?g) => + eapply eq_of_WF_perm_eq; + auto with WF_Perm_db : perm_inv_db. + +Lemma perm_inv'_perm_inv n f : permutation n f -> + perm_eq n (perm_inv' n (perm_inv n f)) f. +Proof. + cleanup_perm_inv. +Qed. + +Lemma perm_inv_perm_inv' n f : permutation n f -> + perm_eq n (perm_inv n (perm_inv' n f)) f. +Proof. + intros Hf k Hk. + rewrite (perm_inv_eq_of_perm_eq _ _ _ (perm_inv'_eq _ _)) by easy. + cleanup_perm_inv. +Qed. + +Lemma perm_inv'_perm_inv_eq n f : + permutation n f -> WF_Perm n f -> + perm_inv' n (perm_inv n f) = f. +Proof. + cleanup_perm_inv. +Qed. + +Lemma perm_inv'_perm_inv' n f : permutation n f -> + perm_eq n (perm_inv' n (perm_inv' n f)) f. +Proof. + intros Hf. + rewrite (perm_inv'_eq_of_perm_eq _ _ _ (perm_inv'_eq n f)). + cleanup_perm_inv. +Qed. + +Lemma perm_inv'_perm_inv'_eq n f : + permutation n f -> WF_Perm n f -> + perm_inv' n (perm_inv' n f) = f. +Proof. + rewrite (perm_inv'_eq_of_perm_eq _ _ _ (perm_inv'_eq n f)). + cleanup_perm_inv. +Qed. + +#[export] Hint Resolve perm_inv'_perm_inv + perm_inv'_perm_inv' perm_inv_perm_inv' : perm_inv_db. +#[export] Hint Rewrite perm_inv'_perm_inv_eq + perm_inv'_perm_inv'_eq + using + solve [auto with perm_db WF_Perm_db] : perm_inv_db. + +Lemma permutation_compose' n f g : + permutation n f -> permutation n g -> + permutation n (fun x => f (g x)). +Proof. + apply permutation_compose. +Qed. + +#[export] Hint Resolve permutation_compose permutation_compose' : perm_db. + +#[export] Hint Rewrite perm_inv_is_linv_of_permutation + perm_inv_is_rinv_of_permutation : perm_inv_db. + +Lemma perm_inv_eq_iff {n g} (Hg : permutation n g) + {k m} (Hk : k < n) (Hm : m < n) : + perm_inv n g k = m <-> k = g m. +Proof. + split; + [intros <- | intros ->]; + rewrite ?(perm_inv_is_rinv_of_permutation _ g Hg), + ?(perm_inv_is_linv_of_permutation _ g Hg); + easy. +Qed. + +Lemma perm_inv_eqb_iff {n g} (Hg : permutation n g) + {k m} (Hk : k < n) (Hm : m < n) : + (perm_inv n g k =? m) = (k =? g m). +Proof. + apply Bool.eq_iff_eq_true; + rewrite 2!Nat.eqb_eq; + now apply perm_inv_eq_iff. +Qed. + +Lemma perm_inv_ge n g k : + n <= perm_inv n g k -> n <= k. +Proof. + intros H. + bdestruct (n <=? k); [lia|]. + specialize (perm_inv_bounded n g k); lia. +Qed. + +Lemma compose_perm_inv_l n f g h + (Hf : permutation n f) (Hg : perm_bounded n g) + (Hh : perm_bounded n h) : + perm_eq n (perm_inv n f ∘ g) h <-> + perm_eq n g (f ∘ h). +Proof. + split; unfold compose. + - intros H k Hk. + rewrite <- H; cleanup_perm_inv. + - intros H k Hk. + rewrite H; cleanup_perm_inv. +Qed. + +Lemma compose_perm_inv_r n f g h + (Hf : permutation n f) (Hg : perm_bounded n g) + (Hh : perm_bounded n h) : + perm_eq n (g ∘ perm_inv n f) h <-> + perm_eq n g (h ∘ f). +Proof. + split; unfold compose. + - intros H k Hk. + rewrite <- H; cleanup_perm_inv. + - intros H k Hk. + rewrite H; cleanup_perm_inv. +Qed. + +Lemma compose_perm_inv_l' n f g h + (Hf : permutation n f) (Hg : perm_bounded n g) + (Hh : perm_bounded n h) : + perm_eq n h (perm_inv n f ∘ g) <-> + perm_eq n (f ∘ h) g. +Proof. + split; intros H; + apply perm_eq_sym, + compose_perm_inv_l, perm_eq_sym; + assumption. +Qed. + +Lemma compose_perm_inv_r' n f g h + (Hf : permutation n f) (Hg : perm_bounded n g) + (Hh : perm_bounded n h) : + perm_eq n h (g ∘ perm_inv n f) <-> + perm_eq n (h ∘ f) g. +Proof. + split; intros H; + apply perm_eq_sym, + compose_perm_inv_r, perm_eq_sym; + assumption. +Qed. + +Lemma compose_perm_inv'_l n (f g h : nat -> nat) + (Hf : permutation n f) (HWFf : WF_Perm n f) : + perm_inv' n f ∘ g = h <-> g = f ∘ h. +Proof. + split; [intros <- | intros ->]; + rewrite <- compose_assoc; + cleanup_perm_inv. +Qed. + +Lemma compose_perm_inv'_r n (f g h : nat -> nat) + (Hf : permutation n f) (HWFf : WF_Perm n f) : + g ∘ perm_inv' n f = h <-> g = h ∘ f. +Proof. + split; [intros <- | intros ->]; + rewrite compose_assoc; + cleanup_perm_inv. +Qed. + +Lemma compose_perm_inv'_l' n (f g h : nat -> nat) + (Hf : permutation n f) (HWFf : WF_Perm n f) : + h = perm_inv' n f ∘ g <-> f ∘ h = g. +Proof. + split; [intros -> | intros <-]; + rewrite <- compose_assoc; + cleanup_perm_inv. +Qed. + +Lemma compose_perm_inv'_r' n (f g h : nat -> nat) + (Hf : permutation n f) (HWFf : WF_Perm n f) : + h = g ∘ perm_inv' n f <-> h ∘ f = g. +Proof. + split; [intros -> | intros <-]; + rewrite compose_assoc; + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite perm_inv_perm_inv : perm_inv_db. + +Lemma perm_inv_perm_eq_iff n f g + (Hf : permutation n f) (Hg : permutation n g) : + perm_eq n (perm_inv n g) f <-> perm_eq n g (perm_inv n f). +Proof. + rewrite <- (compose_idn_r (perm_inv n g)). + rewrite <- (compose_idn_l (perm_inv n f)). + rewrite compose_perm_inv_l, compose_perm_inv_r' by cleanup_perm. + split; apply perm_eq_sym. +Qed. + +Lemma perm_inv_compose {n f g} (Hf : permutation n f) (Hg : permutation n g) : + perm_eq n + (perm_inv n (f ∘ g)) + (perm_inv n g ∘ perm_inv n f). +Proof. + apply perm_eq_sym. + perm_eq_by_inv_inj (f ∘ g) n. + apply compose_perm_inv_l; auto with perm_db. + apply compose_perm_inv_l; auto with perm_db. +Qed. + +#[export] Hint Resolve perm_inv_compose : perm_inv_db. + +Lemma perm_inv'_compose {n f g} + (Hf : permutation n f) (Hg : permutation n g) : + perm_inv' n (f ∘ g) = + perm_inv' n g ∘ perm_inv' n f. +Proof. + eq_by_WF_perm_eq n. + apply (perm_eq_trans (perm_inv'_eq _ _)). + apply (perm_eq_trans (perm_inv_compose Hf Hg)). + apply perm_eq_compose_proper; + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite @perm_inv'_compose + using auto with perm_db : perm_inv_db. + + + +Lemma idn_inv n : + perm_eq n (perm_inv n idn) idn. +Proof. + perm_eq_by_inv_inj (fun k:nat => k) n. +Qed. + +#[export] Hint Resolve idn_inv : perm_inv_db. + +Lemma idn_inv' n : + perm_inv' n idn = idn. +Proof. + permutation_eq_by_WF_inv_inj (fun k:nat=>k) n. +Qed. + +#[export] Hint Rewrite idn_inv' : perm_inv_db. + + +Lemma swap_perm_same a n : + swap_perm a a n = idn. +Proof. + unfold swap_perm. + apply functional_extensionality; intros k. + bdestructΩ'. +Qed. + +Lemma swap_perm_comm a b n : + swap_perm a b n = swap_perm b a n. +Proof. + apply functional_extensionality; intros k. + unfold swap_perm. + bdestructΩ'. +Qed. + +Lemma swap_perm_WF a b n : + WF_Perm n (swap_perm a b n). +Proof. + intros k Hk. + unfold swap_perm. + bdestructΩ'. +Qed. + +Lemma swap_perm_bounded a b n : a < n -> b < n -> + perm_bounded n (swap_perm a b n). +Proof. + intros Ha Hb k Hk. + unfold swap_perm. + bdestructΩ'. +Qed. + +Lemma swap_perm_invol a b n : a < n -> b < n -> + (swap_perm a b n) ∘ (swap_perm a b n) = idn. +Proof. + intros Ha Hb. + unfold compose. + apply functional_extensionality; intros k. + unfold swap_perm. + bdestructΩ'. +Qed. + +#[export] Hint Rewrite swap_perm_same : perm_cleanup_db. +#[export] Hint Resolve swap_perm_WF : WF_Perm_db. +#[export] Hint Resolve swap_perm_bounded : perm_bounded_db. +#[export] Hint Rewrite swap_perm_invol : perm_inv_db. + +Lemma swap_perm_permutation a b n : a < n -> b < n -> + permutation n (swap_perm a b n). +Proof. + intros Ha Hb. + perm_by_inverse (swap_perm a b n). +Qed. + +Lemma swap_perm_S_permutation a n (Ha : S a < n) : + permutation n (swap_perm a (S a) n). +Proof. + apply swap_perm_permutation; lia. +Qed. + +#[export] Hint Resolve swap_perm_permutation : perm_db. +#[export] Hint Resolve swap_perm_S_permutation : perm_db. + + +Lemma swap_perm_inv a b n : a < n -> b < n -> + perm_eq n (perm_inv n (swap_perm a b n)) + (swap_perm a b n). +Proof. + intros Ha Hb. + perm_eq_by_inv_inj (swap_perm a b n) n. +Qed. + +#[export] Hint Resolve swap_perm_inv : perm_inv_db. + +Lemma swap_perm_inv' a b n : a < n -> b < n -> + perm_inv' n (swap_perm a b n) = + swap_perm a b n. +Proof. + intros. + eq_by_WF_perm_eq n; cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite swap_perm_inv' : perm_inv_db. + +Lemma compose_swap_perm a b c n : a < n -> b < n -> c < n -> + b <> c -> a <> c -> + (swap_perm a b n ∘ swap_perm b c n ∘ swap_perm a b n) = swap_perm a c n. +Proof. + intros Ha Hb Hc Hbc Hac. + eq_by_WF_perm_eq n. + unfold compose, swap_perm. + intros k Hk. + bdestructΩ'. +Qed. + +#[export] Hint Rewrite compose_swap_perm : perm_cleanup_db. + + + + + +(* Section on insertion_sort_list *) + +Lemma fswap_eq_compose_swap_perm {A} (f : nat -> A) n m o : n < o -> m < o -> + fswap f n m = f ∘ swap_perm n m o. +Proof. + intros Hn Hm. + apply functional_extensionality; intros k. + unfold compose, fswap, swap_perm. + bdestruct_all; easy. +Qed. + +Lemma fswap_perm_invol_n_permutation f n : permutation (S n) f -> + permutation n (fswap f (perm_inv (S n) f n) n). +Proof. + intros Hperm. + apply fswap_at_boundary_permutation. + - apply Hperm. + - apply perm_inv_bounded_S. + - apply perm_inv_is_rinv_of_permutation; auto. +Qed. + + +Lemma perm_of_swap_list_WF l : swap_list_spec l = true -> + WF_Perm (length l) (perm_of_swap_list l). +Proof. + induction l. + - easy. + - simpl. + rewrite andb_true_iff. + intros [Ha Hl]. + intros k Hk. + unfold compose. + rewrite IHl; [|easy|lia]. + rewrite swap_perm_WF; easy. +Qed. + +Lemma invperm_of_swap_list_WF l : swap_list_spec l = true -> + WF_Perm (length l) (invperm_of_swap_list l). +Proof. + induction l. + - easy. + - simpl. + rewrite andb_true_iff. + intros [Ha Hl]. + intros k Hk. + unfold compose. + rewrite swap_perm_WF; [|easy]. + rewrite IHl; [easy|easy|lia]. +Qed. + +#[export] Hint Resolve perm_of_swap_list_WF invperm_of_swap_list_WF : WF_Perm_db. + +Lemma perm_of_swap_list_bounded l : swap_list_spec l = true -> + perm_bounded (length l) (perm_of_swap_list l). +Proof. + induction l; [easy|]. + simpl. + rewrite andb_true_iff. + intros [Ha Hl]. + intros k Hk. + unfold compose. + rewrite Nat.ltb_lt in Ha. + apply swap_perm_bounded; try lia. + bdestruct (k =? length l). + - subst; rewrite perm_of_swap_list_WF; try easy; lia. + - transitivity (length l); [|lia]. + apply IHl; [easy | lia]. +Qed. + +Lemma invperm_of_swap_list_bounded l : swap_list_spec l = true -> + perm_bounded (length l) (invperm_of_swap_list l). +Proof. + induction l; [easy|]. + simpl. + rewrite andb_true_iff. + intros [Ha Hl]. + rewrite Nat.ltb_lt in Ha. + intros k Hk. + unfold compose. + bdestruct (swap_perm a (length l) (S (length l)) k =? length l). + - rewrite H, invperm_of_swap_list_WF; [lia|easy|easy]. + - transitivity (length l); [|lia]. + apply IHl; [easy|]. + pose proof (swap_perm_bounded a (length l) (S (length l)) Ha (ltac:(lia)) k Hk). + lia. +Qed. + +#[export] Hint Resolve perm_of_swap_list_bounded + invperm_of_swap_list_bounded : perm_bounded_db. + + +Lemma invperm_linv_perm_of_swap_list l : swap_list_spec l = true -> + invperm_of_swap_list l ∘ perm_of_swap_list l = idn. +Proof. + induction l. + - easy. + - simpl. + rewrite andb_true_iff. + intros [Ha Hl]. + rewrite Combinators.compose_assoc, + <- (Combinators.compose_assoc _ _ _ _ (perm_of_swap_list _)). + rewrite swap_perm_invol, compose_idn_l. + + apply (IHl Hl). + + bdestructΩ (a + perm_of_swap_list l ∘ invperm_of_swap_list l = idn. +Proof. + induction l. + - easy. + - simpl. + rewrite andb_true_iff. + intros [Ha Hl]. + rewrite <- Combinators.compose_assoc, + (Combinators.compose_assoc _ _ _ _ (invperm_of_swap_list _)). + rewrite (IHl Hl). + rewrite compose_idn_r. + rewrite swap_perm_invol; [easy| |lia]. + bdestructΩ (a [] + | S n' => let k := (perm_inv (S n') f n') in + k :: insertion_sort_list n' (fswap f k n') + end. *) + +Lemma length_insertion_sort_list n f : + length (insertion_sort_list n f) = n. +Proof. + revert f; + induction n; + intros f. + - easy. + - simpl. + rewrite IHn; easy. +Qed. + +Local Opaque perm_inv. +Lemma insertion_sort_list_is_swap_list n f : + swap_list_spec (insertion_sort_list n f) = true. +Proof. + revert f; + induction n; + intros f. + - easy. + - simpl. + rewrite length_insertion_sort_list, IHn. + pose proof (perm_inv_bounded_S n f n). + bdestructΩ (perm_inv (S n) f n + perm_eq n (invperm_of_swap_list (insertion_sort_list n f) + ∘ perm_of_swap_list (insertion_sort_list n f)) idn. +Proof. + cleanup_perm_inv. +Qed. + +Lemma invperm_rinv_perm_of_insertion_sort_list n f : permutation n f -> + perm_eq n (perm_of_swap_list (insertion_sort_list n f) + ∘ invperm_of_swap_list (insertion_sort_list n f)) idn. +Proof. + cleanup_perm_inv. +Qed. + +#[export] Hint Resolve invperm_linv_perm_of_insertion_sort_list + invperm_rinv_perm_of_insertion_sort_list : perm_inv_db. + + +Lemma perm_of_insertion_sort_list_is_rinv n f : permutation n f -> + perm_eq n (f ∘ perm_of_swap_list (insertion_sort_list n f)) idn. +Proof. + revert f; + induction n; + intros f. + - intros; exfalso; easy. + - intros Hperm k Hk. + simpl. + rewrite length_insertion_sort_list. + bdestruct (k =? n). + + unfold compose. + rewrite perm_of_swap_list_WF; [ | + apply insertion_sort_list_is_swap_list | + rewrite length_insertion_sort_list; lia + ]. + unfold swap_perm. + bdestructΩ (S n <=? k). + bdestructΩ (k =? n). + subst. + bdestruct (n =? perm_inv (S n) f n). + 1: rewrite H at 1. + all: cleanup_perm_inv. + + rewrite <- Combinators.compose_assoc. + rewrite <- fswap_eq_compose_swap_perm; [|apply perm_inv_bounded_S|lia]. + rewrite IHn; [easy| |lia]. + apply fswap_perm_invol_n_permutation, Hperm. +Qed. +Local Transparent perm_inv. + +#[export] Hint Resolve perm_of_insertion_sort_list_is_rinv : perm_inv_db. +#[export] Hint Rewrite perm_of_insertion_sort_list_is_rinv : perm_inv_db. + +Lemma perm_of_insertion_sort_list_WF n f : + WF_Perm n (perm_of_swap_list (insertion_sort_list n f)). +Proof. + intros k. + rewrite <- (length_insertion_sort_list n f) at 1. + revert k. + apply perm_of_swap_list_WF. + apply insertion_sort_list_is_swap_list. +Qed. + +Lemma invperm_of_insertion_sort_list_WF n f : + WF_Perm n (invperm_of_swap_list (insertion_sort_list n f)). +Proof. + intros k. + rewrite <- (length_insertion_sort_list n f) at 1. + revert k. + apply invperm_of_swap_list_WF. + apply insertion_sort_list_is_swap_list. +Qed. + +#[export] Hint Resolve perm_of_insertion_sort_list_WF + invperm_of_swap_list_WF : WF_Perm_db. + + +Lemma perm_of_insertion_sort_list_perm_eq_perm_inv n f : permutation n f -> + perm_eq n (perm_of_swap_list (insertion_sort_list n f)) (perm_inv n f). +Proof. + intros Hperm. + apply (perm_bounded_rinv_injective_of_injective n f). + - apply permutation_is_injective, Hperm. + - pose proof (perm_of_swap_list_bounded (insertion_sort_list n f) + (insertion_sort_list_is_swap_list n f)) as H. + rewrite (length_insertion_sort_list n f) in H. + exact H. + - auto with perm_bounded_db. + - apply perm_of_insertion_sort_list_is_rinv, Hperm. + - apply perm_inv_is_rinv_of_permutation, Hperm. +Qed. + +#[export] Hint Resolve + perm_of_insertion_sort_list_perm_eq_perm_inv : perm_inv_db. + +Lemma perm_of_insertion_sort_list_eq_perm_inv' n f : permutation n f -> + perm_of_swap_list (insertion_sort_list n f) = + perm_inv' n f. +Proof. + intros Hf. + eq_by_WF_perm_eq n. + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite + perm_of_insertion_sort_list_eq_perm_inv' + using auto with perm_db : perm_inv_db. + + +Lemma perm_inv_of_insertion_sort_list_perm_eq n f : permutation n f -> + perm_eq n (perm_inv n (perm_of_swap_list (insertion_sort_list n f))) f. +Proof. + intros Hf. + cleanup_perm_inv. +Qed. + +#[export] Hint Resolve perm_inv_of_insertion_sort_list_perm_eq : perm_inv_db. + +Lemma perm_inv'_of_insertion_sort_list_eq n f : + permutation n f -> WF_Perm n f -> + perm_inv' n (perm_of_swap_list (insertion_sort_list n f)) = f. +Proof. + intros. + eq_by_WF_perm_eq n. + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite perm_inv'_of_insertion_sort_list_eq + using solve [auto with perm_db WF_Perm_db] : perm_inv_db. + +#[export] Hint Extern 100 (perm_eq ?n ?f ?g) => + (apply (@perm_eq_sym n g f)) : perm_inv_db. + +Lemma perm_eq_perm_of_insertion_sort_list_of_perm_inv n f : permutation n f -> + perm_eq n f (perm_of_swap_list (insertion_sort_list n (perm_inv n f))). +Proof. + intros Hf. + cleanup_perm_inv. +Qed. + +Lemma insertion_sort_list_S n f : + insertion_sort_list (S n) f = + (perm_inv (S n) f n) :: (insertion_sort_list n (fswap f (perm_inv (S n) f n) n)). +Proof. easy. Qed. + +Lemma perm_of_swap_list_cons a l : + perm_of_swap_list (a :: l) = swap_perm a (length l) (S (length l)) ∘ perm_of_swap_list l. +Proof. easy. Qed. + +Lemma invperm_of_swap_list_cons a l : + invperm_of_swap_list (a :: l) = invperm_of_swap_list l ∘ swap_perm a (length l) (S (length l)). +Proof. easy. Qed. + +Lemma perm_of_insertion_sort_list_S n f : + perm_of_swap_list (insertion_sort_list (S n) f) = + swap_perm (perm_inv (S n) f n) n (S n) ∘ + perm_of_swap_list (insertion_sort_list n (fswap f (perm_inv (S n) f n) n)). +Proof. + rewrite insertion_sort_list_S, perm_of_swap_list_cons. + rewrite length_insertion_sort_list. + easy. +Qed. + +Lemma invperm_of_insertion_sort_list_S n f : + invperm_of_swap_list (insertion_sort_list (S n) f) = + invperm_of_swap_list (insertion_sort_list n (fswap f (perm_inv (S n) f n) n)) + ∘ swap_perm (perm_inv (S n) f n) n (S n). +Proof. + rewrite insertion_sort_list_S, invperm_of_swap_list_cons. + rewrite length_insertion_sort_list. + easy. +Qed. + +Lemma perm_of_swap_list_permutation l : swap_list_spec l = true -> + permutation (length l) (perm_of_swap_list l). +Proof. + intros Hsw. + induction l; + [ simpl; exists idn; easy |]. + simpl. + apply permutation_compose. + - apply swap_perm_permutation; [|lia]. + simpl in Hsw. + bdestruct (a + permutation (length l) (invperm_of_swap_list l). +Proof. + intros Hsw. + induction l; + [ simpl; exists idn; easy |]. + simpl. + apply permutation_compose. + - eapply permutation_of_le_permutation_WF. + 2: apply IHl. + 1: lia. + 2: apply invperm_of_swap_list_WF. + all: simpl in Hsw; + rewrite andb_true_iff in Hsw; easy. + - apply swap_perm_permutation; [|lia]. + simpl in Hsw. + bdestruct (a + perm_eq n f (invperm_of_swap_list (insertion_sort_list n f)). +Proof. + intros Hperm. + perm_eq_by_inv_inj (perm_of_swap_list (insertion_sort_list n f)) n. +Qed. + + +Lemma permutation_grow_l' n f : permutation (S n) f -> + perm_eq (S n) f (swap_perm (f n) n (S n) ∘ + perm_of_swap_list (insertion_sort_list n (fswap (perm_inv (S n) f) (f n) n))). +Proof. + intros Hperm k Hk. + rewrite (perm_eq_perm_of_insertion_sort_list_of_perm_inv _ _ Hperm) + at 1 by auto. + cbn -[perm_inv]. + rewrite length_insertion_sort_list, perm_inv_perm_inv by auto. + easy. +Qed. + +Lemma permutation_grow_r' n f : permutation (S n) f -> + perm_eq (S n) f ( + invperm_of_swap_list (insertion_sort_list n (fswap f (perm_inv (S n) f n) n)) + ∘ swap_perm (perm_inv (S n) f n) n (S n)). +Proof. + intros Hperm k Hk. + rewrite (perm_eq_invperm_of_insertion_sort_list _ _ Hperm) at 1 by auto. + cbn -[perm_inv]. + rewrite length_insertion_sort_list by auto. + easy. +Qed. + +Lemma permutation_grow_l n f : permutation (S n) f -> + exists g k, k < S n /\ perm_eq (S n) f (swap_perm k n (S n) ∘ g) /\ permutation n g. +Proof. + intros Hperm. + eexists. + exists (f n). + split; [apply permutation_is_bounded; [easy | lia] | split]. + pose proof (perm_eq_perm_of_insertion_sort_list_of_perm_inv _ _ Hperm) as H. + rewrite perm_of_insertion_sort_list_S in H. + rewrite perm_inv_perm_inv in H by (easy || lia). + exact H. + auto with perm_db. +Qed. + +Lemma permutation_grow_r n f : permutation (S n) f -> + exists g k, k < S n /\ perm_eq (S n) f (g ∘ swap_perm k n (S n)) /\ permutation n g. +Proof. + intros Hperm. + eexists. + exists (perm_inv (S n) f n). + split; [apply permutation_is_bounded; [auto with perm_db | lia] | split]. + pose proof (perm_eq_invperm_of_insertion_sort_list _ _ Hperm) as H. + rewrite invperm_of_insertion_sort_list_S in H. + exact H. + auto with perm_db. +Qed. + + + +Local Transparent perm_inv. + + +(* Section on stack_perms *) +Lemma stack_perms_left {n0 n1} {f g} {k} : + k < n0 -> stack_perms n0 n1 f g k = f k. +Proof. + intros Hk. + unfold stack_perms. + replace_bool_lia (k stack_perms n0 n1 f g k = g (k - n0) + n0. +Proof. + intros Hk. + unfold stack_perms. + replace_bool_lia (k stack_perms n0 n1 f g (k + n0) = g k + n0. +Proof. + intros Hk. + rewrite stack_perms_right; [|lia]. + replace (k + n0 - n0) with k by lia. + easy. +Qed. + +Lemma stack_perms_add_right {n0 n1} {f g} {k} : + k < n1 -> stack_perms n0 n1 f g (n0 + k) = g k + n0. +Proof. + rewrite Nat.add_comm. + exact stack_perms_right_add. +Qed. + +Lemma stack_perms_high {n0 n1} {f g} {k} : + n0 + n1 <= k -> (stack_perms n0 n1 f g) k = k. +Proof. + intros H. + unfold stack_perms. + replace_bool_lia (k if k if (¬ k f k = k) (Hg : forall k, k < n1 -> g k = k) : + stack_perms n0 n1 f g = idn. +Proof. + solve_modular_permutation_equalities. + - apply Hf; easy. + - rewrite Hg; lia. +Qed. + + +Lemma contract_perm_bounded {n f} (Hf : perm_bounded n f) a : + a < n -> + perm_bounded (n - 1) (contract_perm f a). +Proof. + intros Ha k Hk. + pose proof (Hf a Ha). + pose proof (Hf k ltac:(lia)). + pose proof (Hf (k+1) ltac:(lia)). + unfold contract_perm. + bdestructΩ'. +Qed. + +#[export] Hint Resolve contract_perm_bounded : perm_bounded_db. + +Lemma contract_perm_permutation {n f} (Hf : permutation n f) a : + a < n -> + permutation (n - 1) (contract_perm f a). +Proof. + intros Ha. + pose proof (fun x y => permutation_eq_iff x y Hf) as Hfinj. + destruct Hf as (finv & Hfinv). + pose proof (fun k Hk => proj1 (Hfinv k Hk)) as Hfbdd. + pose proof (fun k Hk => proj1 (proj2 (Hfinv k Hk))) as Hfinvbdd. + pose proof (fun k Hk => proj1 (proj2 (proj2(Hfinv k Hk)))) as Hlinv. + pose proof (fun k Hk => proj2 (proj2 (proj2(Hfinv k Hk)))) as Hrinv. + exists (contract_perm finv (f a)). + intros k Hk. + repeat split; auto with perm_bounded_db. + - unfold contract_perm. + rewrite !(if_dist _ _ _ finv). + rewrite !Hlinv by lia. + rewrite !(if_dist _ _ _ (fun x=>x+1)). + rewrite !(if_dist _ _ _ finv). + pose proof (Hfinj a k). + pose proof (Hfinj a (k + 1)). + bdestructΩ'; rewrite ?Nat.sub_add, ?Hlinv in *; lia. + - unfold contract_perm. + rewrite !(if_dist _ _ _ f). + rewrite !Hrinv, !Hlinv by lia. + rewrite !(if_dist _ _ _ (fun x=>x+1)). + rewrite !(if_dist _ _ _ f). + assert (Hfeqiff : forall a b, a < n -> b < n -> + f a = b <-> finv b = a) by + (intros; split; intros <-; now rewrite ?Hlinv, ?Hrinv by lia). + pose proof (Hfeqiff a k). + pose proof (Hfeqiff a (k+1)). + bdestructΩ'; rewrite ?Nat.sub_add, ?Hrinv in * by lia; lia. +Qed. + +#[export] Hint Resolve contract_perm_permutation : perm_db. + +Lemma contract_perm_WF n f a : WF_Perm n f -> a < n -> f a < n -> + WF_Perm (n - 1) (contract_perm f a). +Proof. + intros Hf Ha Hfa. + intros k Hk. + unfold contract_perm. + bdestruct (a =? f a); [ + replace <- (f a) in *; + bdestructΩ'; + rewrite ?Hf in * by lia; try lia| + ]. + bdestructΩ'; + rewrite ?Hf in * by lia; lia. +Qed. + +#[export] Hint Extern 0 (WF_Perm _ (contract_perm _ _)) => + apply contract_perm_WF; + [| auto using permutation_is_bounded + with perm_bounded_db..] : WF_Perm_db. + +Lemma contract_perm_inv n f (Hf : permutation n f) a : + a < n -> + forall k, k < n - 1 -> + perm_inv (n - 1) (contract_perm f a) k = + contract_perm (perm_inv n f) (f a) k. +Proof. + intros Ha k Hk. + pose proof (permutation_is_bounded _ _ Hf) as Hfbdd. + pose proof (perm_inv_bounded n f) as Hfinvbdd. + pose proof (Hfbdd a Ha). + pose proof (perm_inv_is_linv_of_permutation n f Hf) as Hlinv. + pose proof (perm_inv_is_rinv_of_permutation n f Hf) as Hrinv. + rewrite perm_inv_eq_iff; auto with perm_db perm_bounded_db. + unfold contract_perm. + rewrite !(if_dist _ _ _ f). + rewrite !Hrinv, !Hlinv by lia. + rewrite !(if_dist _ _ _ (fun x=>x+1)). + rewrite !(if_dist _ _ _ f). + assert (Hfeqiff : forall a b, a < n -> b < n -> + f a = b <-> perm_inv n f b = a) by + (intros; split; intros <-; now rewrite ?Hlinv, ?Hrinv by lia). + pose proof (Hfeqiff a k). + pose proof (Hfeqiff a (k+1)). + bdestructΩ'; rewrite ?Nat.sub_add, ?Hrinv in * by lia; lia. +Qed. + +#[export] Hint Resolve contract_perm_inv : perm_inv_db. + +Lemma contract_perm_perm_eq_of_perm_eq n f g a : + a < n -> perm_eq n f g -> + perm_eq (n - 1) (contract_perm f a) (contract_perm g a). +Proof. + intros Ha Hfg. + intros k Hk. + unfold contract_perm. + now rewrite !Hfg by lia. +Qed. + +#[export] Hint Resolve contract_perm_perm_eq_of_perm_eq : perm_inv_db. + +Lemma contract_perm_inv' {n f} (Hf : permutation n f) a : + WF_Perm n f -> + a < n -> + perm_inv' (n - 1) (contract_perm f a) = + contract_perm (perm_inv' n f) (f a). +Proof. + intros Hfwf Ha. + eq_by_WF_perm_eq (n-1). + auto with perm_inv_db. + apply (perm_eq_trans + (perm_inv'_eq _ _)). + apply (perm_eq_trans + (contract_perm_inv n f Hf a Ha)). + eauto with perm_db perm_inv_db. +Qed. + +#[export] Hint Rewrite @contract_perm_inv' + using (match goal with + | |- WF_Perm _ _ => solve [auto with WF_Perm_db perm_db perm_inv_db] + | |- _ => auto with perm_db + end) : perm_inv_db. + +(* Section on rotr / rotl *) +Lemma rotr_WF {n m} : + WF_Perm n (rotr n m). +Proof. intros k Hk. unfold rotr. bdestruct_one; lia. Qed. + +Lemma rotl_WF {n m} : + WF_Perm n (rotl n m). +Proof. intros k Hk. unfold rotl. bdestruct_one; lia. Qed. + +#[export] Hint Resolve rotr_WF rotl_WF : WF_Perm_db. + +Lemma rotr_bdd {n m} : + forall k, k < n -> (rotr n m) k < n. +Proof. + intros. unfold rotr. bdestruct_one; [lia|]. + apply Nat.mod_upper_bound; lia. +Qed. + +Lemma rotl_bdd {n m} : + forall k, k < n -> (rotl n m) k < n. +Proof. + intros. unfold rotl. bdestruct_one; [lia|]. + apply Nat.mod_upper_bound; lia. +Qed. + +#[export] Hint Resolve rotr_bdd rotl_bdd : perm_bounded_db. + +Lemma rotr_rotl_inv n m : + ((rotr n m) ∘ (rotl n m) = idn)%prg. +Proof. + apply functional_extensionality; intros k. + unfold compose, rotl, rotr. + bdestruct (n <=? k); [bdestructΩ'|]. + assert (Hn0 : n <> 0) by lia. + bdestruct_one. + - pose proof (Nat.mod_upper_bound (k + (n - m mod n)) n Hn0) as Hbad. + lia. (* contradict Hbad *) + - rewrite Nat.Div0.add_mod_idemp_l. + rewrite <- Nat.add_assoc. + replace (n - m mod n + m) with + (n - m mod n + (n * (m / n) + m mod n)) by + (rewrite <- (Nat.div_mod m n Hn0); easy). + pose proof (Nat.mod_upper_bound m n Hn0). + replace (n - m mod n + (n * (m / n) + m mod n)) with + (n * (1 + m / n)) by lia. + rewrite Nat.mul_comm, Nat.Div0.mod_add. + apply Nat.mod_small, H. +Qed. + +Lemma rotl_rotr_inv n m : + ((rotl n m) ∘ (rotr n m) = idn)%prg. +Proof. + apply functional_extensionality; intros k. + unfold compose, rotl, rotr. + bdestruct (n <=? k); [bdestructΩ'|]. + assert (Hn0 : n <> 0) by lia. + bdestruct_one. + - pose proof (Nat.mod_upper_bound (k + m) n Hn0) as Hbad. + lia. (* contradict Hbad *) + - rewrite Nat.Div0.add_mod_idemp_l. + rewrite <- Nat.add_assoc. + rewrite (Nat.div_mod_eq m n) at 1. + pose proof (Nat.mod_upper_bound m n Hn0). + replace ((n * (m / n) + m mod n) + (n - m mod n)) with + (n * (1 + m / n)) by lia. + rewrite Nat.mul_comm, Nat.Div0.mod_add. + apply Nat.mod_small, H. +Qed. + +#[export] Hint Rewrite rotr_rotl_inv rotl_rotr_inv : perm_inv_db. + +Lemma rotr_perm {n m} : permutation n (rotr n m). +Proof. + perm_by_inverse (rotl n m). +Qed. + +Lemma rotl_perm {n m} : permutation n (rotl n m). +Proof. + perm_by_inverse (rotr n m). +Qed. + +#[export] Hint Resolve rotr_perm rotl_perm : perm_db. + + +(* This is the start of the actual section *) +Lemma rotr_0_r n : rotr n 0 = idn. +Proof. + apply functional_extensionality; intros k. + unfold rotr. + bdestructΩ'. + rewrite Nat.mod_small; lia. +Qed. + +Lemma rotl_0_r n : rotl n 0 = idn. +Proof. + apply functional_extensionality; intros k. + unfold rotl. + bdestructΩ'. + rewrite Nat.Div0.mod_0_l, Nat.sub_0_r. + replace (k + n) with (k + 1 * n) by lia. + rewrite Nat.Div0.mod_add, Nat.mod_small; lia. +Qed. + +Lemma rotr_0_l k : rotr 0 k = idn. +Proof. + apply functional_extensionality; intros a. + unfold rotr. + bdestructΩ'. +Qed. + +Lemma rotl_0_l k : rotl 0 k = idn. +Proof. + apply functional_extensionality; intros a. + unfold rotl. + bdestructΩ'. +Qed. + +#[export] Hint Rewrite rotr_0_r rotl_0_r rotr_0_l rotl_0_l : perm_cleanup_db. + +Lemma rotr_rotr n k l : + ((rotr n k) ∘ (rotr n l) = rotr n (k + l))%prg. +Proof. + apply functional_extensionality; intros a. + unfold compose, rotr. + symmetry. + bdestructΩ'. + - pose proof (Nat.mod_upper_bound (a + l) n); lia. + - rewrite Nat.Div0.add_mod_idemp_l. + f_equal; lia. +Qed. + +Lemma rotl_rotl n k l : + ((rotl n k) ∘ (rotl n l) = rotl n (k + l))%prg. +Proof. + + permutation_eq_by_WF_inv_inj (rotr n (k + l)) n. + rewrite Nat.add_comm, <- rotr_rotr, <- compose_assoc, + (compose_assoc _ _ _ _ (rotr n l)). + cleanup_perm. +Qed. + +#[export] Hint Rewrite rotr_rotr rotl_rotl : perm_cleanup_db. + +Lemma rotr_n n : rotr n n = idn. +Proof. + apply functional_extensionality; intros a. + unfold rotr. + bdestructΩ'. + replace (a + n) with (a + 1 * n) by lia. + destruct n; [lia|]. + rewrite Nat.Div0.mod_add. + rewrite Nat.mod_small; easy. +Qed. + +#[export] Hint Rewrite rotr_n : perm_cleanup_db. + +Lemma rotr_eq_rotr_mod n k : rotr n k = rotr n (k mod n). +Proof. + strong induction k. + bdestruct (k 0) by easy. + pose proof (Nat.mod_upper_bound k _ H'). + rewrite <- (rotl_n (S n)). + f_equal. + lia. +Qed. + +Lemma rotl_eq_rotr_sub n k : + rotl n k = rotr n (n - k mod n). +Proof. + permutation_eq_by_WF_inv_inj (rotr n k) n. + destruct n; [cbn; rewrite 2!rotr_0_l, compose_idn_l; easy|]. + rewrite (rotr_eq_rotr_mod _ k), rotr_rotr, <- (rotr_n (S n)). + f_equal. + assert (H' : S n <> 0) by easy. + pose proof (Nat.mod_upper_bound k (S n) H'). + lia. +Qed. + + +Lemma reflect_perm_invol n k : + reflect_perm n (reflect_perm n k) = k. +Proof. + unfold reflect_perm; bdestructΩ'. +Qed. + +Lemma reflect_perm_invol_eq n : + reflect_perm n ∘ reflect_perm n = idn. +Proof. + apply functional_extensionality, reflect_perm_invol. +Qed. + +#[export] Hint Rewrite reflect_perm_invol reflect_perm_invol_eq : perm_inv_db. + +Lemma reflect_perm_bounded n : perm_bounded n (reflect_perm n). +Proof. + intros k Hk. + unfold reflect_perm; bdestructΩ'. +Qed. + +#[export] Hint Resolve reflect_perm_bounded : perm_bounded_db. + +Lemma reflect_perm_permutation n : + permutation n (reflect_perm n). +Proof. + perm_by_inverse (reflect_perm n). +Qed. + +#[export] Hint Resolve reflect_perm_permutation : perm_db. + +Lemma reflect_perm_WF n : WF_Perm n (reflect_perm n). +Proof. + intros k Hk; unfold reflect_perm; bdestructΩ'. +Qed. + +#[export] Hint Resolve reflect_perm_WF : WF_Perm_db. + +Lemma reflect_perm_inv n : + perm_eq n (perm_inv n (reflect_perm n)) (reflect_perm n). +Proof. + perm_eq_by_inv_inj (reflect_perm n) n. +Qed. + +#[export] Hint Resolve reflect_perm_inv : perm_inv_db. +#[export] Hint Rewrite reflect_perm_inv : perm_inv_db. + +Lemma reflect_perm_inv' n : + perm_inv' n (reflect_perm n) = reflect_perm n. +Proof. + eq_by_WF_perm_eq n. + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite reflect_perm_inv : perm_inv_db. + + + +Lemma swap_block_perm_sub padl padm m a k : + m <= k -> + swap_block_perm padl padm a (k - m) = + swap_block_perm (m + padl) padm a k - m. +Proof. + intros Hk. + unfold swap_block_perm. + bdestructΩ'. +Qed. + +Lemma swap_block_perm_invol padl padm a k : + swap_block_perm padl padm a (swap_block_perm padl padm a k) = k. +Proof. + unfold swap_block_perm. + bdestructΩ'. +Qed. + +Lemma swap_block_perm_invol_eq padl padm a : + swap_block_perm padl padm a ∘ swap_block_perm padl padm a = idn. +Proof. + apply functional_extensionality, swap_block_perm_invol. +Qed. + +#[export] Hint Rewrite swap_block_perm_invol + swap_block_perm_invol_eq : perm_inv_db. + +Lemma swap_block_perm_bounded padl padm padr a : + perm_bounded (padl + a + padm + a + padr) (swap_block_perm padl padm a). +Proof. + intros k Hk. + unfold swap_block_perm. + bdestructΩ'. +Qed. + +Lemma swap_block_perm_bounded_alt padl padm padr a : + perm_bounded (padr + a + padm + a + padl) (swap_block_perm padl padm a). +Proof. + replace (padr + a + padm + a + padl) + with (padl + a + padm + a + padr) by lia. + apply swap_block_perm_bounded. +Qed. + +#[export] Hint Resolve swap_block_perm_bounded + swap_block_perm_bounded_alt : perm_bounded_db. + +Lemma swap_block_perm_permutation padl padm padr a : + permutation (padl + a + padm + a + padr) (swap_block_perm padl padm a). +Proof. + perm_by_inverse (swap_block_perm padl padm a). +Qed. + +Lemma swap_block_perm_permutation_alt padl padm padr a : + permutation (padr + a + padm + a + padl) (swap_block_perm padl padm a). +Proof. + perm_by_inverse (swap_block_perm padl padm a). +Qed. + +#[export] Hint Resolve swap_block_perm_permutation + swap_block_perm_permutation_alt : perm_db. + +Lemma swap_block_perm_WF padl padm padr a : + WF_Perm (padl + a + padm + a + padr) (swap_block_perm padl padm a). +Proof. + unfold swap_block_perm. + intros k Hk; bdestructΩ'. +Qed. + +Lemma swap_block_perm_WF_alt padl padm padr a : + WF_Perm (padl + a + padm + a + padr) (swap_block_perm padr padm a). +Proof. + unfold swap_block_perm. + intros k Hk; bdestructΩ'. +Qed. + +#[export] Hint Resolve swap_block_perm_WF + swap_block_perm_WF_alt : WF_Perm_db. + +Lemma swap_block_perm_inv padl padm padr a : + perm_eq (padl + a + padm + a + padr) + (perm_inv (padl + a + padm + a + padr) + (swap_block_perm padl padm a)) + (swap_block_perm padl padm a). +Proof. + perm_eq_by_inv_inj (swap_block_perm padl padm a) + (padl + a + padm + a + padr). +Qed. + +Lemma swap_block_perm_inv_alt padl padm padr a : + perm_eq (padl + a + padm + a + padr) + (perm_inv (padl + a + padm + a + padr) + (swap_block_perm padr padm a)) + (swap_block_perm padr padm a). +Proof. + perm_eq_by_inv_inj (swap_block_perm padr padm a) + (padl + a + padm + a + padr). +Qed. + +#[export] Hint Resolve swap_block_perm_inv + swap_block_perm_inv_alt : perm_inv_db. + +Lemma swap_block_perm_inv' padl padm padr a : + perm_inv' (padl + a + padm + a + padr) + (swap_block_perm padl padm a) = + swap_block_perm padl padm a. +Proof. + eq_by_WF_perm_eq (padl + a + padm + a + padr). + cleanup_perm_inv. +Qed. + +Lemma swap_block_perm_inv'_alt padl padm padr a : + perm_inv' (padl + a + padm + a + padr) + (swap_block_perm padr padm a) = + swap_block_perm padr padm a. +Proof. + eq_by_WF_perm_eq (padl + a + padm + a + padr). + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite swap_block_perm_inv' + swap_block_perm_inv'_alt : perm_inv_db. + + +Lemma rotr_decomp n m : + rotr n m = + fun k => + if n <=? k then k else + if k + m mod n nat) + (Heq : perm_eq n f g) : + perm_eq (2^n) + (qubit_perm_to_nat_perm n f) + (qubit_perm_to_nat_perm n g). +Proof. + intros k Hk. + unfold qubit_perm_to_nat_perm. + apply funbool_to_nat_eq. + intros x Hx. + unfold compose. + rewrite Heq; easy. +Qed. + +#[export] Hint Resolve qubit_perm_to_nat_perm_perm_eq : perm_inv_db. + +Lemma qubit_perm_to_nat_perm_idn n : + perm_eq (2^n) (qubit_perm_to_nat_perm n idn) idn. +Proof. + intros k Hk. + unfold qubit_perm_to_nat_perm. + rewrite compose_idn_r. + now apply nat_to_funbool_inverse. +Qed. + +#[export] Hint Resolve qubit_perm_to_nat_perm_idn : perm_inv_db. + +Lemma qubit_perm_to_nat_perm_id n f + (Hf : perm_eq n f idn) : + perm_eq (2^n) (qubit_perm_to_nat_perm n f) idn. +Proof. + eapply (fun H => perm_eq_trans H + (qubit_perm_to_nat_perm_idn n)). + auto with perm_inv_db. +Qed. + +#[export] Hint Resolve qubit_perm_to_nat_perm_id : perm_inv_db. + +Lemma qubit_perm_to_nat_perm_inv n f (Hf : permutation n f) : + perm_eq (2^n) + (perm_inv (2^n) (qubit_perm_to_nat_perm n f)) + (qubit_perm_to_nat_perm n (perm_inv n f)). +Proof. + perm_eq_by_inv_inj (qubit_perm_to_nat_perm n f) (2^n). +Qed. + +#[export] Hint Resolve qubit_perm_to_nat_perm_inv : perm_inv_db. \ No newline at end of file diff --git a/src/Permutations/PermutationInstances.v b/src/Permutations/PermutationInstances.v new file mode 100644 index 0000000..46285d7 --- /dev/null +++ b/src/Permutations/PermutationInstances.v @@ -0,0 +1,902 @@ +Require Import PermutationAuxiliary. +Require Export PermutationFacts. +Require Import PermutationAutomation. + + +Local Open Scope nat. +Local Open Scope prg. + + + + + +(* Section for swap_2_perm *) +Lemma swap_2_perm_invol : + swap_2_perm ∘ swap_2_perm = idn. +Proof. + apply functional_extensionality; intros k. + repeat first [easy | destruct k]. +Qed. + +#[export] Hint Rewrite swap_2_perm_invol : perm_inv_db. + +Lemma swap_2_perm_bounded k : + k < 2 -> swap_2_perm k < 2. +Proof. + intros Hk. + repeat first [easy | destruct k | cbn; lia]. +Qed. + +#[export] Hint Resolve swap_2_perm_bounded : perm_bounded_db. + +Lemma swap_2_WF k : 1 < k -> swap_2_perm k = k. +Proof. + intros. + repeat first [easy | lia | destruct k]. +Qed. + +Lemma swap_2_WF_Perm : WF_Perm 2 swap_2_perm. +Proof. + intros k. + repeat first [easy | lia | destruct k]. +Qed. + +Global Hint Resolve swap_2_WF_Perm : WF_Perm_db. + +Lemma swap_2_perm_permutation : permutation 2 swap_2_perm. +Proof. + perm_by_inverse swap_2_perm. +Qed. + +Global Hint Resolve swap_2_perm_permutation : perm_db. + +Lemma swap_2_perm_inv : + perm_eq 2 + (perm_inv 2 swap_2_perm) swap_2_perm. +Proof. + perm_eq_by_inv_inj swap_2_perm 2. +Qed. + +Lemma swap_2_perm_inv' : + perm_inv' 2 swap_2_perm = swap_2_perm. +Proof. + permutation_eq_by_WF_inv_inj swap_2_perm 2. +Qed. + +#[export] Hint Resolve swap_2_perm_inv : perm_inv_db. +#[export] Hint Rewrite swap_2_perm_inv' : perm_inv_db. + + + + + + + +(* Section for stack_perms *) +Lemma stack_perms_WF_idn n0 n1 f + (H : WF_Perm n0 f) : + stack_perms n0 n1 f idn = f. +Proof. + solve_modular_permutation_equalities; + rewrite H; lia. +Qed. + +#[export] Hint Rewrite stack_perms_WF_idn + using (solve [auto with WF_Perm_db]) : perm_inv_db. + +Lemma stack_perms_WF n0 n1 f g : + WF_Perm (n0 + n1) (stack_perms n0 n1 f g). +Proof. + intros k Hk. + unfold stack_perms. + bdestructΩ'. +Qed. + +Global Hint Resolve stack_perms_WF : WF_Perm_db. + +Lemma stack_perms_bounded {n0 n1} {f g} : + perm_bounded n0 f -> perm_bounded n1 g -> + perm_bounded (n0 + n1) (stack_perms n0 n1 f g). +Proof. + intros Hf Hg. + intros k Hk. + unfold stack_perms. + bdestruct (k (f k < n0 /\ finv k < n0 /\ finv (f k) = k /\ f (finv k) = k)) + (Hg: forall k, k < n1 -> (g k < n1 /\ ginv k < n1 /\ ginv (g k) = k /\ g (ginv k) = k)) : + stack_perms n0 n1 f g ∘ stack_perms n0 n1 finv ginv = idn. +Proof. + unfold compose. + solve_modular_permutation_equalities. + 1-3: specialize (Hf _ H); lia. + - replace (ginv (k - n0) + n0 - n0) with (ginv (k - n0)) by lia. + assert (Hkn0: k - n0 < n1) by lia. + specialize (Hg _ Hkn0). + lia. + - assert (Hkn0: k - n0 < n1) by lia. + specialize (Hg _ Hkn0). + lia. +Qed. + +Lemma stack_perms_linv {n0 n1} {f g} {finv ginv} + (Hf: forall k, k < n0 -> (f k < n0 /\ finv k < n0 /\ finv (f k) = k /\ f (finv k) = k)) + (Hg: forall k, k < n1 -> (g k < n1 /\ ginv k < n1 /\ ginv (g k) = k /\ g (ginv k) = k)) : + stack_perms n0 n1 finv ginv ∘ stack_perms n0 n1 f g = idn. +Proof. + rewrite stack_perms_rinv. + 2,3: rewrite is_inv_iff_inv_is. + all: easy. +Qed. + +Lemma stack_perms_perm_eq_inv_of_perm_eq_inv {n0 n1} {f g} {finv ginv} + (Hf : perm_eq n0 (f ∘ finv) idn) + (Hg : perm_eq n1 (g ∘ ginv) idn) + (Hfinv : perm_bounded n0 finv) + (Hginv : perm_bounded n1 ginv) : + perm_eq (n0 + n1) + (stack_perms n0 n1 f g ∘ stack_perms n0 n1 finv ginv) + idn. +Proof. + unfold compose in *. + intros k Hk. + unfold stack_perms. + specialize (Hfinv k). + specialize (Hginv (k - n0)). + bdestructΩ'; auto. + rewrite Nat.add_sub. + rewrite Hg; lia. +Qed. + +#[export] Hint Resolve stack_perms_perm_eq_inv_of_perm_eq_inv : perm_inv_db. + +Lemma stack_perms_inv_of_perm_eq_inv {n0 n1} {f g} {finv ginv} + (Hf : perm_eq n0 (f ∘ finv) idn) + (Hg : perm_eq n1 (g ∘ ginv) idn) + (Hfinv : perm_bounded n0 finv) + (Hginv : perm_bounded n1 ginv) : + stack_perms n0 n1 f g ∘ stack_perms n0 n1 finv ginv = idn. +Proof. + eq_by_WF_perm_eq (n0 + n1). + auto with perm_inv_db. +Qed. + +#[export] Hint Resolve stack_perms_inv_of_perm_eq_inv : perm_inv_db. + +#[export] Hint Resolve permutation_is_bounded : perm_bounded_db. + +Lemma stack_perms_permutation {n0 n1 f g} (Hf : permutation n0 f) (Hg: permutation n1 g) : + permutation (n0 + n1) (stack_perms n0 n1 f g). +Proof. + perm_by_inverse (stack_perms n0 n1 (perm_inv n0 f) (perm_inv n1 g)). +Qed. + +#[export] Hint Resolve stack_perms_permutation : perm_db. + +Lemma perm_inv_stack_perms n m f g + (Hf : permutation n f) (Hg : permutation m g) : + perm_eq (n + m) + (perm_inv (n + m) (stack_perms n m f g)) + (stack_perms n m (perm_inv n f) (perm_inv m g)). +Proof. + perm_eq_by_inv_inj (stack_perms n m f g) (n+m). +Qed. + +#[export] Hint Resolve stack_perms_idn_of_left_right_idn + stack_perms_compose : perm_inv_db. +#[export] Hint Rewrite @stack_perms_compose + using auto with perm_db : perm_inv_db. + + + +Lemma stack_perms_proper {n0 n1} {f f' g g'} + (Hf : perm_eq n0 f f') (Hg : perm_eq n1 g g') : + perm_eq (n0 + n1) + (stack_perms n0 n1 f g) + (stack_perms n0 n1 f' g'). +Proof. + intros k Hk. + unfold stack_perms. + bdestructΩ'; [apply Hf | f_equal; apply Hg]; lia. +Qed. + +#[export] Hint Resolve stack_perms_proper : perm_inv_db. + +Lemma stack_perms_proper_eq {n0 n1} {f f' g g'} + (Hf : perm_eq n0 f f') (Hg : perm_eq n1 g g') : + stack_perms n0 n1 f g = + stack_perms n0 n1 f' g'. +Proof. + eq_by_WF_perm_eq (n0 + n1); cleanup_perm_inv. +Qed. + +#[export] Hint Resolve stack_perms_proper_eq : perm_inv_db. + +Lemma perm_inv'_stack_perms n m f g + (Hf : permutation n f) (Hg : permutation m g) : + perm_inv' (n + m) (stack_perms n m f g) = + stack_perms n m (perm_inv' n f) (perm_inv' m g). +Proof. + permutation_eq_by_WF_inv_inj (stack_perms n m f g) (n+m). +Qed. + +#[export] Hint Rewrite @perm_inv'_stack_perms + using auto with perm_db : perm_inv_db. + +Lemma rotr_inv n m : + perm_eq n (perm_inv n (rotr n m)) (rotl n m). +Proof. + perm_eq_by_inv_inj (rotr n m) n. +Qed. + +Lemma rotr_inv' n m : + perm_inv' n (rotr n m) = rotl n m. +Proof. + permutation_eq_by_WF_inv_inj (rotr n m) n. +Qed. + +Lemma rotl_inv n m : + perm_eq n (perm_inv n (rotl n m)) (rotr n m). +Proof. + perm_eq_by_inv_inj (rotl n m) n. +Qed. + +Lemma rotl_inv' n m : + perm_inv' n (rotl n m) = rotr n m. +Proof. + permutation_eq_by_WF_inv_inj (rotl n m) n. +Qed. + +#[export] Hint Resolve rotr_inv rotl_inv : perm_inv_db. +#[export] Hint Rewrite rotr_inv rotr_inv' rotl_inv rotl_inv' : perm_inv_db. + + + + + + + + + +(* Section on top_to_bottom and bottom_to_top *) +Lemma bottom_to_top_perm_bounded {n} k : + k < n -> bottom_to_top_perm n k < n. +Proof. + intros Hk. + unfold bottom_to_top_perm. + replace_bool_lia (n <=? k) false. + destruct k; lia. +Qed. + +Lemma top_to_bottom_perm_bounded {n} k : + k < n -> top_to_bottom_perm n k < n. +Proof. + intros Hk. + unfold top_to_bottom_perm. + replace_bool_lia (n <=? k) false. + bdestruct (k =? n - 1); lia. +Qed. + +Global Hint Resolve bottom_to_top_perm_bounded top_to_bottom_perm_bounded : perm_bounded_db. + +Lemma bottom_to_top_WF_perm n : + WF_Perm n (bottom_to_top_perm n). +Proof. + intros k Hk. + unfold bottom_to_top_perm. + replace_bool_lia (n <=? k) true. + easy. +Qed. + +Lemma top_to_bottom_WF_perm n : + WF_Perm n (top_to_bottom_perm n). +Proof. + intros k Hk. + unfold top_to_bottom_perm. + replace_bool_lia (n <=? k) true. + easy. +Qed. + +Global Hint Resolve bottom_to_top_WF_perm top_to_bottom_WF_perm : WF_Perm_db. + +Lemma bottom_to_top_to_bottom_inv n : + bottom_to_top_perm n ∘ top_to_bottom_perm n = idn. +Proof. + apply functional_extensionality; intros k. + unfold compose, bottom_to_top_perm, top_to_bottom_perm. + bdestruct (n <=? k). + 1: replace_bool_lia (n <=? k) true; easy. + bdestruct (k =? n - 1). + - destruct n. + + easy. + + replace_bool_lia (S n <=? 0) false. + lia. + - replace_bool_lia (n <=? k + 1) false. + replace (k + 1) with (S k) by lia. + easy. +Qed. + +Lemma top_to_bottom_to_top_inv n : + top_to_bottom_perm n ∘ bottom_to_top_perm n = idn. +Proof. + apply functional_extensionality; intros k. + unfold compose, bottom_to_top_perm, top_to_bottom_perm. + bdestruct (n <=? k). + 1: replace_bool_lia (n <=? k) true; easy. + destruct k. + - destruct n; [easy|]. + replace_bool_lia (S n <=? S n - 1) false. + rewrite Nat.eqb_refl. + easy. + - replace_bool_lia (n <=? k) false. + replace_bool_lia (k =? n - 1) false. + lia. +Qed. + +Lemma bottom_to_top_to_bottom_inv' n k : + bottom_to_top_perm n (top_to_bottom_perm n k) = k. +Proof. + pose proof (bottom_to_top_to_bottom_inv n) as H. + apply (f_equal (fun g => g k)) in H. + unfold compose in H. + easy. +Qed. + +Lemma top_to_bottom_to_top_inv' n k : + top_to_bottom_perm n (bottom_to_top_perm n k) = k. +Proof. + pose proof (top_to_bottom_to_top_inv n) as H. + apply (f_equal (fun g => g k)) in H. + unfold compose in H. + easy. +Qed. + +#[export] Hint Rewrite + bottom_to_top_to_bottom_inv + bottom_to_top_to_bottom_inv' + top_to_bottom_to_top_inv + top_to_bottom_to_top_inv' + : perm_inv_db. + +Lemma top_to_bottom_permutation n : + permutation n (top_to_bottom_perm n). +Proof. + perm_by_inverse (bottom_to_top_perm n). +Qed. + +Lemma bottom_to_top_permutation n : + permutation n (bottom_to_top_perm n). +Proof. + perm_by_inverse (top_to_bottom_perm n). +Qed. + +Global Hint Resolve top_to_bottom_permutation bottom_to_top_permutation : perm_db. + +Lemma top_to_bottom_inv n : + perm_eq n (perm_inv n (top_to_bottom_perm n)) (bottom_to_top_perm n). +Proof. + perm_eq_by_inv_inj (top_to_bottom_perm n) n. +Qed. + +Lemma bottom_to_top_inv n : + perm_eq n (perm_inv n (bottom_to_top_perm n)) (top_to_bottom_perm n). +Proof. + perm_eq_by_inv_inj (bottom_to_top_perm n) n. +Qed. + +Lemma top_to_bottom_inv' n : + perm_inv' n (top_to_bottom_perm n) = bottom_to_top_perm n. +Proof. + permutation_eq_by_WF_inv_inj (top_to_bottom_perm n) n. +Qed. + +Lemma bottom_to_top_inv' n : + perm_inv' n (bottom_to_top_perm n) = top_to_bottom_perm n. +Proof. + permutation_eq_by_WF_inv_inj (bottom_to_top_perm n) n. +Qed. + +#[export] Hint Rewrite top_to_bottom_inv top_to_bottom_inv' + bottom_to_top_inv bottom_to_top_inv' : perm_inv_db. + +Lemma top_to_bottom_perm_eq_rotr n : + top_to_bottom_perm n = rotr n 1. +Proof. + apply functional_extensionality; intros k. + unfold top_to_bottom_perm, rotr. + bdestructΩ'. + - subst. + replace (n - 1 + 1) with n by lia. + rewrite Nat.Div0.mod_same; lia. + - rewrite Nat.mod_small; lia. +Qed. + +#[export] Hint Rewrite top_to_bottom_perm_eq_rotr : perm_cleanup_db. + +Lemma bottom_to_top_perm_eq_rotl n : + bottom_to_top_perm n = rotl n 1. +Proof. + permutation_eq_by_WF_inv_inj (top_to_bottom_perm n) n. +Qed. + +#[export] Hint Rewrite bottom_to_top_perm_eq_rotl : perm_cleanup_db. + + + + +Definition kron_comm_perm p q := + fun k => if p * q <=? k then k else + k mod p * q + k / p. + +Lemma kron_comm_perm_WF p q : + WF_Perm (p * q) (kron_comm_perm p q). +Proof. + intros k Hk; unfold kron_comm_perm; bdestructΩ'. +Qed. + +Lemma kron_comm_perm_WF_alt p q : + WF_Perm (q * p) (kron_comm_perm p q). +Proof. + rewrite Nat.mul_comm; apply kron_comm_perm_WF. +Qed. + +#[export] Hint Resolve kron_comm_perm_WF kron_comm_perm_WF_alt : WF_Perm_db. + +Lemma kron_comm_perm_bounded p q : + perm_bounded (p * q) (kron_comm_perm p q). +Proof. + intros k Hk. + unfold kron_comm_perm. + bdestructΩ'. + show_moddy_lt. +Qed. + +Lemma kron_comm_perm_bounded_alt p q : + perm_bounded (q * p) (kron_comm_perm p q). +Proof. + rewrite Nat.mul_comm. + apply kron_comm_perm_bounded. +Qed. + +#[export] Hint Resolve kron_comm_perm_bounded + kron_comm_perm_bounded_alt : perm_bounded_db. + +Lemma kron_comm_perm_pseudo_invol_perm_eq p q : + perm_eq (p * q) (kron_comm_perm p q ∘ kron_comm_perm q p)%prg idn. +Proof. + intros k Hk. + unfold compose, kron_comm_perm. + simplify_bools_lia_one_kernel. + simplify_bools_moddy_lia_one_kernel. + rewrite (Nat.add_comm _ (k/q)). + rewrite Nat.Div0.mod_add, Nat.div_add by show_nonzero. + rewrite Nat.Div0.div_div, Nat.mod_small by show_moddy_lt. + rewrite (Nat.div_small k (q*p)) by lia. + symmetry. + rewrite (Nat.div_mod_eq k q) at 1; lia. +Qed. + +#[export] Hint Resolve kron_comm_perm_pseudo_invol_perm_eq : perm_inv_db. + +Lemma kron_comm_perm_pseudo_invol_alt_perm_eq p q : + perm_eq (q * p) (kron_comm_perm p q ∘ kron_comm_perm q p)%prg idn. +Proof. + rewrite Nat.mul_comm; cleanup_perm_inv. +Qed. + +#[export] Hint Resolve kron_comm_perm_pseudo_invol_alt_perm_eq : perm_inv_db. + +Lemma kron_comm_perm_pseudo_invol p q : + kron_comm_perm p q ∘ kron_comm_perm q p = idn. +Proof. + eq_by_WF_perm_eq (p*q); cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite kron_comm_perm_pseudo_invol : perm_inv_db. + +Lemma kron_comm_perm_permutation p q : + permutation (p * q) (kron_comm_perm p q). +Proof. + perm_by_inverse (kron_comm_perm q p). +Qed. + +Lemma kron_comm_perm_permutation_alt p q : + permutation (q * p) (kron_comm_perm p q). +Proof. + perm_by_inverse (kron_comm_perm q p). +Qed. + +#[export] Hint Resolve kron_comm_perm_permutation + kron_comm_perm_permutation_alt : perm_db. + +Lemma kron_comm_perm_inv p q : + perm_eq (p * q) + (perm_inv (p * q) (kron_comm_perm p q)) + (kron_comm_perm q p). +Proof. + perm_eq_by_inv_inj (kron_comm_perm p q) (p * q). +Qed. + +Lemma kron_comm_perm_inv_alt p q : + perm_eq (q * p) + (perm_inv (p * q) (kron_comm_perm p q)) + (kron_comm_perm q p). +Proof. + perm_eq_by_inv_inj (kron_comm_perm p q) (q * p). +Qed. + +Lemma kron_comm_perm_swap_inv p q : + perm_eq (p * q) + (perm_inv (p * q) (kron_comm_perm q p)) + (kron_comm_perm p q). +Proof. + perm_eq_by_inv_inj (kron_comm_perm q p) (p * q). +Qed. + +Lemma kron_comm_perm_swap_inv_alt p q : + perm_eq (q * p) + (perm_inv (p * q) (kron_comm_perm q p)) + (kron_comm_perm p q). +Proof. + perm_eq_by_inv_inj (kron_comm_perm q p) (q * p). +Qed. + +#[export] Hint Resolve kron_comm_perm_inv + kron_comm_perm_inv_alt + kron_comm_perm_swap_inv + kron_comm_perm_swap_inv_alt : perm_inv_db. + +Lemma kron_comm_perm_inv' p q : + perm_inv' (p * q) (kron_comm_perm p q) = + kron_comm_perm q p. +Proof. + eq_by_WF_perm_eq (p * q). + cleanup_perm_inv. +Qed. + +Lemma kron_comm_perm_inv'_alt p q : + perm_inv' (q * p) (kron_comm_perm p q) = + kron_comm_perm q p. +Proof. + eq_by_WF_perm_eq (q * p). + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite kron_comm_perm_inv' + kron_comm_perm_inv'_alt : perm_inv_db. + +#[export] Hint Resolve compose_WF_Perm : WF_Perm_db. + +Lemma swap_block_perm_decomp_eq padl padr padm a : + swap_block_perm padl padm a = + stack_perms padl (a + padm + a + padr) idn + (stack_perms (a + padm + a) padr + ((stack_perms (a + padm) a (rotr (a + padm) a) idn) ∘ + rotr (a + padm + a) (a + padm)) idn). +Proof. + rewrite 2!stack_perms_WF_idn by + eauto using monotonic_WF_Perm with WF_Perm_db zarith. + rewrite 2!rotr_decomp. + pose proof (Nat.mod_small (a + padm) (a + padm + a)) as Hsm. + pose proof (Nat.mod_small (a) (a + padm)) as Hsm'. + pose proof (Nat.mod_upper_bound (a + padm) (a + padm + a)) as Hl. + pose proof (Nat.mod_upper_bound (a) (a + padm)) as Hl'. + assert (Hpadm0: padm = 0 -> a mod (a + padm) = 0) by + (intros ->; rewrite Nat.add_0_r, Nat.Div0.mod_same; easy). + rewrite stack_perms_idn_f. + unfold swap_block_perm. + apply functional_extensionality; intros k. + unfold compose. + bdestruct (a =? 0); + [subst; + rewrite ?Nat.add_0_r, ?Nat.add_0_l, ?Nat.Div0.mod_same in *; + bdestructΩ'|]. + rewrite Hsm in * by lia. + bdestruct (padm =? 0); + [subst; + rewrite ?Nat.add_0_r, ?Nat.add_0_l, ?Nat.Div0.mod_same in *; + bdestructΩ'|]. + rewrite Hsm' in * by lia. + bdestructΩ'. +Qed. + + + +Lemma tensor_perms_bounded n0 n1 f g : + perm_bounded n0 f -> perm_bounded n1 g -> + perm_bounded (n0 * n1) (tensor_perms n0 n1 f g). +Proof. + intros Hf Hg k Hk. + unfold tensor_perms. + simplify_bools_lia_one_kernel. + pose proof (Hf (k / n1) ltac:(show_moddy_lt)). + pose proof (Hg (k mod n1) ltac:(show_moddy_lt)). + show_moddy_lt. +Qed. + +#[export] Hint Resolve tensor_perms_bounded : perm_bounded_db. + +Lemma tensor_perms_WF n0 n1 f g : + WF_Perm (n0 * n1) (tensor_perms n0 n1 f g). +Proof. + intros k Hk. + unfold tensor_perms. + bdestructΩ'. +Qed. + +#[export] Hint Resolve tensor_perms_WF : WF_Perm_db. +#[export] Hint Extern 100 (WF_Perm ?n01 (tensor_perms ?n0 ?n1 ?f ?g)) => + replace n01 with (n0 * n1) by nia : WF_Perm_db. + +Lemma tensor_perms_compose n0 n1 f0 f1 g0 g1 : + perm_bounded n0 f1 -> perm_bounded n1 g1 -> + tensor_perms n0 n1 f0 g0 ∘ tensor_perms n0 n1 f1 g1 = + tensor_perms n0 n1 (f0 ∘ f1) (g0 ∘ g1). +Proof. + intros Hf1 Hg1. + eq_by_WF_perm_eq (n0*n1). + intros k Hk. + unfold compose. + generalize (tensor_perms_bounded n0 n1 f1 g1 Hf1 Hg1 k Hk). + unfold tensor_perms. + simplify_bools_lia_one_kernel. + intros ?. + simplify_bools_lia_one_kernel. + rewrite Nat.div_add_l by lia. + pose proof (Hf1 (k / n1) ltac:(show_moddy_lt)). + pose proof (Hg1 (k mod n1) ltac:(show_moddy_lt)). + rewrite (Nat.div_small (g1 _)), mod_add_l, Nat.mod_small by easy. + now rewrite Nat.add_0_r. +Qed. + +#[export] Hint Rewrite tensor_perms_compose : perm_cleanup_db perm_inv_db. + +Lemma tensor_perms_0_l n1 f g : + tensor_perms 0 n1 f g = idn. +Proof. + eq_by_WF_perm_eq (0 * n1). +Qed. + +Lemma tensor_perms_0_r n0 f g : + tensor_perms n0 0 f g = idn. +Proof. + eq_by_WF_perm_eq (n0 * 0). + lia. +Qed. + +#[export] Hint Rewrite tensor_perms_0_l + tensor_perms_0_r : perm_cleanup_db perm_inv_db. + +Lemma tensor_perms_perm_eq_proper n0 n1 f f' g g' : + perm_eq n0 f f' -> perm_eq n1 g g' -> + tensor_perms n0 n1 f g = tensor_perms n0 n1 f' g'. +Proof. + intros Hf' Hg'. + eq_by_WF_perm_eq (n0 * n1). + intros k Hk. + unfold tensor_perms. + simplify_bools_lia_one_kernel. + now rewrite Hf', Hg' by show_moddy_lt. +Qed. + +#[export] Hint Resolve tensor_perms_perm_eq_proper : perm_inv_db. + +Lemma tensor_perms_idn_idn n0 n1 : + tensor_perms n0 n1 idn idn = idn. +Proof. + eq_by_WF_perm_eq (n0 * n1). + unfold tensor_perms. + intros k Hk. + simplify_bools_lia_one_kernel. + pose proof (Nat.div_mod_eq k n1). + lia. +Qed. + +#[export] Hint Rewrite tensor_perms_idn_idn : perm_cleanup_db. + +Lemma tensor_perms_idn_idn' n0 n1 f g : + perm_eq n0 f idn -> perm_eq n1 g idn -> + tensor_perms n0 n1 f g = idn. +Proof. + intros Hf Hg. + rewrite <- (tensor_perms_idn_idn n0 n1). + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite tensor_perms_idn_idn' + using (solve [cleanup_perm_inv]) : perm_inv_db. + +Lemma tensor_perms_permutation n0 n1 f g + (Hf : permutation n0 f) (Hg : permutation n1 g) : + permutation (n0 * n1) (tensor_perms n0 n1 f g). +Proof. + perm_by_inverse (tensor_perms n0 n1 (perm_inv n0 f) (perm_inv n1 g)). +Qed. + +#[export] Hint Resolve tensor_perms_permutation : perm_db. + +Lemma tensor_perms_inv n0 n1 f g + (Hf : permutation n0 f) (Hg : permutation n1 g) : + perm_eq (n0 * n1) + (perm_inv (n0 * n1) (tensor_perms n0 n1 f g)) + (tensor_perms n0 n1 (perm_inv n0 f) (perm_inv n1 g)). +Proof. + perm_eq_by_inv_inj (tensor_perms n0 n1 f g) (n0*n1). +Qed. + +#[export] Hint Resolve tensor_perms_inv : perm_inv_db. + +Lemma tensor_perms_inv' n0 n1 f g + (Hf : permutation n0 f) (Hg : permutation n1 g) : + perm_inv' (n0 * n1) (tensor_perms n0 n1 f g) = + tensor_perms n0 n1 (perm_inv' n0 f) (perm_inv' n1 g). +Proof. + permutation_eq_by_WF_inv_inj (tensor_perms n0 n1 f g) (n0*n1). +Qed. + +#[export] Hint Rewrite tensor_perms_inv' + using auto with perm_db : perm_inv_db. + +#[export] Hint Extern 100 (WF_Perm ?npow2 (qubit_perm_to_nat_perm ?n _)) => + replace npow2 with (2^n) by (show_pow2_le + unify_pows_two; nia) + : WF_Perm_db. + +Section qubit_perm_lemmas. + +Import Bits. + +Lemma qubit_perm_to_nat_perm_stack_perms n0 n1 f g + (Hf : perm_bounded n0 f) (Hg : perm_bounded n1 g) : + perm_eq (2^n0 * 2^n1) + (qubit_perm_to_nat_perm (n0 + n1) (stack_perms n0 n1 f g)) + (tensor_perms (2^n0) (2^n1) + (qubit_perm_to_nat_perm n0 f) + (qubit_perm_to_nat_perm n1 g)). +Proof. + intros k Hk. + unfold tensor_perms. + simplify_bools_lia_one_kernel. + unfold qubit_perm_to_nat_perm. + rewrite funbool_to_nat_add_pow2_join. + apply funbool_to_nat_eq. + intros a Ha. + unfold compose. + bdestruct (a if n + m <=? k then k else + if k if m + n <=? k then k else + if k n1 mod (n0 + n1) = 0) by + (intros ->; apply Nat.Div0.mod_same). + rewrite <- Nat.add_sub_assoc by lia. + rewrite rotr_eq_rotr_mod. + rewrite Nat.Div0.add_mod. + replace ((n1 - n1 mod (n0 + n1)) mod (n0 + n1)) with 0 by + (bdestruct (n0 =? 0); [subst; symmetry; + rewrite Nat.Div0.mod_same, Nat.sub_0_r, Nat.Div0.mod_same| + rewrite (Nat.mod_small n1), Nat.sub_diag, Nat.Div0.mod_0_l]; + lia). + rewrite Nat.add_0_r, <- !rotr_eq_rotr_mod. + now rewrite stack_perms_rotr_natural. +Qed. + + +Lemma tensor_perms_kron_comm_perm_natural n0 n1 f g + (Hf : perm_bounded n0 f) (Hg : perm_bounded n1 g) : + tensor_perms n0 n1 f g ∘ kron_comm_perm n0 n1 = + kron_comm_perm n0 n1 ∘ tensor_perms n1 n0 g f. +Proof. + eq_by_WF_perm_eq (n0 * n1). + intros k Hk. + unfold compose, kron_comm_perm. + assert (tensor_perms n1 n0 g f k < n1 * n0) + by auto with perm_bounded_db zarith. + do 2 simplify_bools_lia_one_kernel. + unfold tensor_perms. + simplify_bools_moddy_lia_one_kernel. + simplify_bools_lia_one_kernel. + rewrite !Nat.div_add_l, !mod_add_l by lia. + pose proof (Hf (k mod n0) ltac:(show_moddy_lt)). + pose proof (Hg (k / n0) ltac:(show_moddy_lt)). + rewrite Nat.Div0.div_div, Nat.div_small, Nat.add_0_r by lia. + rewrite (Nat.mod_small (k / n0)) by (show_moddy_lt). + rewrite (Nat.mod_small (f _)), (Nat.div_small (f _)) by lia. + lia. +Qed. + diff --git a/src/Permutations/PermutationRules.v b/src/Permutations/PermutationRules.v new file mode 100644 index 0000000..230baa9 --- /dev/null +++ b/src/Permutations/PermutationRules.v @@ -0,0 +1,9 @@ +Require Export PermutationDefinitions. +Require Export ZXperm. +Require Export ZXpermSemantics. +Require Export PermutationAutomation. +Require Export ZXpermFacts. + +(* Horrible hack to fix scoping issues: *) +Require Export StackComposeRules. + diff --git a/src/Permutations/PermutationSemantics.v b/src/Permutations/PermutationSemantics.v new file mode 100644 index 0000000..9b43b38 --- /dev/null +++ b/src/Permutations/PermutationSemantics.v @@ -0,0 +1,244 @@ +Require Import PermutationAuxiliary. +Require Import PermutationAutomation. +Require Import PermutationInstances. +Require Export PermMatrixFacts KronComm. + +Lemma perm_to_matrix_rotr_eq_kron_comm : forall n o, + perm_to_matrix (n + o) (rotr (n + o) n) = kron_comm (2^o) (2^n). +Proof. + intros n o. + now rewrite <- kron_comm_pows2_eq_perm_to_matrix_rotr. +Qed. + +#[export] Hint Rewrite perm_to_matrix_rotr_eq_kron_comm : perm_inv_db. + +Lemma perm_to_matrix_rotr_eq_kron_comm_mat_equiv : forall n o, + perm_to_matrix (n + o) (rotr (n + o) n) ≡ kron_comm (2^o) (2^n). +Proof. + intros n o. + now rewrite perm_to_matrix_rotr_eq_kron_comm. +Qed. + +#[export] Hint Resolve + perm_to_matrix_rotr_eq_kron_comm_mat_equiv : perm_inv_db. + +Lemma perm_to_matrix_rotl_eq_kron_comm : forall n o, + perm_to_matrix (n + o) (rotl (n + o) n) = kron_comm (2^n) (2^o). +Proof. + intros n o. + rewrite <- (perm_to_matrix_eq_of_perm_eq _ _ _ (rotr_inv (n + o) n)). + rewrite <- perm_to_matrix_transpose_eq by auto with perm_db. + rewrite perm_to_matrix_rotr_eq_kron_comm. + apply kron_comm_transpose. +Qed. + +#[export] Hint Rewrite perm_to_matrix_rotl_eq_kron_comm : perm_inv_db. + +Lemma perm_to_matrix_rotl_eq_kron_comm_mat_equiv : forall n o, + perm_to_matrix (n + o) (rotl (n + o) n) ≡ kron_comm (2^n) (2^o). +Proof. + intros. + now rewrite perm_to_matrix_rotl_eq_kron_comm. +Qed. + +#[export] Hint Resolve + perm_to_matrix_rotl_eq_kron_comm_mat_equiv : perm_inv_db. + +Lemma perm_to_matrix_swap_block_perm_eq padl padm padr a : + perm_to_matrix (padl + a + padm + a + padr) + (swap_block_perm padl padm a) = + I (2^padl) ⊗ + (kron_comm (2^a) (2^padm * 2^a) × + (kron_comm (2^padm) (2^a) ⊗ I (2^a))) ⊗ + I (2^padr). +Proof. + rewrite (swap_block_perm_decomp_eq padl padr padm a). + rewrite <- !(Nat.add_assoc padl). + rewrite 2!perm_to_matrix_of_stack_perms by auto with perm_db. + rewrite perm_to_matrix_compose by auto with perm_db. + rewrite perm_to_matrix_of_stack_perms by auto with perm_db. + rewrite 3!perm_to_matrix_idn. + rewrite kron_assoc by auto with wf_db. + f_equal; [show_pow2_le..|]. + f_equal; [show_pow2_le..|]. + rewrite 2!perm_to_matrix_rotr_eq_kron_comm. + unify_pows_two. + rewrite (Nat.add_comm a padm). + easy. +Qed. + +#[export] Hint Rewrite perm_to_matrix_swap_block_perm_eq : perm_inv_db. + +Lemma perm_to_matrix_rotr_commutes_kron_mat_equiv {n m p q} + (A : Matrix (2^n) (2^m)) (B : Matrix (2^p) (2^q)) : + @Mmult (2^n*2^p) (2^m*2^q) (2^q*2^m) + (A ⊗ B) (perm_to_matrix (q + m) (rotr (q + m) q)) ≡ + @Mmult (2^n*2^p) (2^p*2^n) (2^q*2^m) + (perm_to_matrix (p + n) (rotr (p + n) p)) (B ⊗ A). +Proof. + unify_pows_two. + rewrite 2!perm_to_matrix_rotr_eq_kron_comm. + restore_dims. + pose proof (kron_comm_commutes_r_mat_equiv (2^n) (2^m) + (2^p) (2^q) A B) as H. + rewrite !Nat.pow_add_r. + apply H. +Qed. + +Lemma perm_to_matrix_rotr_commutes_kron {n m p q} + (A : Matrix (2^n) (2^m)) (B : Matrix (2^p) (2^q)) : + WF_Matrix A -> WF_Matrix B -> + @Mmult (2^n*2^p) (2^m*2^q) (2^q*2^m) + (A ⊗ B) (perm_to_matrix (q + m) (rotr (q + m) q)) = + @Mmult (2^n*2^p) (2^p*2^n) (2^q*2^m) + (perm_to_matrix (p + n) (rotr (p + n) p)) (B ⊗ A). +Proof. + unify_pows_two. + rewrite 2!perm_to_matrix_rotr_eq_kron_comm. + restore_dims. + pose proof (kron_comm_commutes_r (2^n) (2^m) + (2^p) (2^q) A B) as H. + rewrite !Nat.pow_add_r. + apply H. +Qed. + + +Lemma perm_to_matrix_swap_block_perm_natural {padl padm padr a} + (A : Matrix (2^a) (2^a)) : + @mat_equiv (2^padl*2^a*2^padm*2^a*2^padr) (2^padl*2^a*2^padm*2^a*2^padr) + (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ + (I (2^padl) ⊗ A ⊗ I (2^padm * 2^a * 2^padr)) + (perm_to_matrix (padl + a + padm + a + padr) + (swap_block_perm padl padm a))) + (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ + (perm_to_matrix (padl + a + padm + a + padr) + (swap_block_perm padl padm a)) + (I (2^padl * 2^a * 2^padm) ⊗ A ⊗ I (2^padr))). +Proof. + apply mat_equiv_of_all_basis_conj. + intros i j Hi Hj. + rewrite !Mmult_assoc. + rewrite <- !Nat.pow_add_r in *. + rewrite !basis_f_to_vec_alt by easy. + rewrite perm_to_matrix_permutes_qubits by + apply swap_block_perm_permutation. + rewrite <- (transpose_involutive _ _ + (perm_to_matrix _ (swap_block_perm _ _ _))). + rewrite <- !Mmult_assoc, <- Mmult_transpose. + rewrite (perm_to_matrix_transpose_eq + (swap_block_perm_permutation padl padm padr a)). + rewrite (perm_to_matrix_eq_of_perm_eq _ _ _ + (swap_block_perm_inv padl padm padr a)). + rewrite perm_to_matrix_permutes_qubits by + apply swap_block_perm_permutation. + replace (padl+a+padm+a+padr) with (padl+a+(padm+a+padr)) in * by lia. + rewrite 2!(f_to_vec_split'_eq (padl+a)), 2!(f_to_vec_split'_eq (padl)). + rewrite !(fun x y => kron_transpose' _ _ x y). + rewrite !(fun x y z => kron_mixed_product' _ _ _ _ _ _ _ x y z) by + (now rewrite ?Nat.pow_add_r; simpl;lia). + rewrite !Mmult_1_r by auto with wf_db. + symmetry. + + replace (padl+a+(padm+a+padr)) with ((padl+a+padm)+a+padr) in * by lia. + rewrite 2!(f_to_vec_split'_eq (padl+a+padm+a)), 2!(f_to_vec_split'_eq (_+_+_)). + rewrite !(fun x y => kron_transpose' _ _ x y). + rewrite !(fun x y z => kron_mixed_product' _ _ _ _ _ _ _ x y z) by + (now rewrite ?Nat.pow_add_r; simpl;lia). + rewrite !Mmult_1_r by auto with wf_db. + unfold kron. + rewrite !Nat.mod_1_r, Nat.Div0.div_0_l. + rewrite !basis_f_to_vec. + rewrite !basis_trans_basis. + rewrite !matrix_conj_basis_eq_lt + by show_moddy_lt. + rewrite !Cmult_if_1_l, !Cmult_if_if_1_r. + apply f_equal_if. + - do 4 simplify_bools_moddy_lia_one_kernel. + apply eq_iff_eq_true. + rewrite !andb_true_iff, !Nat.eqb_eq. + rewrite <- !funbool_to_nat_eq_iff. + split;intros [Hlow Hhigh]; + split. + + intros k Hk. + generalize (Hlow k ltac:(lia)). + unfold swap_block_perm. + now simplify_bools_lia. + + intros k Hk. + unfold swap_block_perm. + simplify_bools_lia. + bdestructΩ'. + * generalize (Hlow (padl+a+k) ltac:(lia)). + unfold swap_block_perm. + now simplify_bools_lia. + * generalize (Hlow (padl + a + k - (a + padm)) ltac:(lia)). + unfold swap_block_perm. + simplify_bools_lia. + intros <-. + f_equal; lia. + * apply_with_obligations + (Hhigh ((padl + a + k) - (padl + a + padm + a)) ltac:(lia)); + f_equal; [lia|]. + unfold swap_block_perm; bdestructΩ'. + + intros k Hk. + unfold swap_block_perm. + simplify_bools_lia. + bdestructΩ'. + * generalize (Hlow (k) ltac:(lia)). + unfold swap_block_perm. + now simplify_bools_lia. + * apply_with_obligations + (Hhigh ((a + padm) + k - (padl + a)) ltac:(lia)); + f_equal; [|lia]. + unfold swap_block_perm; bdestructΩ'. + * apply_with_obligations + (Hhigh (k - (padl + a)) ltac:(lia)); + f_equal; [|lia]. + unfold swap_block_perm; bdestructΩ'. + + intros k Hk. + apply_with_obligations (Hhigh (padm + a + k) ltac:(lia)); + f_equal; + unfold swap_block_perm; + bdestructΩ'. + - f_equal; + apply Bits.funbool_to_nat_eq; + intros; + unfold swap_block_perm; + bdestructΩ'; f_equal; lia. + - easy. +Qed. + +Lemma perm_to_matrix_swap_block_perm_natural_eq {padl padm padr a} + (A : Matrix (2^a) (2^a)) (HA : WF_Matrix A) : + @eq (Matrix (2^padl*2^a*2^padm*2^a*2^padr) (2^padl*2^a*2^padm*2^a*2^padr)) + (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ + (I (2^padl) ⊗ A ⊗ I (2^padm * 2^a * 2^padr)) + (perm_to_matrix (padl + a + padm + a + padr) + (swap_block_perm padl padm a))) + (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ + (perm_to_matrix (padl + a + padm + a + padr) + (swap_block_perm padl padm a)) + (I (2^padl * 2^a * 2^padm) ⊗ A ⊗ I (2^padr))). +Proof. + apply mat_equiv_eq; + auto using WF_Matrix_dim_change with wf_db. + apply perm_to_matrix_swap_block_perm_natural. +Qed. + +Lemma perm_to_matrix_swap_block_perm_natural_eq_alt {padl padm padr a} + (A : Matrix (2^a) (2^a)) (HA : WF_Matrix A) : + @eq (Matrix (2^padl*2^a*2^padm*2^a*2^padr) (2^(padl+a+padm+a+padr))) + (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ + (I (2^padl) ⊗ A ⊗ I (2^padm * 2^a * 2^padr)) + (perm_to_matrix (padl + a + padm + a + padr) + (swap_block_perm padl padm a))) + (@Mmult (2^padl*2^a*2^padm*2^a*2^padr) (2^padl*2^a*2^padm*2^a*2^padr) _ + (perm_to_matrix (padl + a + padm + a + padr) + (swap_block_perm padl padm a)) + (I (2^padl * 2^a * 2^padm) ⊗ A ⊗ I (2^padr))). +Proof. + generalize (@perm_to_matrix_swap_block_perm_natural_eq + padl padm padr a A HA). + unify_pows_two. + easy. +Qed. + diff --git a/src/Permutations/ZXperm.v b/src/Permutations/ZXperm.v new file mode 100644 index 0000000..037207d --- /dev/null +++ b/src/Permutations/ZXperm.v @@ -0,0 +1,84 @@ +Require Import CoreData. +Require Import PermutationDefinitions. + +Open Scope ZX_scope. + +(* @nocheck name *) +(* Allowing combination of Z and X; will check before push *) +Inductive ZXperm : forall n, ZX n n -> Prop := + | PermEmpty : ZXperm 0 Empty + | PermWire : ZXperm 1 Wire + | PermSwap : ZXperm 2 ⨉ + | PermStack {n0 n1 zx0 zx1} : + (ZXperm n0 zx0) -> (ZXperm n1 zx1) -> ZXperm _ (zx0 ↕ zx1) + | PermComp {n zx0 zx1} : + (ZXperm n zx0) -> (ZXperm n zx1) -> ZXperm _ (zx0 ⟷ zx1). + + + +Fixpoint perm_of_zx {n m} (zx : ZX n m) : (nat -> nat) := + let idn := (fun x : nat => x) in + match zx with + | Empty => idn + | Wire => idn + | Swap => swap_2_perm + | @Compose n m o zx0 zx1 => + ((perm_of_zx zx0) ∘ (perm_of_zx zx1))%prg + | @Stack n0 m0 n1 m1 zx0 zx1 => + stack_perms n0 n1 (perm_of_zx zx0) (perm_of_zx zx1) + (* Fake cases: *) + | Cap => idn + | Cup => idn + | Box => idn + | X_Spider _ _ _ => idn + | Z_Spider _ _ _ => idn + end. + +Notation zxperm_to_matrix n zx := (perm_to_matrix n (perm_of_zx zx)). + +Definition bottom_to_top_perm (n : nat) : nat -> nat := + fun k => if n <=? k then k else + match k with + | 0 => (n - 1)%nat + | S k' => k' + end. + +Definition top_to_bottom_perm (n : nat) : nat -> nat := + fun k => if n <=? k then k else + if k =? (n-1) then 0%nat else (k + 1)%nat. + +Definition a_perm (n : nat) : nat -> nat := + swap_perm 0 (n-1) n. + +Lemma zx_to_bot_helper : forall a n, + n = (n - a + Init.Nat.min a n)%nat. +Proof. intros a n; lia. Qed. + +Definition zx_to_bot (a n : nat) : ZX n n := + cast _ _ (zx_to_bot_helper (n-a) n) (zx_to_bot_helper (n-a) n) + ((n_wire (n - (n-a))) ↕ a_swap (min (n-a) n)). + +Lemma zx_to_bot'_helper a n (H : (a < n)%nat) : + n = (a + (n - a))%nat. +Proof. lia. Qed. + +Definition zx_to_bot' (a n : nat) (H : (a < n)%nat) : ZX n n := + cast _ _ (zx_to_bot'_helper a n H) (zx_to_bot'_helper a n H) + (n_wire a ↕ a_swap (n-a)). + +Fixpoint zx_of_swap_list (l : list nat) : ZX (length l) (length l) := + match l with + | [] as l => cast _ _ eq_refl eq_refl ⦰ + | a::l' => + zx_to_bot a (1+length l') + ⟷ (@cast (1+length l') (1+length l') (length l' + 1) (length l' + 1) + (Nat.add_comm _ _) (Nat.add_comm _ _) (zx_of_swap_list l' ↕ —)) + end. + +Definition zx_of_perm_uncast n f := + zx_of_swap_list (insertion_sort_list n (perm_inv n f)). + +(* Need to prove facts about insertion_sort_list first, but in essence: + +Definition zx_of_perm n f := + $ n, n ::: zx_of_perm_uncast n f $ *) \ No newline at end of file diff --git a/src/Permutations/ZXpermFacts.v b/src/Permutations/ZXpermFacts.v new file mode 100644 index 0000000..5486fcd --- /dev/null +++ b/src/Permutations/ZXpermFacts.v @@ -0,0 +1,1061 @@ +Require Import ZXCore. +Require Import StackComposeRules. +Require Import CastRules. +Require Export ZXperm. +Require Import PermutationAutomation. +Require Import PermutationSemantics. +Require Export PermutationInstances. +Require Export PermutationFacts. +Require Export ZXpermSemantics. + +(* In this file, we develop some tools for showing things are ZXperms and + prove some specific values of perm_of_zx *) + +(* Now that we have facts about insertion_sort_list, we can define: *) + +Definition zx_of_perm n f := + cast n n + (eq_sym (length_insertion_sort_list n (perm_inv n f))) + (eq_sym (length_insertion_sort_list n (perm_inv n f))) + (zx_of_perm_uncast n f). + +(* Section on very general ZXperm facts *) + +Local Open Scope nat. +Local Open Scope ZX_scope. + +Lemma zxperm_iff_cast {n0 n1} {zx} (Hn Hn' : n1 = n0) : + ZXperm n1 (cast _ _ Hn Hn' zx) <-> ZXperm n0 zx. +Proof. + split; intros; subst; + rewrite cast_id_eq in *; easy. +Qed. + +#[export] Hint Resolve <- zxperm_iff_cast : zxperm_db. + +Lemma cast_stack_zxperm {n0 n1 o} {zx0} {zx1} + (H0 : ZXperm n0 zx0) (H1 : ZXperm n1 zx1) + (Hn Hn' : o = n0 + n1) : + ZXperm o (cast _ _ Hn Hn' (zx0 ↕ zx1)). +Proof. + auto with zxperm_db. +Qed. + +#[export] Hint Resolve cast_stack_zxperm : zxperm_db. + +Lemma conjugate_zxperm {n} {zx} (H : ZXperm n zx) : + ZXperm n (zx ⊼). +Proof. + induction H; simpl; constructor; easy. +Qed. + +#[export] Hint Resolve conjugate_zxperm : zxperm_db. + +Lemma transpose_zxperm {n} {zx} (H : ZXperm n zx) : + ZXperm n (zx ⊤). +Proof. + induction H; simpl; constructor; easy. +Qed. + +#[export] Hint Resolve transpose_zxperm : zxperm_db. + +Lemma adjoint_zxperm {n} {zx} (H : ZXperm n zx) : + ZXperm n (zx †). +Proof. + induction H; simpl; constructor; easy. +Qed. + +#[export] Hint Resolve adjoint_zxperm : zxperm_db. + +Lemma colorswap_zxperm {n} {zx} (H : ZXperm n zx) : + ZXperm n (⊙ zx). +Proof. + induction H; simpl; constructor; easy. +Qed. + +#[export] Hint Resolve colorswap_zxperm : zxperm_db. + +(* Section on core ZXperms *) +Lemma n_wire_zxperm {n} : + ZXperm n (n_wire n). +Proof. + induction n; simpl; auto with zxperm_db. +Qed. + +#[export] Hint Resolve n_wire_zxperm : zxperm_db. + +(* Lemma n_compose_zxperm {n} {zx} (H : ZXperm n zx) k : + ZXperm _ (n_compose k zx). +Proof. + induction k; simpl; auto with zxperm_db. +Qed. + +#[export] Hint Resolve n_compose_zxperm : zxperm_db. *) + + + +(* Section on specific ZXperms *) +Lemma top_to_bottom_helper_zxperm n : + ZXperm (S n) (top_to_bottom_helper n). +Proof. + induction n. + - constructor. + - simpl. + constructor. + + apply (PermStack PermSwap n_wire_zxperm). + + apply (PermStack PermWire IHn). +Qed. + +#[export] Hint Resolve top_to_bottom_helper_zxperm : zxperm_db. + +Lemma top_to_bottom_zxperm {n} : + ZXperm n (top_to_bottom n). +Proof. + destruct n; simpl; auto with zxperm_db. +Qed. + +Lemma bottom_to_top_zxperm {n} : + ZXperm n (bottom_to_top n). +Proof. + apply transpose_zxperm. + apply top_to_bottom_zxperm. +Qed. + +#[export] Hint Resolve top_to_bottom_zxperm bottom_to_top_zxperm : zxperm_db. + +(* Lemma n_top_to_bottom_zxperm : forall n m, + ZXperm _ (n_top_to_bottom n m). +Proof. + unfold n_top_to_bottom. + auto with zxperm_db. +Qed. + +Lemma n_bottom_to_top_zxperm : forall n m, + ZXperm _ (n_bottom_to_top n m). +Proof. + unfold n_bottom_to_top. + auto with zxperm_db. +Qed. + +#[export] Hint Resolve n_top_to_bottom_zxperm n_bottom_to_top_zxperm : zxperm_db. *) + +Lemma a_swap_zxperm n : + ZXperm n (a_swap n). +Proof. + induction n; simpl; auto with zxperm_db. +Qed. + +#[export] Hint Resolve a_swap_zxperm : zxperm_db. + + + + + + + +(* Section on rules for perm_of_zx *) +Lemma perm_of_zx_WF {n} {zx} (H : ZXperm n zx) : + WF_Perm n (perm_of_zx zx). +Proof. + induction H; intros k Hk; try easy. + - simpl. + destruct k; [|destruct k]; cbn; lia. + - simpl. + rewrite stack_perms_high; easy. + - simpl. + unfold compose. + rewrite IHZXperm1; rewrite IHZXperm2; lia. +Qed. + +#[export] Hint Resolve perm_of_zx_WF : WF_Perm_db. + +Lemma stack_perms_zx_idn {n0 n1} {zx} (H : ZXperm n0 zx) : + stack_perms n0 n1 (perm_of_zx zx) idn = + perm_of_zx zx. +Proof. + apply stack_perms_WF_idn. + auto with WF_Perm_db. +Qed. + +#[export] Hint Rewrite @stack_perms_zx_idn using (auto with zxperm_db) : perm_of_zx_cleanup_db. + +Lemma stack_perms_idn_zx {n0 n1} {zx} (H : ZXperm n1 zx) : + stack_perms n0 n1 idn (perm_of_zx zx) = + fun k => if k + perm_of_zx (zx_of_swap_list l) = perm_of_swap_list l. +Proof. + induction l. + - easy. + - simpl swap_list_spec. + rewrite andb_true_iff, Nat.ltb_lt. + intros [Ha Hspec]. + specialize (IHl Hspec). + simpl. + f_equal. + + rewrite (perm_of_zx_to_bot_eq_zx_to_bot' _ _ Ha). + cleanup_perm_of_zx. + f_equal; lia. + + cleanup_perm_of_zx. +Qed. + +#[export] Hint Rewrite perm_of_zx_of_swap_list + using auto with perm_db : perm_of_zx_cleanup_db. + +Lemma perm_of_zx_uncast_of_perm_eq n f : permutation n f -> + perm_eq n (perm_of_zx (zx_of_perm_uncast n f)) f. +Proof. + intros Hperm. + cleanup_perm_of_zx. +Qed. + +#[export] Hint Resolve perm_of_zx_uncast_of_perm_eq : perm_inv_db. + +Lemma perm_of_zx_uncast_of_perm_eq_WF n f : + permutation n f -> WF_Perm n f -> + perm_of_zx (zx_of_perm_uncast n f) = f. +Proof. + intros Hperm HWF. + cleanup_perm_of_zx. +Qed. + +#[export] Hint Rewrite perm_of_zx_uncast_of_perm_eq_WF + using (solve [auto with perm_db WF_Perm_db]) : perm_of_zx_cleanup_db. + +Lemma perm_of_zx_of_perm_eq n f : permutation n f -> + perm_eq n (perm_of_zx (zx_of_perm n f)) f. +Proof. + intros Hperm. + unfold zx_of_perm. + cleanup_perm_of_zx. +Qed. + +#[export] Hint Resolve perm_of_zx_of_perm_eq : perm_inv_db. + +Lemma perm_of_zx_of_perm_eq_WF n f : + permutation n f -> WF_Perm n f -> + perm_of_zx (zx_of_perm n f) = f. +Proof. + intros Hperm HWF. + unfold zx_of_perm. + cleanup_perm_of_zx. +Qed. + +#[export] Hint Rewrite perm_of_zx_of_perm_eq_WF + using (solve [auto with perm_db WF_Perm_db]) : perm_of_zx_cleanup_db. + +Lemma zx_of_perm_zxperm n f : + ZXperm n (zx_of_perm n f). +Proof. + unfold zx_of_perm. + auto with zxperm_db. +Qed. + +#[export] Hint Resolve zx_of_perm_zxperm : zxperm_db. + +Lemma zx_of_perm_of_zx {n zx} (H : ZXperm n zx) : + zx_of_perm n (perm_of_zx zx) ∝ zx. +Proof. + by_perm_eq. +Qed. + +#[export] Hint Rewrite @zx_of_perm_of_zx + using auto with zxperm_db : perm_of_zx_cleanup_db. + +Lemma perm_of_zx_perm_eq_of_proportional {n} {zx0 zx1 : ZX n n} + (Hzx0 : ZXperm n zx0) (Hzx1 : ZXperm n zx1) : + zx0 ∝ zx1 -> + perm_eq n (perm_of_zx zx0) (perm_of_zx zx1). +Proof. + unfold proportional, proportional_general. + rewrite (perm_of_zx_permutation_semantics Hzx0). + rewrite (perm_of_zx_permutation_semantics Hzx1). + intros H. + apply perm_to_matrix_perm_eq_of_proportional; + cleanup_perm_inv. +Qed. + +Lemma perm_of_zx_proper {n} {zx0 zx1 : ZX n n} + (Hzx0 : ZXperm n zx0) (Hzx1 : ZXperm n zx1) : + zx0 ∝ zx1 -> + perm_of_zx zx0 = perm_of_zx zx1. +Proof. + intros Hprop. + eq_by_WF_perm_eq n. + now apply perm_of_zx_perm_eq_of_proportional. +Qed. + +Lemma perm_of_zx_prop_rw {n} {zx0 zx1} : + zx0 ∝ zx1 -> + ZXperm n zx0 -> ZXperm n zx1 -> + perm_of_zx zx0 = perm_of_zx zx1. +Proof. + intros; now apply perm_of_zx_proper. +Qed. + +(* Import Setoid. + +Add Parametric Morphism n : (@perm_of_zx n n) + with signature + (fun zx0 zx1 => zx0 ∝ zx1 /\ ZXperm n zx0 /\ ZXperm n zx1) ==> + eq as perm_of_zx_proper_instance. +Proof. + intros zx0 zx1 (? & ? & ?); now apply perm_of_zx_proper. +Qed. + +#[export] Hint Extern 0 (_ ∝ _ /\ ZXperm _ _ /\ ZXperm _ _) => + split; [split|]; [|auto with zxperm_db..] : typeclasses_db. *) + +(* Section on combining zx_of_perm *) + +Lemma compose_zx_of_perm n f g + (Hf : permutation n f) + (Hg : permutation n g) : + zx_of_perm n f ⟷ zx_of_perm n g ∝ zx_of_perm n (f ∘ g). +Proof. + (* unfold zx_of_perm. *) + by_perm_eq. + apply (fun H => perm_eq_trans H (perm_eq_sym + (perm_of_zx_of_perm_eq n (f ∘ g) ltac:(auto with perm_db)))). + apply perm_eq_compose_proper; cleanup_perm_of_zx. +Qed. + +Lemma stack_zx_of_perm n m f g + (Hf : permutation n f) + (Hg : permutation m g) : + zx_of_perm n f ↕ zx_of_perm m g ∝ + zx_of_perm (n + m) (stack_perms n m f g). +Proof. + by_perm_eq. +Qed. + +#[export] Hint Rewrite compose_zx_of_perm + stack_zx_of_perm + using auto with perm_db zxperm_db : perm_of_zx_cleanup_db. + +(* TODO: Put somewhere proper *) +Lemma perm_inv_le_bounded_total n f : + forall k, + perm_inv n f k <= n. +Proof. + intros k. + induction n; [easy|]. + simpl. + bdestructΩ'. +Qed. + +#[export] Hint Resolve perm_inv_le_bounded_total : perm_bounded_db. + +Lemma insertion_sort_list_eq_of_perm_eq n f g : + perm_eq n f g -> + insertion_sort_list n f = insertion_sort_list n g. +Proof. + intros Hfg. + enough (forall k, k <= n -> + insertion_sort_list k f = insertion_sort_list k g) by auto with arith. + intros k Hk. + revert f g Hfg. + induction k; [easy|]. + intros f g Hfg. + simpl. + rewrite Hfg by lia. + rewrite (perm_inv_eq_of_perm_eq' n k f g Hfg) by lia. + f_equal. + apply IHk; [lia|]. + intros j Hj. + unfold Bits.fswap. + pose proof (Hfg k). + pose proof (Hfg j). + pose proof (perm_inv_le_bounded_total k g k). + pose proof (Hfg (perm_inv k g k) ltac:(lia)). + bdestructΩ'. +Qed. + +Lemma zx_of_perm_prop_of_perm_eq n f g : + perm_eq n f g -> + zx_of_perm n f ∝ zx_of_perm n g. +Proof. + intros Hperm. + unfold zx_of_perm. + pose proof (insertion_sort_list_eq_of_perm_eq n _ _ + (perm_inv_eq_of_perm_eq n f g Hperm)) as Hkey. + simpl_casts. + unfold zx_of_perm_uncast. + instantiate (1 := (f_equal (@length nat) (eq_sym Hkey))). + instantiate (1 := (f_equal (@length nat) (eq_sym Hkey))). + now case Hkey. +Qed. + +Lemma zx_of_perm_eq_of_perm_eq n f g : + perm_eq n f g -> + zx_of_perm n f = zx_of_perm n g. +Proof. + intros Hperm. + unfold zx_of_perm. + unfold zx_of_perm_uncast. + pose proof (insertion_sort_list_eq_of_perm_eq n _ _ + (perm_inv_eq_of_perm_eq n f g Hperm)) as Hkey. + rewrite (Peano_dec.UIP_nat _ _ _ ( + eq_trans (eq_sym (length_insertion_sort_list n (perm_inv n f))) + (f_equal (@length nat) Hkey) + )). + now case Hkey. +Qed. + +#[export] Hint Resolve zx_of_perm_eq_of_perm_eq + zx_of_perm_prop_of_perm_eq : perm_inv_db. + +Lemma zx_of_perm_idn n : + zx_of_perm n idn ∝ n_wire n. +Proof. + by_perm_eq. +Qed. + +#[export] Hint Rewrite zx_of_perm_idn : perm_of_zx_cleanup_db. + +#[export] Hint Extern 0 (perm_eq _ (perm_of_zx (zx_of_perm ?n ?f)) _) => + apply (perm_eq_trans (perm_of_zx_of_perm_eq n f + ltac:(auto with perm_db zxperm_db zarith))) : perm_inv_db. + +#[export] Hint Extern 0 (perm_eq _ _ (perm_of_zx (zx_of_perm ?n ?f))) => + apply (fun G => perm_eq_trans G (perm_eq_sym (perm_of_zx_of_perm_eq n f + ltac:(auto with perm_db zxperm_db zarith)))) : perm_inv_db. + +Lemma zx_of_perm_eq_idn n f : + perm_eq n f idn -> + zx_of_perm n f = zx_of_perm n idn. +Proof. + intros H. + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite zx_of_perm_eq_idn + using (solve [cleanup_perm_inv]): perm_of_zx_cleanup_db. + +Lemma zx_of_perm_eq_idn_prop n f : + perm_eq n f idn -> + zx_of_perm n f ∝ zx_of_perm n idn. +Proof. + intros H. + now cleanup_perm_of_zx. +Qed. + +Lemma cast_zx_of_perm n n' f (H H' : n = n') : + cast _ _ H H' (zx_of_perm _ f) = zx_of_perm _ f. +Proof. + subst. + now rewrite (Peano_dec.UIP_nat _ _ H' eq_refl). +Qed. + +#[export] Hint Rewrite cast_zx_of_perm : cast_simpl_db + perm_of_zx_cleanup_db. + +Lemma cast_zx_of_perm_natural_l n n' m' f H H' : + cast n' m' H H' (zx_of_perm n f) = + cast n' m' eq_refl (eq_trans H' (eq_sym H)) (zx_of_perm n' f). +Proof. + now subst. +Qed. + +Lemma cast_zx_of_perm_natural_r n n' m' f H H' : + cast n' m' H H' (zx_of_perm n f) = + cast n' m' (eq_trans H (eq_sym H')) eq_refl (zx_of_perm m' f). +Proof. + now subst. +Qed. + +(* Section on zx_of_perm naturalities *) + +Lemma zx_of_perm_perm_eq_idn_removal_l {n m} f + (zx : ZX n m) : perm_eq n f idn -> + zx_of_perm n f ⟷ zx ∝ zx. +Proof. + intros H. + cleanup_perm_of_zx. + now cleanup_zx. +Qed. + +Lemma zx_of_perm_perm_eq_idn_removal_r {n m} f + (zx : ZX n m) : perm_eq m f idn -> + zx ⟷ zx_of_perm m f ∝ zx. +Proof. + intros H. + cleanup_perm_of_zx. + now cleanup_zx. +Qed. + +#[export] Hint Rewrite + @zx_of_perm_perm_eq_idn_removal_l + @zx_of_perm_perm_eq_idn_removal_r + using (solve [cleanup_perm_inv]) : perm_of_zx_cleanup_db. + +Lemma zx_of_perm_semantics n f : + permutation n f -> + ⟦ zx_of_perm n f ⟧ = perm_to_matrix n f. +Proof. + intros Hf. + rewrite perm_of_zx_permutation_semantics by auto with zxperm_db. + apply perm_to_matrix_eq_of_perm_eq. + cleanup_perm_of_zx. +Qed. + +#[export] Hint Rewrite zx_of_perm_semantics + using auto with perm_db : perm_of_zx_cleanup_db. + +Lemma zx_of_perm_casted_semantics f n n' m' + (H : n' = n) (H' : m' = n) : + permutation n f -> + @eq (Matrix (2^m') (2^n')) + (⟦ cast n' m' H H' (zx_of_perm n f) ⟧ ) + (perm_to_matrix n f). +Proof. + intros Hf. + simpl_cast_semantics. + cleanup_perm_of_zx. +Qed. + +#[export] Hint Rewrite zx_of_perm_casted_semantics + using auto with perm_db : perm_of_zx_cleanup_db. + +Ltac simpl_zx_of_perm_semantics := + match goal with + |- context[ ⟦cast ?n' ?m' ?H ?H' (zx_of_perm ?n ?f)⟧] => + rewrite (zx_of_perm_casted_semantics f n n' m' H H') by auto with perm_db; + autorewrite with perm_inv_db + end. + +#[export] Hint Extern 5 (@eq (Matrix _ _) _ _)=> + (* idtac "HIT"; *) + simpl_zx_of_perm_semantics : perm_inv_db perm_of_zx_cleanup_db. + +(* #[export] Hint Extern 0 (@eq (Matrix _ _) ?A ?A) => + reflexivity : perm_inv_db perm_of_zx_cleanup_db. *) + + +Definition zx_comm p q : (ZX (p + q) (q + p)) := + cast (p+q) (q + p) eq_refl (Nat.add_comm q p) + (zx_of_perm (p + q) (rotr (p + q) p)). + +Lemma zx_comm_semantics p q : + ⟦ zx_comm p q ⟧ = kron_comm (2^q) (2^p). +Proof. + unfold zx_comm. + cleanup_perm_of_zx. + (* simpl_zx_of_perm_semantics. + rewrite zx_of_perm_casted_semantics. *) +Qed. + +#[export] Hint Rewrite zx_comm_semantics : perm_of_zx_cleanup_db. + +Lemma zx_comm_cancel p q : + zx_comm p q ⟷ zx_comm q p ∝ n_wire _. +Proof. + prop_exists_nonzero R1. + rewrite Mscale_1_l. + simpl. + cleanup_perm_of_zx. + rewrite n_wire_semantics. + restore_dims. + rewrite kron_comm_mul_inv. + now unify_pows_two. +Qed. + +#[export] Hint Rewrite zx_comm_cancel : perm_of_zx_cleanup_db. + +Lemma zx_comm_commutes_l {n m p q} (zx0 : ZX n m) (zx1 : ZX p q) : + zx_comm p n ⟷ (zx0 ↕ zx1) ∝ + (zx1 ↕ zx0) ⟷ zx_comm q m. +Proof. + prop_exists_nonzero R1. + rewrite Mscale_1_l. + simpl. + cleanup_perm_of_zx. + restore_dims. + apply (kron_comm_commutes_r _ _ _ _ (⟦zx0⟧) (⟦zx1⟧)); + auto with wf_db. +Qed. + +Lemma zx_comm_commutes_r {n m p q} (zx0 : ZX n m) (zx1 : ZX p q) : + (zx0 ↕ zx1) ⟷ zx_comm m q ∝ + zx_comm n p ⟷ (zx1 ↕ zx0). +Proof. + prop_exists_nonzero R1. + rewrite Mscale_1_l. + simpl. + cleanup_perm_of_zx. + restore_dims. + apply (kron_comm_commutes_l _ _ _ _ (⟦zx0⟧) (⟦zx1⟧)); + auto with wf_db. +Qed. + +Lemma zx_comm_1_1_swap : + zx_comm 1 1 ∝ ⨉. +Proof. + unfold zx_comm. + simpl_permlike_zx. + by_perm_eq. + intros [| []]; easy. +Qed. + +Lemma swap_pullthrough_l {n m} (zx0 : ZX n 1) (zx1 : ZX m 1) : + (zx0 ↕ zx1) ⟷ ⨉ ∝ + zx_comm n m ⟷ (zx1 ↕ zx0). +Proof. + rewrite <- zx_comm_1_1_swap. + now rewrite zx_comm_commutes_r. +Qed. + +Lemma swap_pullthrough_r {n m} (zx0 : ZX 1 n) (zx1 : ZX 1 m) : + ⨉ ⟷ (zx0 ↕ zx1) ∝ + (zx1 ↕ zx0) ⟷ zx_comm m n. +Proof. + rewrite <- zx_comm_1_1_swap. + now rewrite zx_comm_commutes_r. +Qed. + +(* TODO: move *) +Lemma permutation_change_dims n m (H : n = m) f : + permutation n f <-> permutation m f. +Proof. + now subst. +Qed. + +Lemma rotr_add_n_l n k : + rotr n (n + k) = rotr n k. +Proof. + rewrite rotr_eq_rotr_mod. + rewrite Nat.add_comm, mod_add_n_r. + now rewrite <- rotr_eq_rotr_mod. +Qed. + +Lemma rotr_add_n_r n k : + rotr n (k + n) = rotr n k. +Proof. + rewrite rotr_eq_rotr_mod. + rewrite mod_add_n_r. + now rewrite <- rotr_eq_rotr_mod. +Qed. + +#[export] Hint Rewrite rotr_add_n_r rotr_add_n_l : perm_cleanup_db. + +Lemma cast_compose_eq_mid_join n m o n' m' o' + (Hn : n' = n) (Hm Hm' : m' = m) (Ho : o' = o) + (zx0 : ZX n m) (zx1 : ZX m o) : + cast n' m' Hn Hm zx0 ⟷ cast m' o' Hm' Ho zx1 = + cast n' o' Hn Ho (zx0 ⟷ zx1). +Proof. + subst. + now rewrite (Peano_dec.UIP_nat _ _ Hm' eq_refl). +Qed. + +#[export] Hint Rewrite cast_compose_eq_mid_join : cast_simpl_db. + +Lemma zx_of_perm_compose_cast_r n n' m' Hn Hm f g + (Hf : permutation n f) (Hg : permutation n' g) : + zx_of_perm n f ⟷ cast n m' Hn Hm (zx_of_perm n' g) ∝ + cast n m' Hn Hm (zx_of_perm n' (f ∘ g)). +Proof. + subst. + cleanup_perm_of_zx. +Qed. + +Lemma zx_of_perm_compose_cast_l m n' m' Hn Hm f g + (Hf : permutation m' f) (Hg : permutation m g) : + cast n' m Hn Hm (zx_of_perm m' f) ⟷ zx_of_perm m g ∝ + cast n' m Hn Hm (zx_of_perm m' (f ∘ g)). +Proof. + subst. + cleanup_perm_of_zx. +Qed. + +Lemma zx_of_perm_compose_cast_cast n m n' m' o' Hn Hm Hm' Ho f g + (Hf : permutation n f) (Hg : permutation m g) : + cast n' m' Hn Hm (zx_of_perm n f) ⟷ + cast m' o' Hm' Ho (zx_of_perm m g) ∝ + cast n' o' (eq_trans Hn (eq_trans (eq_sym Hm) Hm')) Ho + (zx_of_perm m (f ∘ g)). +Proof. + subst. + cleanup_perm_of_zx. +Qed. + +#[export] Hint Rewrite zx_of_perm_compose_cast_r + zx_of_perm_compose_cast_l + zx_of_perm_compose_cast_cast + using (first [auto with perm_db zxperm_db + | erewrite permutation_change_dims; auto with perm_db zarith ]) : + perm_of_zx_cleanup_db. + +Lemma zx_comm_twice_add_r_join n m o H : + zx_comm n (m + o) ⟷ cast _ _ H eq_refl (zx_comm m (o + n)) ∝ + cast _ _ (Nat.add_assoc _ _ _) (eq_sym (Nat.add_assoc _ _ _)) + (zx_comm _ _). +Proof. + unfold zx_comm. + simpl_casts. + rewrite zx_of_perm_compose_cast_cast by auto with perm_db. + simpl_casts. + apply zx_of_perm_prop_of_perm_eq. + replace (n + m + o) with (n + (m + o)) by lia. + replace (m + (o + n)) with (n + (m + o)) by lia. + cleanup_perm. +Qed. + + +Lemma zx_comm_twice_add_l_join n m o H : + zx_comm (n + m) o ⟷ cast _ _ H eq_refl (zx_comm (o + n) m) ∝ + cast _ _ (eq_sym (Nat.add_assoc _ _ _)) (Nat.add_assoc _ _ _) + (zx_comm n (m + o)). +Proof. + unfold zx_comm. + simpl_casts. + rewrite zx_of_perm_compose_cast_cast by auto with perm_db. + simpl_casts. + apply zx_of_perm_prop_of_perm_eq. + replace (n + m + o) with (n + (m + o)) by lia. + replace (o + n + m) with (n + (m + o)) by lia. + cleanup_perm. + replace (n + m + (o + n)) with (n + (m + o) + n) by lia. + cleanup_perm. +Qed. + +Lemma zx_of_perm_rotr_to_zx_comm n m : + zx_of_perm (n + m) (rotr (n + m) n) ∝ + cast _ _ eq_refl (Nat.add_comm _ _) + (zx_comm n m). +Proof. + unfold zx_comm. + simpl_casts. +Qed. + +Lemma zx_of_perm_rotr_to_zx_comm_rev n m : + zx_of_perm (n + m) (rotr (n + m) m) ∝ + cast _ _ (Nat.add_comm _ _) eq_refl + (zx_comm m n). +Proof. + unfold zx_comm. + simpl_casts. + now rewrite (Nat.add_comm m n). +Qed. + +Definition zx_gap_comm p m q : (ZX (p + m + q) (q + m + p)) := + cast _ _ eq_refl (eq_sym (Nat.add_assoc _ _ _)) + (zx_comm (p + m) q ⟷ (n_wire q ↕ zx_comm p m)). + +Lemma zx_gap_comm_defn p m q : + zx_gap_comm p m q ∝ + cast _ _ eq_refl (eq_sym zx_of_perm + +Import ComposeRules StackComposeRules CastRules. + +Lemma zx_gap_comm_pullthrough_r {n m r s p q} + (zx0 : ZX n m) (zx1 : ZX r s) (zx2 : ZX p q) : + zx0 ↕ zx1 ↕ zx2 ⟷ zx_gap_comm m s q ∝ + zx_gap_comm n r p ⟷ (zx2 ↕ zx1 ↕ zx0). +Proof. + unfold zx_gap_comm at 1. + rewrite cast_compose_distribute, cast_id, <- compose_assoc. + rewrite zx_comm_commutes_r, compose_assoc. + rewrite cast_compose_r, cast_id, <- stack_compose_distr. + rewrite zx_comm_commutes_r, nwire_removal_r. + rewrite <- (nwire_removal_l zx2) at 1. + clean_eqns rewrite stack_compose_distr, stack_assoc_back. + rewrite (cast_compose_r _ _ (_ ↕ _)). + simpl_casts. + rewrite <- compose_assoc. + unfold zx_gap_comm. + rewrite cast_compose_distribute, cast_id. + auto using compose_simplify, cast_simplify, proportional_refl. +Qed. + +Lemma zx_gap_comm_pullthrough_l {n m r s p q} + (zx0 : ZX n m) (zx1 : ZX r s) (zx2 : ZX p q) : + zx_gap_comm n r p ⟷ (zx2 ↕ zx1 ↕ zx0) ∝ + zx0 ↕ zx1 ↕ zx2 ⟷ zx_gap_comm m s q. +Proof. + symmetry. + apply zx_gap_comm_pullthrough_r. +Qed. + +Lemma zx_gap_comm_1_m_1_a_swap m : + zx_gap_comm 1 m 1 ∝ a_swap (1 + m + 1). +Proof. + unfold zx_gap_comm, zx_. + by_perm_eq. \ No newline at end of file diff --git a/src/Permutations/ZXpermSemantics.v b/src/Permutations/ZXpermSemantics.v new file mode 100644 index 0000000..3618838 --- /dev/null +++ b/src/Permutations/ZXpermSemantics.v @@ -0,0 +1,186 @@ +Require Import ZXCore. +Require Import CastRules. +Require Import PermutationFacts. +Require Import PermutationInstances. +Require Import ZXperm. +Require Import PermutationAuxiliary. +Require Import PermutationAutomation. +Require Import PermMatrixFacts. +Require Import PermutationSemantics. +Require Import CoreData.Proportional. + + +Local Open Scope nat. + +Lemma perm_of_zx_permutation n zx : + ZXperm n zx -> permutation n (perm_of_zx zx). +Proof. + intros H. + induction H; show_permutation. +Qed. + +#[export] Hint Resolve perm_of_zx_permutation : perm_db. +#[export] Hint Extern 4 (permutation _ (perm_of_zx _)) => + apply perm_of_zx_permutation; + solve [auto with zxperm_db] : perm_db. + +#[export] Hint Constructors ZXperm : zxperm_db. + +(* TODO: Decide whether this goes here (it does) or somewhere else (it doesn't) *) +Lemma stack_perms_matrix_helper {n0 n1 i j} {f g} + (Hi : i < 2 ^ (n0 + n1)) (Hj: j < 2 ^ (n0 + n1)) : + permutation n0 f -> permutation n1 g -> + i =? qubit_perm_to_nat_perm (n0 + n1) (stack_perms n0 n1 f g) j = + (i / 2 ^ n1 =? qubit_perm_to_nat_perm n0 f (j / 2 ^ n1)) && + (i mod 2 ^ n1 =? qubit_perm_to_nat_perm n1 g (j mod 2 ^ n1)). +Proof. + intros Hfperm Hgperm. + rewrite qubit_perm_to_nat_perm_stack_perms by auto with perm_bounded_db. + rewrite (eqb_iff_div_mod_eqb (2^n1)), andb_comm. + do 2 f_equal; + unfold tensor_perms; + simplify_bools_moddy_lia_one_kernel. + - rewrite Nat.div_add_l by show_nonzero. + rewrite (Nat.div_small (_ _)) by auto with perm_bounded_db. + lia. + - now rewrite mod_add_l, Nat.mod_small by auto with perm_bounded_db. +Qed. + +Lemma empty_permutation_semantics : ⟦ Empty ⟧ = zxperm_to_matrix 0 Empty. +Proof. lma'. Qed. + +Lemma wire_permutation_semantics : ⟦ Wire ⟧ = zxperm_to_matrix 1 Wire. +Proof. lma'. Qed. + +Lemma swap_2_perm_semantics : ⟦ Swap ⟧ = zxperm_to_matrix 2 Swap. +Proof. lma'. Qed. + +Lemma if_dist2 {T1 T2 T3 : Type} (f : T1 -> T2 -> T3) + (b1 b2 : bool) x1 x2 x3 x4 : + f (if b1 then x1 else x2) (if b2 then x3 else x4) = + if b1 && b2 then f x1 x3 else + (if b1 then f x1 x4 else + (if b2 then f x2 x3 else f x2 x4)). +Proof. + now destruct b1, b2. +Qed. + +Lemma stack_perms_semantics {n0 n1 m0 m1} + {zx0 : ZX n0 m0} {zx1 : ZX n1 m1} (H0 : n0 = m0) (H1 : n1 = m1) + (Hzx0 : ⟦ zx0 ⟧ = zxperm_to_matrix n0 zx0) + (Hzx1 : ⟦ zx1 ⟧ = zxperm_to_matrix n1 zx1) + (Hzx0perm : permutation n0 (perm_of_zx zx0)) + (Hzx1perm : permutation n1 (perm_of_zx zx1)) : + ⟦ zx0 ↕ zx1 ⟧ = zxperm_to_matrix (n0 + n1) (zx0 ↕ zx1). +Proof. + simpl. + subst. + rewrite perm_to_matrix_of_stack_perms by easy. + now f_equal. +Qed. + +Lemma compose_permutation_semantics {n m o} {zx0 : ZX n m} {zx1 : ZX m o} + (H0 : n = m) + (Hzx0 : ⟦ zx0 ⟧ = zxperm_to_matrix n zx0) + (Hzx1 : ⟦ zx1 ⟧ = zxperm_to_matrix m zx1) + (Hzx0perm : permutation n (perm_of_zx zx0)) + (Hzx1perm : permutation m (perm_of_zx zx1)) : + ⟦ zx0 ⟷ zx1 ⟧ = zxperm_to_matrix n (zx0 ⟷ zx1). +Proof. + simpl. + subst. + rewrite perm_to_matrix_compose by easy. + now rewrite Hzx0, Hzx1. +Qed. + +Lemma cast_permutations_semantics {n0 n1} {zx : ZX n0 n0} + (Hn : n1 = n0) + (Hzx : ⟦ zx ⟧ = zxperm_to_matrix n1 zx) : + ⟦ cast _ _ Hn Hn zx ⟧ = zxperm_to_matrix n1 (cast _ _ Hn Hn zx). +Proof. subst; easy. Qed. + +Lemma perm_of_zx_permutation_semantics {n zx} : + ZXperm n zx -> ⟦ zx ⟧ = zxperm_to_matrix n zx. +Proof. + intros H. + induction H. + - apply empty_permutation_semantics. + - apply wire_permutation_semantics. + - apply swap_2_perm_semantics. + - eapply stack_perms_semantics; auto with perm_db. + - apply compose_permutation_semantics; auto with perm_db. +Qed. + +(* ... which enables the main result: *) + +Lemma proportional_of_equal_perm {n} {zx0 zx1 : ZX n n} + (Hzx0 : ZXperm n zx0) (Hzx1 : ZXperm n zx1) + (Hperm : perm_of_zx zx0 = perm_of_zx zx1) : + zx0 ∝ zx1. +Proof. + prop_exists_nonzero (RtoC 1). + rewrite Mscale_1_l. + rewrite (perm_of_zx_permutation_semantics Hzx0), + (perm_of_zx_permutation_semantics Hzx1). + f_equal; easy. +Qed. + +Lemma proportional_of_perm_eq {n} {zx0 zx1 : ZX n n} + (Hzx0 : ZXperm n zx0) (Hzx1 : ZXperm n zx1) + (Hperm : forall k, k < n -> perm_of_zx zx0 k = perm_of_zx zx1 k) : + zx0 ∝ zx1. +Proof. + prop_exists_nonzero (RtoC 1). + rewrite Mscale_1_l. + rewrite (perm_of_zx_permutation_semantics Hzx0), + (perm_of_zx_permutation_semantics Hzx1). + apply mat_equiv_eq; auto with wf_db. + apply perm_to_matrix_perm_eq, Hperm. +Qed. + +(* TODO: split intro prop_perm_eq and prop_perm_eqΩ *) + +Ltac prop_perm_eq_nosimpl := + intros; + simpl_casts; + simpl_permlike_zx; + __cast_prop_sides_to_square; + (* Goal: zx0 ∝ zx1 *) + apply proportional_of_equal_perm; [ + (* New goals: *) + (*1: ZXperm _ zx0 *) auto 10 with zxperm_db | + (*2: ZXperm _ zx1*) auto 10 with zxperm_db | + (*3: perm_of_zx zx0 = perm_of_zx zx1*) + ]. + +Ltac prop_perm_eq := + intros; + autounfold with zxperm_db; + simpl_casts; + simpl_permlike_zx; + __cast_prop_sides_to_square; + (* Goal: zx0 ∝ zx1 *) + apply proportional_of_equal_perm; [ + (* New goals: *) + (*1: ZXperm _ zx0 *) auto 10 with zxperm_db | + (*2: ZXperm _ zx1*) auto 10 with zxperm_db | + (*3: perm_of_zx zx0 = perm_of_zx zx1*) cleanup_perm_of_zx; try easy; try lia + ]. + +(* TODO: switch all over to this: *) +Ltac by_perm_eq := + intros; + autounfold with zxperm_db; + simpl_casts; + simpl_permlike_zx; + __cast_prop_sides_to_square; + (* Goal: zx0 ∝ zx1 *) + apply proportional_of_perm_eq; [ + (* New goals: *) + (*1: ZXperm _ zx0 *) auto 10 with zxperm_db | + (*2: ZXperm _ zx1*) auto 10 with zxperm_db | + (*3: forall k, k < n -> perm_of_zx zx0 k = perm_of_zx zx1 k *) + cleanup_perm_of_zx; try easy; try lia + ]. + + From fa77173a2e9075660cd014e8f93ead95708699ba Mon Sep 17 00:00:00 2001 From: William Spencer Date: Sat, 20 Jul 2024 13:50:36 -0700 Subject: [PATCH 02/10] Added helper lemmas for Swap, zx_comm, a_swap, zx_gap_comm naturality, of the form [name]_nat_(top|mid|bot)_(r|l)[_1], to ZXpermFacts --- src/Permutations/ZXpermFacts.v | 388 ++++++++++++++++++++++++++++++++- 1 file changed, 382 insertions(+), 6 deletions(-) diff --git a/src/Permutations/ZXpermFacts.v b/src/Permutations/ZXpermFacts.v index 5486fcd..e6b2bb6 100644 --- a/src/Permutations/ZXpermFacts.v +++ b/src/Permutations/ZXpermFacts.v @@ -890,6 +890,10 @@ Proof. now rewrite zx_comm_commutes_r. Qed. +(* NB: These are intentionally swapped l / r *) +Notation swap_commutes_l := swap_pullthrough_r. +Notation swap_commutes_r := swap_pullthrough_l. + (* TODO: move *) Lemma permutation_change_dims n m (H : n = m) f : permutation n f <-> permutation m f. @@ -1019,13 +1023,30 @@ Definition zx_gap_comm p m q : (ZX (p + m + q) (q + m + p)) := cast _ _ eq_refl (eq_sym (Nat.add_assoc _ _ _)) (zx_comm (p + m) q ⟷ (n_wire q ↕ zx_comm p m)). +Lemma zx_gap_comm_pf p m q : p + m + q = q + m + p. +Proof. lia. Qed. + Lemma zx_gap_comm_defn p m q : zx_gap_comm p m q ∝ - cast _ _ eq_refl (eq_sym zx_of_perm + cast _ _ eq_refl (zx_gap_comm_pf _ _ _) + (zx_of_perm (p + m + q) (rotr (p + m + q) (p + m) ∘ + stack_perms q (p + m) idn (rotr (p + m) p))). +Proof. + unfold zx_gap_comm, zx_comm. + rewrite <- zx_of_perm_idn. + clean_eqns rewrite cast_stack_r. + rewrite stack_zx_of_perm by auto with perm_db. + rewrite cast_compose_l, !cast_cast_eq. + rewrite cast_zx_of_perm_natural_l. + rewrite cast_compose_r, cast_id, compose_zx_of_perm by + (erewrite permutation_change_dims; auto with perm_db zarith). + rewrite cast_cast_eq. + now apply cast_simplify. +Qed. Import ComposeRules StackComposeRules CastRules. -Lemma zx_gap_comm_pullthrough_r {n m r s p q} +Lemma zx_gap_comm_pullthrough_l {n m r s p q} (zx0 : ZX n m) (zx1 : ZX r s) (zx2 : ZX p q) : zx0 ↕ zx1 ↕ zx2 ⟷ zx_gap_comm m s q ∝ zx_gap_comm n r p ⟷ (zx2 ↕ zx1 ↕ zx0). @@ -1045,17 +1066,372 @@ Proof. auto using compose_simplify, cast_simplify, proportional_refl. Qed. -Lemma zx_gap_comm_pullthrough_l {n m r s p q} +Lemma zx_gap_comm_pullthrough_r {n m r s p q} (zx0 : ZX n m) (zx1 : ZX r s) (zx2 : ZX p q) : zx_gap_comm n r p ⟷ (zx2 ↕ zx1 ↕ zx0) ∝ zx0 ↕ zx1 ↕ zx2 ⟷ zx_gap_comm m s q. Proof. symmetry. - apply zx_gap_comm_pullthrough_r. + apply zx_gap_comm_pullthrough_l. Qed. +(* NB: These are intentionally swapped l / r *) +Notation zx_gap_comm_commutes_l := zx_gap_comm_pullthrough_r. +Notation zx_gap_comm_commutes_r := zx_gap_comm_pullthrough_l. + Lemma zx_gap_comm_1_m_1_a_swap m : zx_gap_comm 1 m 1 ∝ a_swap (1 + m + 1). Proof. - unfold zx_gap_comm, zx_. - by_perm_eq. \ No newline at end of file + rewrite zx_gap_comm_defn, cast_id. + by_perm_eq. + rewrite Nat.add_sub. + rewrite perm_of_zx_of_perm_eq_WF + by (rewrite (Nat.add_comm 1 m), Nat.add_comm; cleanup_perm_inv). + rewrite stack_perms_idn_f. + rewrite 2!rotr_add_l_eq. + intros k Hk; unfold compose. + unfold swap_perm. + rewrite (Nat.add_comm 1 m). + bdestructΩ'. +Qed. + +Lemma a_swap_pullthrough_l {n m o p} + (zx0 : ZX n 1) (zx1 : ZX m o) (zx2 : ZX p 1) : + zx0 ↕ zx1 ↕ zx2 ⟷ a_swap (1 + o + 1) ∝ + zx_gap_comm n m p ⟷ (zx2 ↕ zx1 ↕ zx0). +Proof. + rewrite <- zx_gap_comm_1_m_1_a_swap. + apply zx_gap_comm_pullthrough_l. +Qed. + +Lemma a_swap_pullthrough_r {n m o p} + (zx0 : ZX 1 n) (zx1 : ZX m o) (zx2 : ZX 1 p) : + a_swap (1 + m + 1) ⟷ (zx0 ↕ zx1 ↕ zx2) ∝ + zx2 ↕ zx1 ↕ zx0 ⟷ zx_gap_comm p o n . +Proof. + rewrite <- zx_gap_comm_1_m_1_a_swap. + apply zx_gap_comm_pullthrough_r. +Qed. + +(* NB: These are intentionally swapped l / r *) +Notation a_swap_commutes_l := a_swap_pullthrough_r. +Notation a_swap_commutes_r := a_swap_pullthrough_l. + + + + +Lemma zx_comm_nat_bot_l {p q n m} + (zxBot : ZX m q) (zxTop : ZX n p) : + zxTop ↕ zxBot ⟷ zx_comm p q ∝ + zxTop ↕ n_wire m ⟷ zx_comm p m + ⟷ (zxBot ↕ n_wire p). +Proof. + rewrite 2!zx_comm_commutes_r, compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + +Lemma zx_comm_nat_top_l {p q n m} + (zxTop : ZX n p) (zxBot : ZX m q) : + zxTop ↕ zxBot ⟷ zx_comm p q ∝ + n_wire n ↕ zxBot ⟷ zx_comm n q + ⟷ (n_wire q ↕ zxTop). +Proof. + rewrite 2!zx_comm_commutes_r, compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + +Lemma zx_comm_nat_bot_r {p q n m} + (zxBot : ZX m q) (zxTop : ZX n p) : + zx_comm m n ⟷ (zxTop ↕ zxBot) ∝ + zxBot ↕ n_wire n ⟷ zx_comm q n + ⟷ (zxTop ↕ n_wire q). +Proof. + rewrite compose_assoc, 2!zx_comm_commutes_l, <- compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + +Lemma zx_comm_nat_top_r {p q n m} + (zxTop : ZX n p) (zxBot : ZX m q) : + zx_comm m n ⟷ (zxTop ↕ zxBot) ∝ + n_wire m ↕ zxTop ⟷ zx_comm m p + ⟷ (n_wire p ↕ zxBot). +Proof. + rewrite compose_assoc, 2!zx_comm_commutes_l, <- compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + + + +Lemma swap_nat_bot_l {n m} + (zxBot : ZX m 1) (zxTop : ZX n 1) : + zxTop ↕ zxBot ⟷ ⨉ ∝ + zxTop ↕ n_wire m ⟷ zx_comm 1 m + ⟷ (zxBot ↕ n_wire 1). +Proof. + rewrite swap_commutes_r, zx_comm_commutes_r, compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + +Lemma swap_nat_top_l {n m} + (zxTop : ZX n 1) (zxBot : ZX m 1) : + zxTop ↕ zxBot ⟷ ⨉ ∝ + n_wire n ↕ zxBot ⟷ zx_comm n 1 + ⟷ (n_wire 1 ↕ zxTop). +Proof. + rewrite swap_commutes_r, zx_comm_commutes_r, compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + +Lemma swap_nat_bot_r {p q} + (zxBot : ZX 1 q) (zxTop : ZX 1 p) : + ⨉ ⟷ (zxTop ↕ zxBot) ∝ + zxBot ↕ n_wire 1 ⟷ zx_comm q 1 + ⟷ (zxTop ↕ n_wire q). +Proof. + rewrite compose_assoc, swap_commutes_l, + zx_comm_commutes_l, <- compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + +Lemma swap_nat_top_r {p q} + (zxTop : ZX 1 p) (zxBot : ZX 1 q) : + ⨉ ⟷ (zxTop ↕ zxBot) ∝ + n_wire 1 ↕ zxTop ⟷ zx_comm 1 p + ⟷ (n_wire p ↕ zxBot). +Proof. + rewrite compose_assoc, swap_commutes_l, + zx_comm_commutes_l, <- compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + + + +Lemma swap_nat_bot_l_1 {n} + (zxBot : ZX 1 1) (zxTop : ZX n 1) : + zxTop ↕ zxBot ⟷ ⨉ ∝ + zxTop ↕ n_wire 1 ⟷ ⨉ + ⟷ (zxBot ↕ n_wire 1). +Proof. + rewrite 2!swap_commutes_r, compose_assoc. + change 2%nat with (1 + 1)%nat. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + +Lemma swap_nat_top_l_1 {m} + (zxTop : ZX 1 1) (zxBot : ZX m 1) : + zxTop ↕ zxBot ⟷ ⨉ ∝ + n_wire 1 ↕ zxBot ⟷ ⨉ + ⟷ (n_wire 1 ↕ zxTop). +Proof. + rewrite 2!swap_commutes_r, compose_assoc. + change 2%nat with (1 + 1)%nat. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + +Lemma swap_nat_bot_r_1 {p} + (zxBot : ZX 1 1) (zxTop : ZX 1 p) : + ⨉ ⟷ (zxTop ↕ zxBot) ∝ + zxBot ↕ n_wire 1 ⟷ ⨉ + ⟷ (zxTop ↕ n_wire 1). +Proof. + rewrite compose_assoc, 2!swap_commutes_l, <- compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + +Lemma swap_nat_top_r_1 {q} + (zxTop : ZX 1 1) (zxBot : ZX 1 q) : + ⨉ ⟷ (zxTop ↕ zxBot) ∝ + n_wire 1 ↕ zxTop ⟷ ⨉ + ⟷ (n_wire 1 ↕ zxBot). +Proof. + rewrite compose_assoc, 2!swap_commutes_l, <- compose_assoc. + rewrite <- stack_compose_distr. + now rewrite nwire_removal_l, nwire_removal_r. +Qed. + + + +Lemma zx_gap_comm_nat_top_l {n m o q r s} + (zx0 : ZX n q) (zx1 : ZX m r) (zx2 : ZX o s) : + zx0 ↕ zx1 ↕ zx2 ⟷ zx_gap_comm q r s ∝ + n_wire n ↕ zx1 ↕ zx2 ⟷ zx_gap_comm n r s + ⟷ (n_wire s ↕ n_wire r ↕ zx0). +Proof. + rewrite 2!zx_gap_comm_commutes_r, compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma zx_gap_comm_nat_mid_l {n m o q r s} + (zx1 : ZX m r) (zx0 : ZX n q) (zx2 : ZX o s) : + zx0 ↕ zx1 ↕ zx2 ⟷ zx_gap_comm q r s ∝ + zx0 ↕ n_wire m ↕ zx2 ⟷ zx_gap_comm q m s + ⟷ (n_wire s ↕ zx1 ↕ n_wire q). +Proof. + rewrite 2!zx_gap_comm_commutes_r, compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma zx_gap_comm_nat_bot_l {n m o q r s} + (zx2 : ZX o s) (zx0 : ZX n q) (zx1 : ZX m r) : + zx0 ↕ zx1 ↕ zx2 ⟷ zx_gap_comm q r s ∝ + zx0 ↕ zx1 ↕ n_wire o ⟷ zx_gap_comm q r o + ⟷ (zx2 ↕ n_wire r ↕ n_wire q). +Proof. + rewrite 2!zx_gap_comm_commutes_r, compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma zx_gap_comm_nat_top_r {n m o q r s} + (zx0 : ZX n q) (zx1 : ZX m r) (zx2 : ZX o s) : + zx_gap_comm _ _ _ ⟷ (zx0 ↕ zx1 ↕ zx2) ∝ + n_wire _ ↕ n_wire _ ↕ zx0 ⟷ zx_gap_comm _ _ _ + ⟷ (n_wire _ ↕ zx1 ↕ zx2). +Proof. + rewrite compose_assoc, 2!zx_gap_comm_commutes_l, + <- compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma zx_gap_comm_nat_mid_r {n m o q r s} + (zx1 : ZX m r) (zx0 : ZX n q) (zx2 : ZX o s) : + zx_gap_comm _ _ _ ⟷ (zx0 ↕ zx1 ↕ zx2) ∝ + n_wire _ ↕ zx1 ↕ n_wire _ ⟷ zx_gap_comm _ _ _ + ⟷ (zx0 ↕ n_wire _ ↕ zx2). +Proof. + rewrite compose_assoc, 2!zx_gap_comm_commutes_l, + <- compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma zx_gap_comm_nat_bot_r {n m o q r s} + (zx2 : ZX o s) (zx0 : ZX n q) (zx1 : ZX m r) : + zx_gap_comm _ _ _ ⟷ (zx0 ↕ zx1 ↕ zx2) ∝ + zx2 ↕ n_wire _ ↕ n_wire _ ⟷ zx_gap_comm _ _ _ + ⟷ (zx0 ↕ zx1 ↕ n_wire _). +Proof. + rewrite compose_assoc, 2!zx_gap_comm_commutes_l, + <- compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + + + +Lemma a_swap_nat_top_l {n m o r} + (zx0 : ZX n 1) (zx1 : ZX m r) (zx2 : ZX o 1) : + zx0 ↕ zx1 ↕ zx2 ⟷ a_swap (1 + r + 1) ∝ + n_wire n ↕ zx1 ↕ zx2 ⟷ zx_gap_comm n r 1 + ⟷ (n_wire 1 ↕ n_wire r ↕ zx0). +Proof. + rewrite a_swap_commutes_r, zx_gap_comm_commutes_r, + compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma a_swap_nat_mid_l {n m o r} + (zx0 : ZX n 1) (zx1 : ZX m r) (zx2 : ZX o 1) : + zx0 ↕ zx1 ↕ zx2 ⟷ a_swap (1 + r + 1) ∝ + zx0 ↕ n_wire m ↕ zx2 ⟷ a_swap (1 + m + 1) + ⟷ (n_wire 1 ↕ zx1 ↕ n_wire 1). +Proof. + rewrite 2!a_swap_commutes_r, compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma a_swap_nat_bot_l {n m o r} + (zx0 : ZX n 1) (zx1 : ZX m r) (zx2 : ZX o 1) : + zx0 ↕ zx1 ↕ zx2 ⟷ a_swap (1 + r + 1) ∝ + zx0 ↕ zx1 ↕ n_wire o ⟷ zx_gap_comm 1 r o + ⟷ (zx2 ↕ n_wire r ↕ n_wire 1). +Proof. + rewrite a_swap_commutes_r, zx_gap_comm_commutes_r, + compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma a_swap_nat_top_r {m q r s} + (zx0 : ZX 1 q) (zx1 : ZX m r) (zx2 : ZX 1 s) : + a_swap (1 + _ + 1) ⟷ (zx0 ↕ zx1 ↕ zx2) ∝ + n_wire _ ↕ n_wire _ ↕ zx0 ⟷ zx_gap_comm _ _ _ + ⟷ (n_wire _ ↕ zx1 ↕ zx2). +Proof. + rewrite compose_assoc, a_swap_commutes_l, zx_gap_comm_commutes_l, + <- compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma a_swap_nat_mid_r {m q r s} + (zx0 : ZX 1 q) (zx1 : ZX m r) (zx2 : ZX 1 s) : + a_swap (1 + _ + 1) ⟷ (zx0 ↕ zx1 ↕ zx2) ∝ + n_wire _ ↕ zx1 ↕ n_wire _ ⟷ a_swap (1 + _ + 1) + ⟷ (zx0 ↕ n_wire _ ↕ zx2). +Proof. + rewrite compose_assoc, 2!a_swap_commutes_l, + <- compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma a_swap_nat_bot_r {m q r s} + (zx0 : ZX 1 q) (zx1 : ZX m r) (zx2 : ZX 1 s) : + a_swap (1 + _ + 1) ⟷ (zx0 ↕ zx1 ↕ zx2) ∝ + zx2 ↕ n_wire _ ↕ n_wire _ ⟷ zx_gap_comm _ _ _ + ⟷ (zx0 ↕ zx1 ↕ n_wire _). +Proof. + rewrite compose_assoc, a_swap_commutes_l, zx_gap_comm_commutes_l, + <- compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + + + +Lemma a_swap_nat_top_l_1 {m o r} + (zx0 : ZX 1 1) (zx1 : ZX m r) (zx2 : ZX o 1) : + zx0 ↕ zx1 ↕ zx2 ⟷ a_swap (1 + r + 1) ∝ + n_wire 1 ↕ zx1 ↕ zx2 ⟷ a_swap (1 + _ + 1) + ⟷ (n_wire 1 ↕ n_wire r ↕ zx0). +Proof. + rewrite 2!a_swap_commutes_r, compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma a_swap_nat_bot_l_1 {n m r} + (zx0 : ZX n 1) (zx1 : ZX m r) (zx2 : ZX 1 1) : + zx0 ↕ zx1 ↕ zx2 ⟷ a_swap (1 + r + 1) ∝ + zx0 ↕ zx1 ↕ n_wire 1 ⟷ a_swap (1 + _ + 1) + ⟷ (zx2 ↕ n_wire r ↕ n_wire 1). +Proof. + rewrite 2!a_swap_commutes_r, compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma a_swap_nat_top_r_1 {m r s} + (zx0 : ZX 1 1) (zx1 : ZX m r) (zx2 : ZX 1 s) : + a_swap (1 + _ + 1) ⟷ (zx0 ↕ zx1 ↕ zx2) ∝ + n_wire _ ↕ n_wire _ ↕ zx0 ⟷ a_swap (1 + _ + 1) + ⟷ (n_wire _ ↕ zx1 ↕ zx2). +Proof. + rewrite compose_assoc, 2!a_swap_commutes_l, + <- compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. + +Lemma a_swap_nat_bot_r_1 {m q r} + (zx0 : ZX 1 q) (zx1 : ZX m r) (zx2 : ZX 1 1) : + a_swap (1 + _ + 1) ⟷ (zx0 ↕ zx1 ↕ zx2) ∝ + zx2 ↕ n_wire _ ↕ n_wire _ ⟷ a_swap (1 + _ + 1) + ⟷ (zx0 ↕ zx1 ↕ n_wire _). +Proof. + rewrite compose_assoc, 2!a_swap_commutes_l, + <- compose_assoc, <- !stack_compose_distr. + now rewrite ?nwire_removal_l, ?nwire_removal_r. +Qed. \ No newline at end of file From ddaa8185217bb722b10fcf9f05b27b3a6d9a6790 Mon Sep 17 00:00:00 2001 From: William Spencer Date: Sat, 20 Jul 2024 17:51:35 -0700 Subject: [PATCH 03/10] Fix build issues, add general permutation pullthrough result --- src/Permutations/PermMatrixFacts.v | 241 +++++++++++++++++++++++ src/Permutations/PermutationAutomation.v | 14 +- src/Permutations/PermutationFacts.v | 38 +++- src/Permutations/PermutationInstances.v | 6 - src/Permutations/PermutationSemantics.v | 78 ++++++++ 5 files changed, 366 insertions(+), 11 deletions(-) diff --git a/src/Permutations/PermMatrixFacts.v b/src/Permutations/PermMatrixFacts.v index 66da0ab..45dd5d2 100644 --- a/src/Permutations/PermMatrixFacts.v +++ b/src/Permutations/PermMatrixFacts.v @@ -610,3 +610,244 @@ Proof. apply perm_to_matrix_eq_of_perm_eq. now apply perm_to_matrix_perm_eq_of_proportional. Qed. + +Definition perm_eq_id_mid (padl padm : nat) (f : nat -> nat) : Prop := + forall a, a < padm -> f (padl + a) = padl + a. + +Lemma inv_perm_eq_id_mid {padl padm padr f} + (Hf : permutation (padl + padm + padr) f) + (Hfidn : perm_eq_id_mid padl padm f) : + forall k, k < padl + padm + padr -> + padl <= f k < padl + padm -> f k = k. +Proof. + intros k Hk []. + apply (permutation_is_injective _ _ Hf); [lia..|]. + replace (f k) with (padl + (f k - padl)) by lia. + (* unfold perm_eq_id_mid in Hfidn. *) + apply Hfidn; lia. +Qed. + +Definition expand_perm_id_mid (padl padm padr : nat) + (f : nat -> nat) : nat -> nat := + stack_perms padl (padm + padr) idn (rotr (padm + padr) padm) + ∘ (stack_perms (padl + padr) padm f idn) + ∘ stack_perms padl (padm + padr) idn (rotr (padm + padr) padr). + +Arguments compose_assoc [_ _ _ _]. + +Lemma expand_perm_id_mid_compose (f g : nat -> nat) (padl padm padr : nat) + (Hf : perm_bounded (padl + padr) f) + (Hg : perm_bounded (padl + padr) g) : + expand_perm_id_mid padl padm padr f ∘ expand_perm_id_mid padl padm padr g = + expand_perm_id_mid padl padm padr (f ∘ g). +Proof. + unfold expand_perm_id_mid. + (* cleanup_perm. *) + rewrite (compose_assoc _ (stack_perms _ _ idn (rotr _ padr))), + <- !(compose_assoc _ _ (stack_perms _ _ idn (rotr _ padr))). + cleanup_perm_inv. + cleanup_perm. + rewrite (Nat.add_comm padr padm). + cleanup_perm. + rewrite compose_assoc, <- (compose_assoc _ _ (stack_perms _ _ f _)). + cleanup_perm. +Qed. + +Lemma expand_perm_id_mid_eq_of_perm_eq {padl padr f g} + (Hfg : perm_eq (padl + padr) f g) padm : + expand_perm_id_mid padl padm padr f = expand_perm_id_mid padl padm padr g. +Proof. + unfold expand_perm_id_mid. + do 2 f_equal. + now apply stack_perms_proper_eq. +Qed. + +Lemma expand_perm_id_mid_permutation {padl padr f} + (Hf : permutation (padl + padr) f) padm : + permutation (padl + padm + padr) (expand_perm_id_mid padl padm padr f). +Proof. + unfold expand_perm_id_mid. + rewrite <- Nat.add_assoc. + apply permutation_compose; [|auto with perm_db]. + apply permutation_compose; [auto with perm_db|]. + replace (padl + (padm + padr)) with (padl + padr + padm) by lia. + auto with perm_db. +Qed. + +#[export] Hint Resolve expand_perm_id_mid_permutation : perm_db. + +Definition contract_perm_id_mid (padl padm padr : nat) + (f : nat -> nat) : nat -> nat := + stack_perms padl (padm + padr) idn (rotr (padm + padr) padr) ∘ + f ∘ stack_perms padl (padm + padr) idn (rotr (padm + padr) padm). + +Lemma contract_expand_perm_perm_eq_inv padl padm padr f + (Hf : perm_bounded (padl + padr) f) : + perm_eq (padl + padr) + (contract_perm_id_mid padl padm padr + (expand_perm_id_mid padl padm padr f)) + f. +Proof. + unfold contract_perm_id_mid, expand_perm_id_mid. + rewrite !compose_assoc. + cleanup_perm. + rewrite (Nat.add_comm padr padm). + rewrite <- !compose_assoc. + cleanup_perm. + rewrite (Nat.add_comm padr padm). + cleanup_perm. + intros k Hk. + now rewrite stack_perms_left by easy. +Qed. + +Lemma stack_perms_idn_compose n0 n1 f g + (Hg : perm_bounded n1 g) : + stack_perms n0 n1 idn (f ∘ g) = + stack_perms n0 n1 idn f ∘ stack_perms n0 n1 idn g. +Proof. + cleanup_perm. +Qed. + +Lemma stack_perms_compose_idn n0 n1 f g + (Hg : perm_bounded n0 g) : + stack_perms n0 n1 (f ∘ g) idn = + stack_perms n0 n1 f idn ∘ stack_perms n0 n1 g idn. +Proof. + cleanup_perm. +Qed. + +Lemma contract_perm_id_mid_compose {padl padm padr f} + (Hf : perm_bounded (padl + padm + padr) f) g : + contract_perm_id_mid padl padm padr g ∘ contract_perm_id_mid padl padm padr f = + contract_perm_id_mid padl padm padr (g ∘ f). +Proof. + unfold contract_perm_id_mid. + rewrite (compose_assoc _ (stack_perms _ _ idn (rotr _ padm))), + <- !(compose_assoc _ _ (stack_perms _ _ idn (rotr _ padm))). + cleanup_perm. +Qed. + +Lemma contract_perm_id_mid_permutation_big {padl padm padr f} + (Hf : permutation (padl + padm + padr) f) : + permutation (padl + padm + padr) (contract_perm_id_mid padl padm padr f). +Proof. + unfold contract_perm_id_mid. + rewrite <- Nat.add_assoc in *. + auto with perm_db. +Qed. + +Lemma permutation_of_le_permutation_idn_above n m f : + permutation n f -> m <= n -> (forall k, m <= k < n -> f k = k) -> + permutation m f. +Proof. + intros Hf Hm Hfid. + pose proof Hf as Hf'. + destruct Hf' as [finv Hfinv]. + exists finv. + intros k Hk; repeat split; try (apply Hfinv; lia). + - pose proof (Hfinv k ltac:(lia)) as (?&?&?&?). + bdestructΩ (f k (f (finv k)) in Hfid. + lia. +Qed. + +Lemma contract_perm_id_mid_permutation {padl padm padr f} + (Hf : permutation (padl + padm + padr) f) + (Hfid : perm_eq_id_mid padl padm f) : + permutation (padl + padr) (contract_perm_id_mid padl padm padr f). +Proof. + apply (permutation_of_le_permutation_idn_above _ _ _ + (contract_perm_id_mid_permutation_big Hf)); + [lia|]. + intros k []. + unfold contract_perm_id_mid. + unfold compose at 1. + rewrite stack_perms_right by lia. + rewrite rotr_add_l_eq. + do 2 simplify_bools_lia_one_kernel. + unfold compose. + rewrite (Nat.add_comm _ padl), Hfid by lia. + rewrite stack_perms_right by lia. + rewrite rotr_add_r_eq. + bdestructΩ'. +Qed. + +#[export] Hint Resolve contract_perm_id_mid_permutation_big + contract_perm_id_mid_permutation : perm_db. + + +Lemma expand_contract_perm_perm_eq_idn_inv {padl padm padr f} + (Hf : permutation (padl + padm + padr) f) + (Hfidn : perm_eq_id_mid padl padm f) : + perm_eq (padl + padm + padr) + ((expand_perm_id_mid padl padm padr + (contract_perm_id_mid padl padm padr f))) + f. +Proof. + unfold contract_perm_id_mid, expand_perm_id_mid. + (* rewrite rotr_add_l_eq, rotr_add_r_eq. + rewrite 2!stack_perms_idn_f, stack_perms_f_idn. *) + intros k Hk. + rewrite (stack_perms_idn_f _ _ (rotr _ padr)) at 2. + unfold compose at 1. + + simplify_bools_lia_one_kernel. + replace (if ¬ k (repeat first [rewrite cast_id_eq | rewrite cast_cast_eq]) : zxperm_db. @@ -884,6 +886,14 @@ Ltac show_term_nonzero term := match term with | 2 ^ ?a => exact (pow2_nonzero a) | ?a ^ ?b => exact (Nat.pow_nonzero a b ltac:(show_term_nonzero a)) + | ?a * ?b => + (assert (a <> 0) by (show_term_nonzero a); + assert (b <> 0) by (show_term_nonzero b); + lia) + | ?a + ?b => + ((assert (a <> 0) by (show_term_nonzero a) || + assert (b <> 0) by (show_term_nonzero b)); + lia) | _ => lia | _ => nia end. diff --git a/src/Permutations/PermutationFacts.v b/src/Permutations/PermutationFacts.v index 96b2df0..0f2d820 100644 --- a/src/Permutations/PermutationFacts.v +++ b/src/Permutations/PermutationFacts.v @@ -10,6 +10,12 @@ Open Scope nat. Open Scope prg. Open Scope perm_scope. +Lemma permutation_change_dims n m (H : n = m) f : + permutation n f <-> permutation m f. +Proof. + now subst. +Qed. + Lemma permutation_eqb_iff {n f} a b : permutation n f -> a < n -> b < n -> f a =? f b = (a =? b). @@ -1166,12 +1172,12 @@ Proof. solve_modular_permutation_equalities. Qed. #[export] Hint Rewrite stack_perms_idn_idn : perm_cleanup_db. Lemma stack_perms_compose {n0 n1} {f g} {f' g'} - (Hf' : permutation n0 f') (Hg' : permutation n1 g') : + (Hf' : perm_bounded n0 f') (Hg' : perm_bounded n1 g') : (stack_perms n0 n1 f g ∘ stack_perms n0 n1 f' g' = stack_perms n0 n1 (f ∘ f') (g ∘ g'))%prg. Proof. - destruct Hf' as [Hf'inv Hf']. - destruct Hg' as [Hg'inv Hg']. + (* destruct Hf' as [Hf'inv Hf']. *) + (* destruct Hg' as [Hg'inv Hg']. *) unfold compose. (* bdestruct_one. *) solve_modular_permutation_equalities. @@ -1181,6 +1187,9 @@ Proof. specialize (Hg' _ Hk); lia. Qed. +#[export] Hint Rewrite @stack_perms_compose + using auto with perm_db perm_bounded_db : perm_inv_db. + Lemma stack_perms_assoc {n0 n1 n2} {f g h} : stack_perms (n0 + n1) n2 (stack_perms n0 n1 f g) h = stack_perms n0 (n1 + n2) f (stack_perms n1 n2 g h). @@ -1202,6 +1211,10 @@ Proof. - rewrite Hg; lia. Qed. +#[export] Hint Resolve stack_perms_idn_of_left_right_idn + stack_perms_compose : perm_inv_db. + + Lemma contract_perm_bounded {n f} (Hf : perm_bounded n f) a : a < n -> @@ -1545,6 +1558,25 @@ Proof. lia. Qed. +Lemma rotr_add_n_l n k : + rotr n (n + k) = rotr n k. +Proof. + rewrite rotr_eq_rotr_mod. + rewrite Nat.add_comm, mod_add_n_r. + now rewrite <- rotr_eq_rotr_mod. +Qed. + +Lemma rotr_add_n_r n k : + rotr n (k + n) = rotr n k. +Proof. + rewrite rotr_eq_rotr_mod. + rewrite mod_add_n_r. + now rewrite <- rotr_eq_rotr_mod. +Qed. + +#[export] Hint Rewrite rotr_add_n_r rotr_add_n_l : perm_cleanup_db. + + Lemma reflect_perm_invol n k : reflect_perm n (reflect_perm n k) = k. diff --git a/src/Permutations/PermutationInstances.v b/src/Permutations/PermutationInstances.v index 46285d7..4bf9c47 100644 --- a/src/Permutations/PermutationInstances.v +++ b/src/Permutations/PermutationInstances.v @@ -190,12 +190,6 @@ Proof. perm_eq_by_inv_inj (stack_perms n m f g) (n+m). Qed. -#[export] Hint Resolve stack_perms_idn_of_left_right_idn - stack_perms_compose : perm_inv_db. -#[export] Hint Rewrite @stack_perms_compose - using auto with perm_db : perm_inv_db. - - Lemma stack_perms_proper {n0 n1} {f f' g g'} (Hf : perm_eq n0 f f') (Hg : perm_eq n1 g g') : diff --git a/src/Permutations/PermutationSemantics.v b/src/Permutations/PermutationSemantics.v index 9b43b38..4acb20e 100644 --- a/src/Permutations/PermutationSemantics.v +++ b/src/Permutations/PermutationSemantics.v @@ -12,6 +12,16 @@ Qed. #[export] Hint Rewrite perm_to_matrix_rotr_eq_kron_comm : perm_inv_db. +Lemma perm_to_matrix_rotr_eq_kron_comm_alt : forall n o, + perm_to_matrix (n + o) (rotr (n + o) o) = kron_comm (2^n) (2^o). +Proof. + intros n o. + rewrite Nat.add_comm. + cleanup_perm_inv. +Qed. + +#[export] Hint Rewrite perm_to_matrix_rotr_eq_kron_comm_alt : perm_inv_db. + Lemma perm_to_matrix_rotr_eq_kron_comm_mat_equiv : forall n o, perm_to_matrix (n + o) (rotr (n + o) n) ≡ kron_comm (2^o) (2^n). Proof. @@ -242,3 +252,71 @@ Proof. easy. Qed. +Lemma perm_to_matrix_pullthrough_middle_eq_idn padl padm padr padm' f + (Hf : permutation (padl + padm + padr) f) + (Hfid : perm_eq_id_mid padl padm f) + (A : Matrix (2^padm') (2^padm)) (HA : WF_Matrix A) : + @Mmult (2^padl*2^padm'*2^padr) (2^padl*2^padm*2^padr) (2^(padl+padm+padr)) + (I (2^padl) ⊗ A ⊗ I (2^padr)) (perm_to_matrix (padl + padm + padr) f) = + @Mmult (2^(padl+padm'+padr)) (2^padl*2^padm'*2^padr) (2^padl*2^padm*2^padr) + (perm_to_matrix (padl + padm' + padr) + (expand_perm_id_mid padl padm' padr + (contract_perm_id_mid padl padm padr f))) + (I (2^padl) ⊗ A ⊗ I (2^padr)). +Proof. + rewrite (perm_to_matrix_eq_of_perm_eq _ _ _ + (perm_eq_sym (expand_contract_perm_perm_eq_idn_inv Hf Hfid))). + unfold expand_perm_id_mid. + rewrite 4!perm_to_matrix_compose by + (erewrite permutation_change_dims; auto with perm_db zarith + || apply permutation_compose; + erewrite permutation_change_dims; auto with perm_db zarith). + replace (padl + padm + padr) with (padl + padr + padm) by lia. + rewrite perm_to_matrix_of_stack_perms by auto with perm_db. + replace (padl + padr + padm) with (padl + (padm + padr)) by lia. + rewrite !perm_to_matrix_of_stack_perms by auto with perm_db. + replace (padl + padm' + padr) with (padl + padr + padm') by lia. + rewrite perm_to_matrix_of_stack_perms by auto with perm_db. + replace (padl + padr + padm') with (padl + (padm' + padr)) by lia. + rewrite !perm_to_matrix_of_stack_perms by auto with perm_db. + + rewrite !perm_to_matrix_idn. + rewrite !perm_to_matrix_rotr_eq_kron_comm_alt, + !perm_to_matrix_rotr_eq_kron_comm. + unify_pows_two. + rewrite <- !Mmult_assoc. + rewrite !Nat.pow_add_r. + rewrite kron_assoc, <- 2!Nat.mul_assoc by auto with wf_db. + rewrite kron_mixed_product. + restore_dims. + (* replace (@Mmult (2 ^ padm' * 2 ^ padr) (2 ^ padm * 2 ^ padr) + (2 ^ padm * 2 ^ padr)) with + (@Mmult (2 ^ padm' * 2 ^ padr) (2 ^ padm * 2 ^ padr) + (2 ^ padr * 2 ^ padm)) by (f_equal; lia). *) + rewrite (kron_comm_commutes_r _ _ _ _ A (I (2^padr))) by auto with wf_db. + rewrite (Nat.mul_comm (2^padm) (2^padr)). + rewrite <- kron_mixed_product. + rewrite <- kron_assoc by auto with wf_db. + rewrite !Mmult_assoc. + f_equal. + restore_dims. + rewrite !Nat.pow_add_r. + rewrite <- (Mmult_assoc (_ ⊗ _ ⊗ A)). + rewrite kron_mixed_product. + rewrite Mmult_1_r by auto. + rewrite id_kron. + restore_dims. + rewrite Mmult_1_l, <- (Mmult_1_r _ _ (perm_to_matrix _ _)) by auto with wf_db. + rewrite <- (Mmult_1_l _ _ A) by auto. + rewrite <- kron_mixed_product. + rewrite Mmult_1_r, Mmult_1_l by auto with wf_db. + rewrite Mmult_assoc. + f_equal. + rewrite kron_mixed_product, kron_comm_commutes_l by auto with wf_db. + rewrite <- kron_mixed_product. + restore_dims. + rewrite <- kron_assoc by auto with wf_db. + rewrite Nat.pow_add_r, <- id_kron. + now restore_dims. +Qed. + From 80a4105668bfc2067a18f9cd4d9ec5d1f49dea6c Mon Sep 17 00:00:00 2001 From: William Spencer Date: Wed, 24 Jul 2024 22:57:19 -0700 Subject: [PATCH 04/10] Add Z/X absorbtion of ZXperms --- src/Permutations/PermutationSemantics.v | 5 - src/Permutations/ZXpermFacts.v | 233 +++++++++++++++++++++--- 2 files changed, 204 insertions(+), 34 deletions(-) diff --git a/src/Permutations/PermutationSemantics.v b/src/Permutations/PermutationSemantics.v index 4acb20e..58feb9a 100644 --- a/src/Permutations/PermutationSemantics.v +++ b/src/Permutations/PermutationSemantics.v @@ -279,7 +279,6 @@ Proof. rewrite perm_to_matrix_of_stack_perms by auto with perm_db. replace (padl + padr + padm') with (padl + (padm' + padr)) by lia. rewrite !perm_to_matrix_of_stack_perms by auto with perm_db. - rewrite !perm_to_matrix_idn. rewrite !perm_to_matrix_rotr_eq_kron_comm_alt, !perm_to_matrix_rotr_eq_kron_comm. @@ -289,10 +288,6 @@ Proof. rewrite kron_assoc, <- 2!Nat.mul_assoc by auto with wf_db. rewrite kron_mixed_product. restore_dims. - (* replace (@Mmult (2 ^ padm' * 2 ^ padr) (2 ^ padm * 2 ^ padr) - (2 ^ padm * 2 ^ padr)) with - (@Mmult (2 ^ padm' * 2 ^ padr) (2 ^ padm * 2 ^ padr) - (2 ^ padr * 2 ^ padm)) by (f_equal; lia). *) rewrite (kron_comm_commutes_r _ _ _ _ A (I (2^padr))) by auto with wf_db. rewrite (Nat.mul_comm (2^padm) (2^padr)). rewrite <- kron_mixed_product. diff --git a/src/Permutations/ZXpermFacts.v b/src/Permutations/ZXpermFacts.v index e6b2bb6..8e71e03 100644 --- a/src/Permutations/ZXpermFacts.v +++ b/src/Permutations/ZXpermFacts.v @@ -223,21 +223,21 @@ Qed. -Lemma perm_of_transpose_is_rinv {n} {zx} (H : ZXperm n zx) : +Lemma perm_of_zx_transpose_is_rinv {n} {zx} (H : ZXperm n zx) : (perm_of_zx zx ∘ perm_of_zx zx⊤)%prg = idn. Proof. cleanup_perm_of_zx. Qed. -Lemma perm_of_transpose_is_linv {n} {zx} (H : ZXperm n zx) : +Lemma perm_of_zx_transpose_is_linv {n} {zx} (H : ZXperm n zx) : (perm_of_zx zx⊤ ∘ perm_of_zx zx)%prg = idn. Proof. cleanup_perm_of_zx. Qed. #[export] Hint Rewrite - @perm_of_transpose_is_rinv - @perm_of_transpose_is_linv + @perm_of_zx_transpose_is_rinv + @perm_of_zx_transpose_is_linv using (auto with zxperm_db) : perm_of_zx_cleanup_db. Lemma perm_of_conjugate {n m} (zx : ZX n m) : @@ -280,6 +280,18 @@ Qed. #[export] Hint Rewrite perm_of_n_wire : perm_of_zx_cleanup_db. +Lemma zxperm_transpose_right_inverse {n zx} (H : ZXperm n zx) : + zx ⟷ zx ⊤ ∝ n_wire n. +Proof. + by_perm_eq. +Qed. + +Lemma zxperm_transpose_left_inverse {n zx} (H : ZXperm n zx) : + zx ⊤ ⟷ zx ∝ n_wire n. +Proof. + by_perm_eq. +Qed. + Lemma perm_of_zx_stack_n_wire_alt {n0} {zx} (H : ZXperm n0 zx) {n1} : perm_of_zx (zx ↕ (n_wire n1)) = perm_of_zx zx. Proof. @@ -894,30 +906,7 @@ Qed. Notation swap_commutes_l := swap_pullthrough_r. Notation swap_commutes_r := swap_pullthrough_l. -(* TODO: move *) -Lemma permutation_change_dims n m (H : n = m) f : - permutation n f <-> permutation m f. -Proof. - now subst. -Qed. - -Lemma rotr_add_n_l n k : - rotr n (n + k) = rotr n k. -Proof. - rewrite rotr_eq_rotr_mod. - rewrite Nat.add_comm, mod_add_n_r. - now rewrite <- rotr_eq_rotr_mod. -Qed. - -Lemma rotr_add_n_r n k : - rotr n (k + n) = rotr n k. -Proof. - rewrite rotr_eq_rotr_mod. - rewrite mod_add_n_r. - now rewrite <- rotr_eq_rotr_mod. -Qed. - -#[export] Hint Rewrite rotr_add_n_r rotr_add_n_l : perm_cleanup_db. +(* TODO: Move *) Lemma cast_compose_eq_mid_join n m o n' m' o' (Hn : n' = n) (Hm Hm' : m' = m) (Ho : o' = o) @@ -1434,4 +1423,190 @@ Proof. rewrite compose_assoc, 2!a_swap_commutes_l, <- compose_assoc, <- !stack_compose_distr. now rewrite ?nwire_removal_l, ?nwire_removal_r. -Qed. \ No newline at end of file +Qed. + +(* Section on X / Z absorbtion *) + +Import SwapRules ZXRules. + +Lemma X_cast_r_to_refl n m α {m' o' o} (zx : ZX m' o') Hm Ho : + X n m α ⟷ cast m o Hm Ho zx = + X n m' α ⟷ cast m' o eq_refl Ho zx. +Proof. + now subst. +Qed. + +Lemma X_cast_r_contract n m α {m' o' o} (zx : ZX m' o') Hm Ho : + X n m α ⟷ cast m o Hm Ho zx = + cast n o eq_refl Ho (X n m' α ⟷ zx). +Proof. + now subst. +Qed. + +Lemma Z_cast_r_to_refl n m α {m' o' o} (zx : ZX m' o') Hm Ho : + Z n m α ⟷ cast m o Hm Ho zx = + Z n m' α ⟷ cast m' o eq_refl Ho zx. +Proof. + now subst. +Qed. + +Lemma Z_cast_r_contract n m α {m' o' o} (zx : ZX m' o') Hm Ho : + Z n m α ⟷ cast m o Hm Ho zx = + cast n o eq_refl Ho (Z n m' α ⟷ zx). +Proof. + now subst. +Qed. + +Lemma X_stacked_a_swap_absorbtion_right n m0 m1 m2 α : + X n (m0 + m1 + m2) α ⟷ (n_wire m0 ↕ a_swap m1 ↕ n_wire m2) ∝ + X n (m0 + m1 + m2) α. +Proof. + (* rewrite grow_X_bot_right. *) + rewrite 2!X_add_r_base_rot, compose_assoc. + rewrite <- (nwire_removal_l (X 1 m2 0)). + rewrite stack_compose_distr, compose_assoc. + rewrite <- stack_compose_distr. + rewrite <- (stack_compose_distr (X 1 m0 0)). + rewrite 2!nwire_removal_r. + now rewrite X_a_swap_absorbtion_right_base. +Qed. + +Lemma Z_stacked_a_swap_absorbtion_right n m0 m1 m2 α : + Z n (m0 + m1 + m2) α ⟷ (n_wire m0 ↕ a_swap m1 ↕ n_wire m2) ∝ + Z n (m0 + m1 + m2) α. +Proof. + colorswap_of (X_stacked_a_swap_absorbtion_right n m0 m1 m2 α). +Qed. + +Lemma zxperm_colorswap_eq {n} (zx : ZX n n) (Hzx : ZXperm n zx) : + ⊙ zx = zx. +Proof. + induction Hzx; simpl; now f_equal. +Qed. + +Lemma colorswap_zx_to_bot a m : + ⊙ (zx_to_bot a m) ∝ zx_to_bot a m. +Proof. + now rewrite zxperm_colorswap_eq by auto with zxperm_db. +Qed. + +Lemma colorswap_zx_of_swap_list l : + ⊙ (zx_of_swap_list l) ∝ zx_of_swap_list l. +Proof. + now rewrite zxperm_colorswap_eq by auto with zxperm_db. +Qed. + +#[export] Hint Rewrite colorswap_zx_to_bot + colorswap_zx_of_swap_list : colorswap_db. + +Lemma X_zx_to_bot_absorbtion_right n m α a : + X n m α ⟷ zx_to_bot a m ∝ + X n m α. +Proof. + unfold zx_to_bot. + rewrite X_cast_r_contract. + rewrite grow_X_bot_right, compose_assoc, <- stack_compose_distr. + rewrite X_a_swap_absorbtion_right_base, nwire_removal_l. + rewrite <- grow_X_bot_right. + now simpl_casts. +Qed. + +Lemma Z_zx_to_bot_absorbtion_right n m α a : + Z n m α ⟷ zx_to_bot a m ∝ + Z n m α. +Proof. + colorswap_of (X_zx_to_bot_absorbtion_right n m α a). +Qed. + +Lemma X_zx_of_swap_list_absorbtion_right n α l : + X n (length l) α ⟷ zx_of_swap_list l ∝ + X n (length l) α. +Proof. + revert n α; + induction l; intros n α. + - simpl. + now cleanup_zx. + - simpl. + rewrite <- compose_assoc. + rewrite X_zx_to_bot_absorbtion_right. + rewrite X_cast_r_contract. + rewrite X_add_r_base_rot, compose_assoc. + rewrite <- (stack_compose_distr (X 1 (length l) 0)). + rewrite wire_removal_r, IHl. + rewrite <- X_add_r_base_rot. + now simpl_casts. +Qed. + +Lemma Z_zx_of_swap_list_absorbtion_right n α l : + Z n (length l) α ⟷ zx_of_swap_list l ∝ + Z n (length l) α. +Proof. + colorswap_of (X_zx_of_swap_list_absorbtion_right n α l). +Qed. + +Section Absorbtion. +(* This is a section only to localize the following hint, + which may be too costly to want to use globally *) + +Local Hint Rewrite @zxperm_colorswap_eq using auto with zxperm_db : + colorswap_db. + +Lemma X_zx_of_perm_absorbtion_right n m α f : + X n m α ⟷ zx_of_perm m f ∝ + X n m α. +Proof. + unfold zx_of_perm. + rewrite X_cast_r_contract. + unfold zx_of_perm_uncast. + rewrite X_zx_of_swap_list_absorbtion_right. + now simpl_casts. +Qed. + +Lemma Z_zx_of_perm_absorbtion_right n m α f : + Z n m α ⟷ zx_of_perm m f ∝ + Z n m α. +Proof. + colorswap_of (X_zx_of_perm_absorbtion_right n m α f). +Qed. + +Lemma X_zxperm_absorbtion_right n m α + (zx : ZX m m) (Hzx : ZXperm m zx) : + X n m α ⟷ zx ∝ + X n m α. +Proof. + rewrite <- (zx_of_perm_of_zx Hzx). + apply X_zx_of_perm_absorbtion_right. +Qed. + +Lemma Z_zxperm_absorbtion_right n m α + (zx : ZX m m) (Hzx : ZXperm m zx) : + Z n m α ⟷ zx ∝ + Z n m α. +Proof. + colorswap_of (X_zxperm_absorbtion_right n m α zx Hzx). +Qed. + +Lemma X_zxperm_absorbtion_left n m α + (zx : ZX n n) (Hzx : ZXperm n zx) : + zx ⟷ X n m α ∝ + X n m α. +Proof. + transpose_of (X_zxperm_absorbtion_right m n α + (zx⊤) (transpose_zxperm Hzx)). +Qed. + +Lemma Z_zxperm_absorbtion_left n m α + (zx : ZX n n) (Hzx : ZXperm n zx) : + zx ⟷ Z n m α ∝ + Z n m α. +Proof. + transpose_of (Z_zxperm_absorbtion_right m n α + (zx⊤) (transpose_zxperm Hzx)). +Qed. + +End Absorbtion. + + + + +zx_of_swap_list \ No newline at end of file From cd99a523a10e9962e50c05ac7406e4c3d44cd487 Mon Sep 17 00:00:00 2001 From: William Spencer Date: Wed, 24 Jul 2024 23:44:31 -0700 Subject: [PATCH 05/10] Add Z/X absorbtion of zx_comm, zx_gap_comm --- src/Permutations/ZXpermFacts.v | 181 ++++++++++++++++++++++++++++----- 1 file changed, 156 insertions(+), 25 deletions(-) diff --git a/src/Permutations/ZXpermFacts.v b/src/Permutations/ZXpermFacts.v index 8e71e03..f8e2567 100644 --- a/src/Permutations/ZXpermFacts.v +++ b/src/Permutations/ZXpermFacts.v @@ -267,6 +267,11 @@ Qed. #[export] Hint Rewrite @perm_of_adjoint using (auto with zxperm_db) : perm_of_zx_cleanup_db. +Lemma zxperm_colorswap_eq {n} (zx : ZX n n) (Hzx : ZXperm n zx) : + ⊙ zx = zx. +Proof. + induction Hzx; simpl; now f_equal. +Qed. (* Section on specific values of perm_of_zx *) @@ -491,6 +496,21 @@ Qed. #[export] Hint Rewrite perm_of_zx_of_swap_list using auto with perm_db : perm_of_zx_cleanup_db. +Lemma colorswap_zx_to_bot a m : + ⊙ (zx_to_bot a m) ∝ zx_to_bot a m. +Proof. + now rewrite zxperm_colorswap_eq by auto with zxperm_db. +Qed. + +Lemma colorswap_zx_of_swap_list l : + ⊙ (zx_of_swap_list l) ∝ zx_of_swap_list l. +Proof. + now rewrite zxperm_colorswap_eq by auto with zxperm_db. +Qed. + +#[export] Hint Rewrite colorswap_zx_to_bot + colorswap_zx_of_swap_list : colorswap_db. + Lemma perm_of_zx_uncast_of_perm_eq n f : permutation n f -> perm_eq n (perm_of_zx (zx_of_perm_uncast n f)) f. Proof. @@ -830,8 +850,6 @@ Lemma zx_comm_semantics p q : Proof. unfold zx_comm. cleanup_perm_of_zx. - (* simpl_zx_of_perm_semantics. - rewrite zx_of_perm_casted_semantics. *) Qed. #[export] Hint Rewrite zx_comm_semantics : perm_of_zx_cleanup_db. @@ -851,6 +869,34 @@ Qed. #[export] Hint Rewrite zx_comm_cancel : perm_of_zx_cleanup_db. +Lemma zx_comm_transpose p q : + (zx_comm p q) ⊤ ∝ zx_comm q p. +Proof. + unfold zx_comm. + simpl_casts. + rewrite <- cast_transpose, cast_zx_of_perm. + by_perm_eq. + rewrite Nat.add_comm. + rewrite perm_of_zx_of_perm_eq_WF by cleanup_perm. + cleanup_perm. + perm_eq_by_inv_inj (rotr (p + q) p) (p + q). + cleanup_perm. + rewrite Nat.add_comm. + cleanup_perm. +Qed. + +#[export] Hint Rewrite zx_comm_transpose : transpose_db. + +Lemma zx_comm_colorswap p q : + ⊙ (zx_comm p q) ∝ zx_comm p q. +Proof. + unfold zx_comm. + simpl_casts. + now rewrite zxperm_colorswap_eq by auto with zxperm_db. +Qed. + +#[export] Hint Rewrite zx_comm_colorswap : colorswap_db. + Lemma zx_comm_commutes_l {n m p q} (zx0 : ZX n m) (zx1 : ZX p q) : zx_comm p n ⟷ (zx0 ↕ zx1) ∝ (zx1 ↕ zx0) ⟷ zx_comm q m. @@ -1033,6 +1079,53 @@ Proof. now apply cast_simplify. Qed. +Lemma zx_gap_comm_transpose p m q : + (zx_gap_comm p m q) ⊤ ∝ zx_gap_comm q m p. +Proof. + rewrite 2!zx_gap_comm_defn. + simpl_casts. + rewrite <- cast_transpose, cast_zx_of_perm. + by_perm_eq. + replace (q + m + p) with (p + m + q) by lia. + pose proof (fun f => proj2 (permutation_change_dims + (p + m + q) (q + (p + m)) ltac:(lia) f)). + pose proof (fun f => proj2 (permutation_change_dims + (p + m + q) (p + (q + m)) ltac:(lia) f)). + rewrite 2!perm_of_zx_of_perm_eq_WF; auto with perm_db; + [|apply compose_WF_Perm; [auto with WF_Perm_db|]..]; + [|replace (p+m+q) with (p+(q+m)) by lia + | replace (p+m+q) with (q+(p+m)) by lia]; + [|auto with WF_Perm_db..]. + perm_eq_by_inv_inj (rotr (p + m + q) (p + m) + ∘ stack_perms q (p + m) idn (rotr (p + m) p)) (p + m + q). + replace (p + m + q) with ((q + m) + p) by lia. + rewrite <- stack_perms_rotr_natural by cleanup_perm. + replace (q + m + p) with (p + m + q) by lia. + rewrite <- stack_perms_rotr_natural by cleanup_perm. + cleanup_perm. + rewrite 3!rotr_add_l_eq. + replace (p + m + q) with (q + m + p) by lia. + rewrite rotr_add_l_eq. + rewrite <- !compose_assoc. + intros k Hk. + unfold compose at 1. + simplify_bools_lia_one_kernel. + repeat (bdestructΩ'; unfold compose at 1). +Qed. + +#[export] Hint Rewrite zx_gap_comm_transpose : transpose_db. + +Lemma zx_gap_comm_colorswap p m q : + ⊙ (zx_gap_comm p m q) ∝ zx_gap_comm p m q. +Proof. + unfold zx_gap_comm. + simpl_casts. + simpl. + now autorewrite with colorswap_db. +Qed. + +#[export] Hint Rewrite zx_gap_comm_colorswap : colorswap_db. + Import ComposeRules StackComposeRules CastRules. Lemma zx_gap_comm_pullthrough_l {n m r s p q} @@ -1478,27 +1571,6 @@ Proof. colorswap_of (X_stacked_a_swap_absorbtion_right n m0 m1 m2 α). Qed. -Lemma zxperm_colorswap_eq {n} (zx : ZX n n) (Hzx : ZXperm n zx) : - ⊙ zx = zx. -Proof. - induction Hzx; simpl; now f_equal. -Qed. - -Lemma colorswap_zx_to_bot a m : - ⊙ (zx_to_bot a m) ∝ zx_to_bot a m. -Proof. - now rewrite zxperm_colorswap_eq by auto with zxperm_db. -Qed. - -Lemma colorswap_zx_of_swap_list l : - ⊙ (zx_of_swap_list l) ∝ zx_of_swap_list l. -Proof. - now rewrite zxperm_colorswap_eq by auto with zxperm_db. -Qed. - -#[export] Hint Rewrite colorswap_zx_to_bot - colorswap_zx_of_swap_list : colorswap_db. - Lemma X_zx_to_bot_absorbtion_right n m α a : X n m α ⟷ zx_to_bot a m ∝ X n m α. @@ -1606,7 +1678,66 @@ Qed. End Absorbtion. +Lemma X_zx_comm_absorbtion_right n p q α : + X n (p + q) α ⟷ zx_comm p q ∝ + X n (q + p) α. +Proof. + unfold zx_comm. + rewrite X_cast_r_contract, X_zx_of_perm_absorbtion_right. + now simpl_casts. +Qed. + +Lemma Z_zx_comm_absorbtion_right n p q α : + Z n (p + q) α ⟷ zx_comm p q ∝ + Z n (q + p) α. +Proof. + colorswap_of (X_zx_comm_absorbtion_right n p q α). +Qed. - +Lemma X_zx_comm_absorbtion_left p q m α : + zx_comm p q ⟷ X (q + p) m α ∝ + X (p + q) m α. +Proof. + transpose_of (X_zx_comm_absorbtion_right m q p α). +Qed. -zx_of_swap_list \ No newline at end of file +Lemma Z_zx_comm_absorbtion_left p q m α : + zx_comm p q ⟷ Z (q + p) m α ∝ + Z (p + q) m α. +Proof. + colorswap_of (X_zx_comm_absorbtion_left p q m α). +Qed. + +Lemma X_zx_gap_comm_absorbtion_right n p m q α : + X n (p + m + q) α ⟷ zx_gap_comm p m q ∝ + X n (q + m + p) α. +Proof. + unfold zx_gap_comm. + rewrite X_cast_r_contract. + rewrite <- compose_assoc, X_zx_comm_absorbtion_right. + rewrite grow_X_bot_right, compose_assoc, <- stack_nwire_distribute_l. + rewrite X_zx_comm_absorbtion_right. + rewrite <- grow_X_bot_right. + now simpl_casts. +Qed. + +Lemma Z_zx_gap_comm_absorbtion_right n p m q α : + Z n (p + m + q) α ⟷ zx_gap_comm p m q ∝ + Z n (q + m + p) α. +Proof. + colorswap_of (X_zx_gap_comm_absorbtion_right n p m q α). +Qed. + +Lemma X_zx_gap_comm_absorbtion_left p n q m α : + zx_gap_comm p n q ⟷ X (q + n + p) m α ∝ + X (p + n + q) m α. +Proof. + transpose_of (X_zx_gap_comm_absorbtion_right m q n p α). +Qed. + +Lemma Z_zx_gap_comm_absorbtion_left p n q m α : + zx_gap_comm p n q ⟷ Z (q + n + p) m α ∝ + Z (p + n + q) m α. +Proof. + colorswap_of (X_zx_gap_comm_absorbtion_left p n q m α). +Qed. From 451871cd418ef73fabec503bae77543124206138 Mon Sep 17 00:00:00 2001 From: William Spencer Date: Mon, 29 Jul 2024 12:48:31 -0700 Subject: [PATCH 06/10] Bump QuantumLib requirement to >=1.5.0 --- coq-vyzx.opam | 2 +- dune-project | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/coq-vyzx.opam b/coq-vyzx.opam index 3f1cf83..29ea585 100644 --- a/coq-vyzx.opam +++ b/coq-vyzx.opam @@ -13,7 +13,7 @@ homepage: "https://github.com/inQWIRE/VyZX" bug-reports: "https://github.com/inQWIRE/VyZX/issues" depends: [ "dune" {>= "2.8"} - "coq-quantumlib" {>= "1.3.0"} + "coq-quantumlib" {>= "1.5.0"} "coq-sqir" {>= "1.3.0"} "coq-voqc" {>= "1.3.0"} "coq" {>= "8.16"} diff --git a/dune-project b/dune-project index 4415ddb..06c27b3 100644 --- a/dune-project +++ b/dune-project @@ -18,7 +18,7 @@ ) (depends - (coq-quantumlib (>= 1.3.0)) + (coq-quantumlib (>= 1.5.0)) (coq-sqir (>= 1.3.0)) (coq-voqc (>= 1.3.0)) (coq (>= 8.16)))) From 676d80b3b1d25f065024aaf3bed74d4751fd25f4 Mon Sep 17 00:00:00 2001 From: William Spencer Date: Tue, 20 Aug 2024 13:27:20 -0700 Subject: [PATCH 07/10] Improve permutations, much small proof repair and improvement, including to use new ZXperm machinery --- src/CoreData/QlibTemp.v | 485 ----- src/CoreData/SemanticCore.v | 381 ++-- src/CoreData/ZXCore.v | 61 +- src/CoreRules/CapCupRules.v | 52 +- src/CoreRules/CastRules.v | 44 +- src/CoreRules/CoreAutomation.v | 9 +- src/CoreRules/SpiderInduction.v | 253 +-- src/CoreRules/SwapRules.v | 369 +--- src/CoreRules/WireRules.v | 89 +- src/CoreRules/XRules.v | 76 + src/CoreRules/ZRules.v | 271 ++- src/CoreRules/ZXRules.v | 90 +- src/DiagramRules/Bell.v | 27 +- src/DiagramRules/Bialgebra.v | 124 +- src/DiagramRules/Completeness.v | 37 +- src/DiagramRules/CompletenessComp.v | 24 +- src/Gates/GateRules.v | 227 +- src/Ingest/Ingest.v | 98 +- src/Permutations/KronComm.v | 2337 --------------------- src/Permutations/MatEquivSetoid.v | 382 ---- src/Permutations/PermMatrixFacts.v | 853 -------- src/Permutations/PermutationAutomation.v | 1475 ------------- src/Permutations/PermutationAuxiliary.v | 1514 ------------- src/Permutations/PermutationDefinitions.v | 91 - src/Permutations/PermutationFacts.v | 1829 ---------------- src/Permutations/PermutationInstances.v | 896 -------- src/Permutations/PermutationRules.v | 9 - src/Permutations/PermutationSemantics.v | 317 --- src/Permutations/ZXperm.v | 2 +- src/Permutations/ZXpermAutomation.v | 231 ++ src/Permutations/ZXpermFacts.v | 476 ++--- src/Permutations/ZXpermSemantics.v | 33 +- src/Quarantine.v | 21 +- 33 files changed, 1630 insertions(+), 11553 deletions(-) delete mode 100644 src/CoreData/QlibTemp.v delete mode 100644 src/Permutations/KronComm.v delete mode 100644 src/Permutations/MatEquivSetoid.v delete mode 100644 src/Permutations/PermMatrixFacts.v delete mode 100644 src/Permutations/PermutationAutomation.v delete mode 100644 src/Permutations/PermutationAuxiliary.v delete mode 100644 src/Permutations/PermutationDefinitions.v delete mode 100644 src/Permutations/PermutationFacts.v delete mode 100644 src/Permutations/PermutationInstances.v delete mode 100644 src/Permutations/PermutationRules.v delete mode 100644 src/Permutations/PermutationSemantics.v create mode 100644 src/Permutations/ZXpermAutomation.v diff --git a/src/CoreData/QlibTemp.v b/src/CoreData/QlibTemp.v deleted file mode 100644 index 10eac0d..0000000 --- a/src/CoreData/QlibTemp.v +++ /dev/null @@ -1,485 +0,0 @@ -From QuantumLib Require Import Matrix. -From QuantumLib Require Import Quantum. - -(* @nocheck name *) -Lemma Mscale_inv : forall {n m} (A B : Matrix n m) c, c <> C0 -> c .* A = B <-> A = (/ c) .* B. -Proof. - intros. - split; intro H0; [rewrite <- H0 | rewrite H0]; - rewrite Mscale_assoc. - - rewrite Cinv_l; [ lma | assumption]. - - rewrite Cinv_r; [ lma | assumption]. -Qed. - -(* @nocheck name *) -Lemma Ropp_lt_0 : forall x : R, x < 0 -> 0 < -x. -Proof. - intros. - rewrite <- Ropp_0. - apply Ropp_lt_contravar. - easy. -Qed. - -(* @nocheck name *) -Definition Rsqrt (x : R) :C := -match Rcase_abs x with -| left a => Ci * Rsqrt {| nonneg := - x; cond_nonneg := Rlt_le 0 (-x)%R (Ropp_lt_0 x a) |} -| right a => C1 * Rsqrt {| nonneg := x; cond_nonneg := Rge_le x R0 a |} -end. - -(* @nocheck name *) -(* *) -Lemma INR_pi_exp : forall (r : nat), - Cexp (INR r * PI) = 1 \/ Cexp (INR r * PI) = -1. -Proof. - intros. - dependent induction r. - - simpl. - rewrite Rmult_0_l. - left. - apply Cexp_0. - - rewrite S_O_plus_INR. - rewrite Rmult_plus_distr_r. - rewrite Rmult_1_l. - rewrite Rplus_comm. - rewrite Cexp_plus_PI. - destruct IHr. - + rewrite H; right; lca. - + rewrite H; left; lca. -Qed. - -Lemma transpose_matrices : forall {n m} (A B : Matrix n m), - A ⊤ = B ⊤ -> A = B. -Proof. - intros. - rewrite <- transpose_involutive. - rewrite <- H. - rewrite transpose_involutive. - easy. -Qed. - -Lemma adjoint_matrices : forall {n m} (A B : Matrix n m), - A † = B † -> A = B. -Proof. - intros. - rewrite <- adjoint_involutive. - rewrite <- H. - rewrite adjoint_involutive. - easy. -Qed. - - -Lemma kron_id_dist_r : forall {n m o} p (A : Matrix n m) (B : Matrix m o), -WF_Matrix A -> WF_Matrix B -> (A × B) ⊗ (I p) = (A ⊗ (I p)) × (B ⊗ (I p)). -Proof. - intros. - rewrite <- (Mmult_1_l _ _ (I p)). - rewrite kron_mixed_product. - Msimpl. - easy. - auto with wf_db. -Qed. - -Lemma kron_id_dist_l : forall {n m o} p (A : Matrix n m) (B : Matrix m o), -WF_Matrix A -> WF_Matrix B -> (I p) ⊗ (A × B) = ((I p) ⊗ A) × ((I p) ⊗ B). -Proof. - intros. - rewrite <- (Mmult_1_l _ _ (I p)). - rewrite kron_mixed_product. - Msimpl. - easy. - auto with wf_db. -Qed. - -Lemma swap_transpose : swap ⊤%M = swap. -Proof. lma. Qed. - -Lemma swap_spec' : swap = ((ket 0 × bra 0) ⊗ (ket 0 × bra 0) .+ (ket 0 × bra 1) ⊗ (ket 1 × bra 0) - .+ (ket 1 × bra 0) ⊗ (ket 0 × bra 1) .+ (ket 1 × bra 1) ⊗ (ket 1 × bra 1)). -Proof. - solve_matrix. -Qed. - -Lemma xbasis_plus_spec : ∣+⟩ = / √ 2 .* (∣0⟩ .+ ∣1⟩). -Proof. solve_matrix. Qed. - -Lemma xbasis_minus_spec : ∣-⟩ = / √ 2 .* (∣0⟩ .+ (- 1) .* (∣1⟩)). -Proof. solve_matrix. Qed. - -Definition braminus := / √ 2 .* (⟨0∣ .+ (-1 .* ⟨1∣)). -Definition braplus := / √ 2 .* (⟨0∣ .+ ⟨1∣). - -Notation "⟨+∣" := braplus. -Notation "⟨-∣" := braminus. - -Lemma WF_braplus : WF_Matrix (⟨+∣). -Proof. unfold braplus; auto with wf_db. Qed. - -Lemma WF_braminus : WF_Matrix (⟨-∣). -Proof. unfold braminus; auto with wf_db. Qed. - -Lemma braplus_transpose_ketplus : - ⟨+∣⊤ = ∣+⟩. -Proof. unfold braplus; lma. Qed. - -Lemma braminus_transpose_ketminus : - ⟨-∣⊤ = ∣-⟩. -Proof. unfold braminus; lma. Qed. - -(* @nocheck name *) -(* PI is captialized in Coq R *) -Lemma Cexp_2_PI : forall a, Cexp (INR a * 2 * PI) = 1. -Proof. - intros. - induction a. - - simpl. - rewrite 2 Rmult_0_l. - rewrite Cexp_0. - easy. - - rewrite S_INR. - rewrite 2 Rmult_plus_distr_r. - rewrite Rmult_1_l. - rewrite double. - rewrite <- Rplus_assoc. - rewrite 2 Cexp_plus_PI. - rewrite IHa. - lca. -Qed. - -#[export] Hint Resolve - WF_braplus - WF_braminus : wf_db. - -#[export] Hint Rewrite - Mscale_kron_dist_l - Mscale_kron_dist_r - Mscale_mult_dist_l - Mscale_mult_dist_r - Mscale_assoc : scalar_move_db. - -#[export] Hint Rewrite <- Mscale_plus_distr_l : scalar_move_db. -#[export] Hint Rewrite <- Mscale_plus_distr_r : scalar_move_db. - -(* @nocheck name *) -Definition Csqrt (z : C) : C := - match z with - | (a, b) => sqrt ((Cmod z + a) / 2) + Ci * (b / Rabs b) * sqrt((Cmod z - a) / 2) - end. - -Notation "√ z" := (Csqrt z) : C_scope. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmultplus0 : - ⟨+∣ × ∣0⟩ = / (√2)%R .* I 1. -Proof. - unfold braplus. - rewrite Mscale_mult_dist_l. - rewrite Mmult_plus_distr_r. - rewrite Mmult00. - rewrite Mmult10. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmult0plus : - ⟨0∣ × ∣+⟩ = / (√2)%R .* I 1. -Proof. - unfold xbasis_plus. - rewrite Mscale_mult_dist_r. - rewrite Mmult_plus_distr_l. - rewrite Mmult00. - rewrite Mmult01. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmultplus1 : - ⟨+∣ × ∣1⟩ = / (√2)%R .* I 1. -Proof. - unfold braplus. - rewrite Mscale_mult_dist_l. - rewrite Mmult_plus_distr_r. - rewrite Mmult01. - rewrite Mmult11. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmult1plus : - ⟨1∣ × ∣+⟩ = / (√2)%R .* I 1. -Proof. - unfold xbasis_plus. - rewrite Mscale_mult_dist_r. - rewrite Mmult_plus_distr_l. - rewrite Mmult10. - rewrite Mmult11. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmultminus0 : - ⟨-∣ × ∣0⟩ = / (√2)%R .* I 1. -Proof. - unfold braminus. - rewrite Mscale_mult_dist_l. - rewrite Mmult_plus_distr_r. - rewrite Mmult00. - rewrite Mscale_mult_dist_l. - rewrite Mmult10. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmult0minus : - ⟨0∣ × ∣-⟩ = / (√2)%R .* I 1. -Proof. - unfold xbasis_minus. - rewrite Mscale_mult_dist_r. - rewrite Mmult_plus_distr_l. - rewrite Mmult00. - rewrite Mscale_mult_dist_r. - rewrite Mmult01. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmultminus1 : - ⟨-∣ × ∣1⟩ = - / (√2)%R .* I 1. -Proof. - unfold braminus. - rewrite Mscale_mult_dist_l. - rewrite Mmult_plus_distr_r. - rewrite Mmult01. - rewrite Mscale_mult_dist_l. - rewrite Mmult11. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmult1minus : - ⟨1∣ × ∣-⟩ = - / (√2)%R .* I 1. -Proof. - unfold xbasis_minus. - rewrite Mscale_mult_dist_r. - rewrite Mmult_plus_distr_l. - rewrite Mmult10. - rewrite Mscale_mult_dist_r. - rewrite Mmult11. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmultminusminus : - ⟨-∣ × ∣-⟩ = I 1. -Proof. - unfold braminus. - unfold xbasis_minus. - repeat rewrite Mscale_mult_dist_l. - repeat rewrite Mscale_mult_dist_r. - repeat rewrite Mmult_plus_distr_r. - repeat rewrite Mmult_plus_distr_l. - autorewrite with scalar_move_db. - rewrite Mmult00. - rewrite Mmult01. - rewrite Mmult10. - rewrite Mmult11. - Msimpl. - autorewrite with scalar_move_db. - solve_matrix. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmultplusminus : - ⟨+∣ × ∣-⟩ = Zero. -Proof. - unfold xbasis_minus. - unfold braplus. - repeat rewrite Mscale_mult_dist_l. - repeat rewrite Mscale_mult_dist_r. - repeat rewrite Mmult_plus_distr_r. - repeat rewrite Mmult_plus_distr_l. - autorewrite with scalar_move_db. - rewrite Mmult00. - rewrite Mmult01. - rewrite Mmult10. - rewrite Mmult11. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmultminusplus : - ⟨-∣ × ∣+⟩ = Zero. -Proof. - unfold xbasis_plus. - unfold braminus. - repeat rewrite Mscale_mult_dist_l. - repeat rewrite Mscale_mult_dist_r. - repeat rewrite Mmult_plus_distr_r. - repeat rewrite Mmult_plus_distr_l. - autorewrite with scalar_move_db. - rewrite Mmult00. - rewrite Mmult01. - rewrite Mmult10. - rewrite Mmult11. - Msimpl. - lma. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mmultplusplus : - ⟨+∣ × ∣+⟩ = I 1. -Proof. - unfold xbasis_plus. - unfold braplus. - repeat rewrite Mscale_mult_dist_l. - repeat rewrite Mscale_mult_dist_r. - repeat rewrite Mmult_plus_distr_r. - repeat rewrite Mmult_plus_distr_l. - autorewrite with scalar_move_db. - rewrite Mmult00. - rewrite Mmult01. - rewrite Mmult10. - rewrite Mmult11. - solve_matrix. -Qed. - -#[export] Hint Rewrite - Mmult00 Mmult01 Mmult10 Mmult11 - Mmultplus0 Mmultplus1 Mmultminus0 Mmultminus1 - Mmult0plus Mmult0minus Mmult1plus Mmult1minus - Mmultplusplus Mmultplusminus Mmultminusplus Mmultminusminus - : ketbra_mult_db. - -Lemma bra0transpose : - ⟨0∣⊤ = ∣0⟩. -Proof. solve_matrix. Qed. - -Lemma bra1transpose : - ⟨1∣⊤ = ∣1⟩. -Proof. solve_matrix. Qed. - -Lemma ket0transpose : - ∣0⟩⊤ = ⟨0∣. -Proof. solve_matrix. Qed. - -Lemma ket1transpose : - ∣1⟩⊤ = ⟨1∣. -Proof. solve_matrix. Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mplus_plus_minus : ∣+⟩ .+ ∣-⟩ = (√2)%R .* ∣0⟩. -Proof. - unfold xbasis_plus. - unfold xbasis_minus. - solve_matrix. - C_field. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mplus_plus_minus_opp : ∣+⟩ .+ -1 .* ∣-⟩ = (√2)%R .* ∣1⟩. -Proof. - unfold xbasis_plus. - unfold xbasis_minus. - solve_matrix. - C_field_simplify. - lca. - C_field. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mplus_minus_plus : ∣-⟩ .+ ∣+⟩ = (√2)%R .* ∣0⟩. -Proof. - unfold xbasis_plus. - unfold xbasis_minus. - solve_matrix. - C_field. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mplus_minus_opp_plus : -1 .* ∣-⟩ .+ ∣+⟩ = (√2)%R .* ∣1⟩. -Proof. - unfold xbasis_plus. - unfold xbasis_minus. - solve_matrix. - C_field_simplify. - lca. - C_field. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mplus_0_1 : ∣0⟩ .+ ∣1⟩ = (√2)%R .* ∣+⟩. -Proof. - unfold xbasis_plus. - unfold xbasis_minus. - solve_matrix. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mplus_0_1_opp : ∣0⟩ .+ -1 .* ∣1⟩ = (√2)%R .* ∣-⟩. -Proof. - unfold xbasis_plus. - unfold xbasis_minus. - solve_matrix. - C_field_simplify. - lca. - C_field. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mplus_1_0 : ∣1⟩ .+ ∣0⟩ = (√2)%R .* ∣+⟩. -Proof. - unfold xbasis_plus. - unfold xbasis_minus. - solve_matrix. -Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Mplus_1_opp_0 : -1 .* ∣1⟩ .+ ∣0⟩ = (√2)%R .* ∣-⟩. -Proof. - unfold xbasis_plus. - unfold xbasis_minus. - solve_matrix. - C_field_simplify. - lca. - C_field. -Qed. - -Lemma σz_decomposition : σz = ∣0⟩⟨0∣ .+ -1 .* ∣1⟩⟨1∣. -Proof. solve_matrix. Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Cexp_spec : forall α, Cexp α = cos α + Ci * sin α. -Proof. intros; lca. Qed. - -(* @nocheck name *) -(* Conventional name *) -Lemma Cexp_minus : forall θ, - Cexp θ + Cexp (-θ) = 2 * cos θ. -Proof. - intros. - unfold Cexp. - rewrite cos_neg. - rewrite sin_neg. - lca. -Qed. \ No newline at end of file diff --git a/src/CoreData/SemanticCore.v b/src/CoreData/SemanticCore.v index 418ed36..fb00ac2 100644 --- a/src/CoreData/SemanticCore.v +++ b/src/CoreData/SemanticCore.v @@ -6,7 +6,6 @@ and well formedness Require Export QuantumLib.Quantum. Require Import QuantumLib.Proportional. Require Export QuantumLib.VectorStates. -Require Export QlibTemp. (* Sparse Matrix Definition *) @@ -96,7 +95,7 @@ Proof. distribute_adjoint. rewrite Z_semantics_adj. rewrite 2 kron_n_adjoint; try auto with wf_db. - rewrite hadamard_sa. + rewrite hadamard_hermitian_rw. rewrite Mmult_assoc. reflexivity. Qed. @@ -236,8 +235,8 @@ Proof. induction n; [reflexivity | ]. rewrite kron_n_assoc; [ | auto with wf_db]. unfold kron. - rewrite 2 Nat.div_0_l; try apply Nat.pow_nonzero; try easy. - rewrite 2 Nat.mod_0_l; try apply Nat.pow_nonzero; try easy. + rewrite 2 Nat.Div0.div_0_l. + rewrite 2 Nat.Div0.mod_0_l. rewrite IHn. rewrite Cmult_1_r. unfold bra. @@ -256,28 +255,20 @@ Proof. rewrite kron_n_assoc; [| auto with wf_db]. unfold kron. destruct (S j mod 2 ^S n) eqn:En. - + destruct (Nat.mod_divides (S j) (2 ^ S n)); - [apply Nat.pow_nonzero; auto |]. + + destruct (Nat.Div0.mod_divides (S j) (2 ^ S n)). destruct (H En). rewrite H1. replace (2 ^ S n * x / 2 ^ S n)%nat with x. * unfold bra; simpl. unfold adjoint. simpl. - destruct x. - -- rewrite Nat.mul_0_r in H1. - discriminate H1. - -- destruct (i / (1 ^ n + 0))%nat. - ++ simpl. - destruct x; lca. - ++ simpl. - destruct x; lca. + destruct x; + [now rewrite Nat.mul_0_r in H1|]. + destruct (i / (1 ^ n + 0))%nat; + simpl; destruct x; lca. * rewrite Nat.mul_comm. - rewrite Nat.divide_div_mul_exact. - -- rewrite Nat.div_same; [lia | ]. - apply Nat.pow_nonzero; easy. - -- apply Nat.pow_nonzero; easy. - -- apply Nat.divide_refl. + rewrite Nat.div_mul by now apply Nat.pow_nonzero. + easy. + rewrite IHn. lca. Qed. @@ -299,8 +290,8 @@ Proof. induction n; [reflexivity | ]. rewrite kron_n_assoc; [ | auto with wf_db]. unfold kron. - rewrite 2 Nat.div_0_l; try apply Nat.pow_nonzero; try easy. - rewrite 2 Nat.mod_0_l; try apply Nat.pow_nonzero; try easy. + rewrite 2 Nat.Div0.div_0_l. + rewrite 2 Nat.Div0.mod_0_l. rewrite IHn. rewrite Cmult_1_r. reflexivity. @@ -332,14 +323,12 @@ Proof. rewrite Nat.mod_1_r. rewrite Nat.div_1_r. destruct (S i mod 2 ^ S n) eqn:En. - + destruct (Nat.mod_divides (S i) (2^S n)); [apply Nat.pow_nonzero; auto |]. + + destruct (Nat.Div0.mod_divides (S i) (2^S n)). destruct H; [assumption |]. rewrite H. rewrite Nat.mul_comm. - rewrite Nat.divide_div_mul_exact; - [ | apply Nat.pow_nonzero; auto | apply Nat.divide_refl ]. - rewrite Nat.div_same; [ | apply Nat.pow_nonzero; auto]. - rewrite Nat.mul_1_r. + + rewrite Nat.div_mul by now apply Nat.pow_nonzero. destruct x; [rewrite Nat.mul_0_r in H; discriminate H |]. unfold ket; simpl. destruct x, j; lca. @@ -389,98 +378,6 @@ Proof. lca. Qed. -Lemma big_ket_1_max_0 : forall n, (n ⨂ ∣1⟩) (2 ^ n - 1)%nat 0%nat = C1. -Proof. - induction n. - - lca. - - rewrite kron_n_assoc; [| auto with wf_db]. - unfold kron. - simpl. - rewrite <- Nat.add_sub_assoc. - + replace (0 / 1 ^ n)%nat with 0%nat - by (rewrite Nat.pow_1_l; rewrite Nat.div_1_r; reflexivity). - replace (0 mod 1^n) with 0%nat by (rewrite Nat.pow_1_l; reflexivity). - replace ((2 ^ n + (2 ^ n + 0 - 1)) / 2 ^ n)%nat with 1%nat. - * replace ((2 ^ n + (2 ^ n + 0 - 1)) mod 2 ^ n)%nat with (2^n-1)%nat. - -- rewrite IHn; lca. - -- rewrite Nat.add_mod; [| apply Nat.pow_nonzero; auto]. - ++ rewrite Nat.add_0_r. - rewrite Nat.mod_same; [| apply Nat.pow_nonzero; auto]. - rewrite Nat.add_0_l. - rewrite Nat.mod_mod; [| apply Nat.pow_nonzero; auto]. - destruct n. - ** reflexivity. - ** rewrite Nat.mod_small; [reflexivity|]. - destruct (2 ^ S n)%nat eqn:E. - --- destruct (Nat.pow_nonzero 2 (S n)); [auto |apply E]. - --- simpl. - rewrite Nat.sub_0_r. - constructor. - * rewrite Nat.add_0_r. - replace ((2 ^ n + (2 ^ n - 1)) / 2 ^ n)%nat - with (((1 * 2 ^ n) + (2 ^ n - 1)) / 2 ^ n)%nat. - -- rewrite Nat.div_add_l; [| apply Nat.pow_nonzero; auto]. - rewrite Nat.div_small; [reflexivity|]. - destruct (2^n)%nat eqn:E. - ++ destruct (Nat.pow_nonzero 2 n); [auto | apply E]. - ++ simpl; rewrite Nat.sub_0_r. - auto. - -- rewrite Nat.mul_1_l. - reflexivity. - + rewrite Nat.add_0_r. - rewrite <- (Nat.pow_1_l n). - replace (S (1 ^ n)) with 2%nat. - * apply Nat.pow_le_mono_l. - auto. - * rewrite Nat.pow_1_l; reflexivity. -Qed. - -Lemma big_bra_1_0_max : forall n, (n ⨂ ⟨1∣) 0%nat (2 ^ n - 1)%nat = C1. -Proof. - induction n. - - lca. - - rewrite kron_n_assoc; [| auto with wf_db]. - unfold kron. - simpl. - rewrite <- Nat.add_sub_assoc. - + replace (0 / 1 ^ n)%nat with 0%nat - by (rewrite Nat.pow_1_l; rewrite Nat.div_1_r; reflexivity). - replace (0 mod 1^n) with 0%nat by (rewrite Nat.pow_1_l; reflexivity). - replace ((2 ^ n + (2 ^ n + 0 - 1)) / 2 ^ n)%nat with 1%nat. - * replace ((2 ^ n + (2 ^ n + 0 - 1)) mod 2 ^ n)%nat with (2^n-1)%nat. - -- rewrite IHn; lca. - -- rewrite Nat.add_mod; [| apply Nat.pow_nonzero; auto]. - ++ rewrite Nat.add_0_r. - rewrite Nat.mod_same; [| apply Nat.pow_nonzero; auto]. - rewrite Nat.add_0_l. - rewrite Nat.mod_mod; [| apply Nat.pow_nonzero; auto]. - destruct n. - ** reflexivity. - ** rewrite Nat.mod_small; [reflexivity|]. - destruct (2 ^ S n)%nat eqn:E. - --- destruct (Nat.pow_nonzero 2 (S n)); [auto |apply E]. - --- simpl. - rewrite Nat.sub_0_r. - constructor. - * rewrite Nat.add_0_r. - replace ((2 ^ n + (2 ^ n - 1)) / 2 ^ n)%nat - with (((1 * 2 ^ n) + (2 ^ n - 1)) / 2 ^ n)%nat. - -- rewrite Nat.div_add_l; [| apply Nat.pow_nonzero; auto]. - rewrite Nat.div_small; [reflexivity|]. - destruct (2^n)%nat eqn:E. - ++ destruct (Nat.pow_nonzero 2 n); [auto | apply E]. - ++ simpl; rewrite Nat.sub_0_r. - auto. - -- rewrite Nat.mul_1_l. - reflexivity. - + rewrite Nat.add_0_r. - rewrite <- (Nat.pow_1_l n). - replace (S (1 ^ n)) with 2%nat. - * apply Nat.pow_le_mono_l. - auto. - * rewrite Nat.pow_1_l; reflexivity. -Qed. - Lemma big_ket_1_n_S : forall n i j, (n ⨂ ∣1⟩) i (S j) = C0. Proof. induction n. @@ -504,146 +401,31 @@ Definition big_bra_sem (n : nat) : Matrix 1 (2 ^ n) := fun x y => if (y =? 2^n-1) && (x =? 0) then C1 else C0. -Opaque Nat.div. -Opaque Nat.modulo. +Lemma big_bra_sem_to_e_i n : + big_bra_sem n = (e_i (2^n-1)) ⊤. +Proof. + prep_matrix_equality. + unfold transpose, big_bra_sem, e_i. + pose proof (Modulus.pow2_nonzero n). + Modulus.bdestructΩ'. +Qed. Lemma big_bra_to_sem : forall n, (n ⨂ (bra 1)) = big_bra_sem n. Proof. + intros n. + rewrite big_bra_sem_to_e_i. + replace (bra 1) with ((@e_i 2 1) ⊤) by lma'. + rewrite <- kron_n_transpose. + rewrite Nat.pow_1_l. + f_equal. induction n. - - prep_matrix_equality. - destruct x,y. - + lca. - + lca. - + lca. - + unfold big_bra_sem. - rewrite andb_false_r. - simpl. - unfold I. - rewrite andb_false_r. - reflexivity. - - prep_matrix_equality. - simpl. + - lma'. + - cbn [kron_n]. rewrite IHn. - unfold kron. - destruct (y =? 2^(S n) - 1) eqn:Ex. - + unfold big_bra_sem. - rewrite Ex. - apply Nat.eqb_eq in Ex. - rewrite Ex. - rewrite Nat.mod_1_r. - rewrite Nat.div_1_r. - destruct y. - * destruct (2^n)%nat eqn:En. - -- contradict En. - apply Nat.pow_nonzero. - easy. - -- replace ((2 ^ S n - 1) / 2)%nat with (2^n - 1)%nat. - ++ rewrite En. - rewrite Nat.eqb_refl. - replace ((2 ^ S n - 1) mod 2)%nat with 1%nat. - ** destruct x; lca. - ** replace (2 ^ S n)%nat with (2^n + 2^n)%nat. - --- destruct (2 ^ n)%nat eqn:E2n. - +++ contradict E2n. - apply Nat.pow_nonzero; easy. - +++ rewrite <- plus_n_Sm. - replace (S (S n1 + n1) - 1)%nat - with (S (n1 + n1))%nat by reflexivity. - rewrite (double_mult n1). - rewrite <- (Nat.add_0_l (2*n1)). - replace (S (0 + 2 * n1))%nat - with (1 + 2 * n1)%nat by reflexivity. - rewrite Nat.add_mod; [| easy]. - rewrite Nat.mul_comm. - rewrite Nat.mod_mul; [| easy]. - reflexivity. - --- simpl. - rewrite Nat.add_0_r. - lia. - ++ replace (2 ^ S n)%nat with (2 * (2 ^ n))%nat. - ** destruct (2^n)%nat. - --- reflexivity. - --- contradict Ex. - destruct (2^S n)%nat eqn:Esn. - +++ contradict Esn. - apply Nat.pow_nonzero; easy. - +++ destruct n2. - *** contradict Esn. - simpl. - destruct (2^n)%nat. - ---- easy. - ---- destruct n2. - ++++ easy. - ++++ simpl. - easy. - *** easy. - ** reflexivity. - * Opaque Nat.div. - Opaque Nat.modulo. - replace ((2 ^ S n - 1) / 2)%nat with (2^n - 1)%nat. - replace ((2 ^ S n - 1) mod 2)%nat with 1%nat. - -- rewrite Nat.eqb_refl. - destruct x; lca. - -- simpl. - rewrite Nat.add_0_r. - destruct (2 ^ n)%nat eqn:En. - ++ contradict En. - ** apply Nat.pow_nonzero; easy. - ++ simpl. - rewrite <- plus_n_Sm. - rewrite Nat.sub_0_r. - rewrite double_mult. - replace (S (2 * n0))%nat with (1 + (2 * n0))%nat by reflexivity. - rewrite Nat.mul_comm. - rewrite Nat.add_mod; [| easy]. - rewrite Nat.mod_mul; [| easy]. - reflexivity. - -- simpl. - rewrite Nat.add_0_r. - destruct (2 ^ n)%nat. - ++ reflexivity. - ++ simpl. - rewrite Nat.sub_0_r. - rewrite Nat.sub_0_r. - rewrite <- plus_n_Sm. - rewrite double_mult. - replace (S (2 * n0))%nat with ((1 + (2 * n0)))%nat by reflexivity. - rewrite Nat.add_comm. - rewrite Nat.mul_comm. - rewrite Nat.div_add_l; [| easy]. - rewrite Nat.add_comm. - reflexivity. - + unfold big_bra_sem. - rewrite Ex. - simpl. - rewrite Nat.mod_1_r. - Transparent Nat.div. - destruct (Nat.divmod y 1 0 1) eqn:Edm. - assert (Hy : (y = 2 * (y / 2) + y mod 2)%nat). - { apply Nat.div_mod; lia. } (* Nat.div_mod_eq works in 8.14 on *) - destruct (y/2 =? 2^n-1) eqn:Ey2. - * destruct (y mod 2 =? 1) eqn:Eym. - -- apply Nat.eqb_eq in Eym, Ey2. - rewrite Ey2, Eym in Hy. - replace (2 * (2 ^ n - 1) + 1)%nat with (2 ^ S n - 1)%nat in Hy. - ++ rewrite Hy in Ex. - rewrite Nat.eqb_refl in Ex. - discriminate. - ++ simpl. - rewrite 2 Nat.add_0_r. - rewrite <- Nat.add_assoc. - rewrite <- plus_n_Sm. - rewrite Nat.add_0_r. - destruct (2 ^ n)%nat eqn:En. - ** contradict En. - apply Nat.pow_nonzero; easy. - ** simpl. lia. - -- destruct (y mod 2). - ++ lca. - ++ destruct n2. - ** discriminate. - ** lca. - * lca. + restore_dims. + pose proof (Modulus.pow2_nonzero n). + rewrite (Kronecker.kron_e_i_e_i 2 (2^n) 1 (2^n-1)) by lia. + f_equal; cbn; lia. Qed. Definition big_ket_sem (n : nat) : Matrix (2 ^ n) 1 := @@ -664,14 +446,28 @@ Proof. intros. rewrite <- (transpose_involutive _ _ _). rewrite kron_n_transpose. - replace ((ket 1)⊤) with (bra 1). - - rewrite big_ket_sem_big_bra_sem_transpose. - f_equal. - + rewrite Nat.pow_1_l. - easy. - + apply big_bra_to_sem. - - rewrite ket1_transpose_bra1. - reflexivity. + rewrite ket1_transpose_bra1. + rewrite big_ket_sem_big_bra_sem_transpose. + rewrite big_bra_to_sem, Nat.pow_1_l. + easy. +Qed. + +Lemma big_ket_1_max_0 : forall n, (n ⨂ ∣1⟩) (2 ^ n - 1)%nat 0%nat = C1. +Proof. + intros n. + rewrite ket1_equiv. + rewrite big_ket_to_sem. + unfold big_ket_sem. + now rewrite 2!Nat.eqb_refl. +Qed. + +Lemma big_bra_1_0_max : forall n, (n ⨂ ⟨1∣) 0%nat (2 ^ n - 1)%nat = C1. +Proof. + intros n. + rewrite bra1_equiv. + rewrite big_bra_to_sem. + unfold big_bra_sem. + now rewrite 2!Nat.eqb_refl. Qed. Lemma braket_sem_1_intermediate : forall n m : nat, @@ -727,3 +523,66 @@ Qed. #[export] Hint Resolve WF_Z_semantics WF_X_semantics : wf_db. + +Lemma X_2_1_semantics α : X_semantics 2 1 α = + (/ √ 2 * / 2) .* @make_WF (2^1) (2^2) (list2D_to_matrix + [[1 + Cexp α; 1 - Cexp α; 1 - Cexp α; 1 + Cexp α]; + [1 - Cexp α; 1 + Cexp α; 1 + Cexp α; 1 - Cexp α]]). +Proof. + unfold X_semantics. + cbn [kron_n]. + Msimpl. + prep_matrix_equivalence. + rewrite make_WF_equiv. + restore_dims. + rewrite Mscale_list2D_to_matrix. + cbn [map]. + restore_dims. + compute_matrix (hadamard × Z_semantics 2 1 α × (hadamard ⊗ hadamard)). + group_radicals. + rewrite Copp_involutive. + replace (/ √ 2 * / C2 + / √ 2 * Cexp α * / C2) with + (/ √ 2 * / C2 * (C1 + Cexp α)) by lca. + replace (/ √ 2 * / C2 + - (/ √ 2 * Cexp α * / C2)) with + (/ √ 2 * / C2 * (C1 - Cexp α)) by lca. + apply make_WF_equiv. +Qed. + +Lemma X_2_1_0_semantics : X_semantics 2 1 0 = + @make_WF (2^1) (2^2) (list2D_to_matrix + [[/ √ 2; C0; C0; / √ 2]; [C0; / √ 2; / √ 2; C0]]). +Proof. + rewrite X_2_1_semantics. + prep_matrix_equivalence. + rewrite 2!make_WF_equiv. + restore_dims. + rewrite Mscale_list2D_to_matrix. + rewrite Cexp_0. + rewrite <- Cdouble, Cmult_1_r, Cminus_diag by reflexivity. + cbn [map]. + rewrite <- Cmult_assoc. + now autorewrite with C_db. +Qed. + +Lemma X_2_1_PI_semantics : X_semantics 2 1 PI = + @make_WF (2^1) (2^2) (list2D_to_matrix + [[C0; / √ 2; / √ 2; C0]; [/ √ 2; C0; C0; / √ 2]]). +Proof. + rewrite X_2_1_semantics. + prep_matrix_equivalence. + rewrite 2!make_WF_equiv. + restore_dims. + rewrite Mscale_list2D_to_matrix. + rewrite Cexp_PI. + change (-1 : R) with (Ropp 1). + rewrite RtoC_opp. + autorewrite with C_db. + cbn [map]. + rewrite <- 2!Cmult_assoc. + now autorewrite with C_db. +Qed. + +(* Compatibility from earlier code *) +Opaque Nat.div. +Opaque Nat.modulo. + diff --git a/src/CoreData/ZXCore.v b/src/CoreData/ZXCore.v index 8eedd7f..c226840 100644 --- a/src/CoreData/ZXCore.v +++ b/src/CoreData/ZXCore.v @@ -1,9 +1,9 @@ Require Import QuantumLib.Quantum. Require Import QuantumLib.Proportional. Require Import QuantumLib.VectorStates. +Require Import QuantumLib.Kronecker. Require Export SemanticCore. -Require Export QlibTemp. (* Base constructions for the ZX calculus, lets us build every diagram inductively. @@ -99,7 +99,9 @@ Proof. apply cast_semantics. Qed. -Tactic Notation "simpl_cast_semantics" := try repeat rewrite cast_semantics; try repeat (rewrite cast_semantics_dim; unfold cast_semantics_dim_eqn). +Ltac simpl_cast_semantics := + try repeat rewrite cast_semantics; + try repeat (rewrite cast_semantics_dim; unfold cast_semantics_dim_eqn). (* @nocheck name *) Fixpoint ZX_dirac_sem {n m} (zx : ZX n m) : @@ -246,8 +248,8 @@ Lemma semantics_transpose_comm {nIn nOut} : forall (zx : ZX nIn nOut), Proof. induction zx. - Msimpl; reflexivity. - - simpl; solve_matrix. - - simpl; solve_matrix. + - lma'. + - lma'. - simpl; lma. - simpl; rewrite id_transpose_eq; reflexivity. - simpl; rewrite hadamard_st; reflexivity. @@ -264,8 +266,8 @@ Proof. intros. induction zx. - simpl; Msimpl; reflexivity. - - simpl; solve_matrix. - - simpl; solve_matrix. + - lma'. + - lma'. - simpl; lma. - simpl; Msimpl; reflexivity. - simpl; lma. @@ -295,11 +297,34 @@ Lemma semantics_colorswap_comm {nIn nOut} : forall (zx : ZX nIn nOut), Proof. induction zx. - simpl; Msimpl; reflexivity. - - solve_matrix. - - solve_matrix. - - simpl. + - cbn. + apply mat_equiv_eq; + [auto using show_WF_list2D_to_matrix with wf_db..|]. + rewrite kron_1_l_mat_equiv. + rewrite Mmult_assoc, Mmult_1_r by now apply show_WF_list2D_to_matrix. + compute_matrix (hadamard ⊗ hadamard). + group_radicals. + rewrite make_WF_equiv. + unfold Mmult. + by_cell; lca. + - cbn. + apply mat_equiv_eq; + [auto using show_WF_list2D_to_matrix with wf_db..|]. + rewrite kron_1_l_mat_equiv. + rewrite Mmult_1_l by now apply show_WF_list2D_to_matrix. + compute_matrix (hadamard ⊗ hadamard). + group_radicals. + rewrite make_WF_equiv. + unfold Mmult. + by_cell; lca. + - cbn. Msimpl. - solve_matrix. + restore_dims. + rewrite swap_eq_kron_comm. + rewrite kron_comm_commutes_r by auto_wf. + rewrite Mmult_assoc. + rewrite kron_mixed_product, MmultHH, id_kron. + now rewrite Mmult_1_r by auto_wf. - simpl; Msimpl; restore_dims; rewrite MmultHH; reflexivity. - simpl; Msimpl; restore_dims; rewrite MmultHH; Msimpl; reflexivity. - simpl. unfold X_semantics. @@ -377,14 +402,20 @@ Qed. Lemma z_1_1_pi_σz : ⟦ Z 1 1 PI ⟧ = σz. -Proof. solve_matrix. autorewrite with Cexp_db. lca. Qed. +Proof. lma'. autorewrite with Cexp_db. lca. Qed. Lemma x_1_1_pi_σx : ⟦ X 1 1 PI ⟧ = σx. -Proof. - simpl. - unfold X_semantics. simpl; Msimpl. solve_matrix; autorewrite with Cexp_db. - all: C_field_simplify; [lca | C_field]. +Proof. + prep_matrix_equivalence. + cbn [ZX_semantics]. + unfold X_semantics. + rewrite kron_n_1 by auto_wf. + simpl_rewrite z_1_1_pi_σz. + restore_dims. + compute_matrix (hadamard × σz × hadamard). + autorewrite with C_db. + by_cell; reflexivity. Qed. Definition zx_triangle : ZX 1 1 := diff --git a/src/CoreRules/CapCupRules.v b/src/CoreRules/CapCupRules.v index e18863a..42ca8c7 100644 --- a/src/CoreRules/CapCupRules.v +++ b/src/CoreRules/CapCupRules.v @@ -9,17 +9,17 @@ Require Import CoreAutomation. Lemma cup_Z : ⊃ ∝ Z 2 0 0. Proof. prop_exists_nonzero 1. - Msimpl; simpl. - solve_matrix. - autorewrite with Cexp_db; easy. + rewrite Mscale_1_l. + lma'. + now rewrite Cexp_0. Qed. Lemma cap_Z : ⊂ ∝ Z 0 2 0. Proof. prop_exists_nonzero 1. - Msimpl; simpl. - solve_matrix. - autorewrite with Cexp_db; easy. + rewrite Mscale_1_l. + lma'. + now rewrite Cexp_0. Qed. Lemma cup_X : ⊃ ∝ X 2 0 0. @@ -31,23 +31,19 @@ Proof. colorswap_of cap_Z. Qed. Lemma n_cup_0_empty : n_cup 0 ∝ ⦰. Proof. unfold n_cup. - repeat (simpl; - cleanup_zx; - simpl_casts). - easy. + cbn. + cleanup_zx. + apply cast_id. Qed. Lemma n_cup_1_cup : n_cup 1 ∝ ⊃. Proof. unfold n_cup. - simpl. - simpl_casts. - simpl. - cleanup_zx. - simpl_casts. - bundle_wires. + cbn. + rewrite cast_id. cleanup_zx. - easy. + rewrite !cast_id. + now rewrite wire_to_n_wire, n_wire_stack, 2!nwire_removal_l. Qed. Opaque n_cup. @@ -78,23 +74,21 @@ Proof. intros. induction n. - simpl. - simpl_casts. - cleanup_zx. - simpl_casts. - bundle_wires. + rewrite !cast_id. cleanup_zx. - easy. + rewrite !cast_id. + now rewrite wire_to_n_wire, n_wire_stack, nwire_removal_l. - simpl. simpl in IHn. rewrite IHn at 1. simpl_casts. rewrite stack_wire_distribute_l. rewrite stack_wire_distribute_r. - bundle_wires. - erewrite <- (@cast_n_wire (n + 1) (1 + n)). + change (— ↕ n_wire n) with (n_wire (1 + n)). + rewrite <- (@cast_n_wire (n + 1) (1 + n)). rewrite <- ComposeRules.compose_assoc. apply compose_simplify; [ | easy]. - erewrite (cast_compose_mid (S (n + S n))). + rewrite (cast_compose_mid (S (n + S n))). rewrite cast_compose_distribute. repeat rewrite cast_contract. apply compose_simplify; [ | apply cast_simplify; easy]. @@ -103,13 +97,13 @@ Proof. simpl_casts. rewrite 3 stack_assoc_back. simpl_casts. - erewrite <- (@cast_n_wire (n + 1) (1 + n)) at 2. + rewrite <- (@cast_n_wire (n + 1) (1 + n)) at 2. rewrite cast_stack_r. simpl. - rewrite (stack_assoc (— ↕ n_wire n ↕ ⊃) (n_wire n) —). - bundle_wires. + rewrite (stack_assoc (— ↕ n_wire n ↕ ⊃) (n_wire n) —). + rewrite <- n_wire_stack. simpl_casts. - easy. + now rewrite <- wire_to_n_wire. Unshelve. all: lia. Qed. diff --git a/src/CoreRules/CastRules.v b/src/CoreRules/CastRules.v index 5b9fe62..1aef426 100644 --- a/src/CoreRules/CastRules.v +++ b/src/CoreRules/CastRules.v @@ -26,14 +26,30 @@ Proof. congruence. Qed. -Tactic Notation "cast_irrelevance" := +Ltac cast_irrelevance := apply cast_simplify; try easy. -Tactic Notation "auto_cast_eqn" tactic3(tac) := unshelve tac; try lia; shelve_unifiable. +Ltac auto_cast_eqn tac := + unshelve tac; try lia; shelve_unifiable. + +Tactic Notation "auto_cast_eqn" tactic3(tac) := + unshelve tac; try lia; shelve_unifiable. + +Create HintDb cast_simpl_db. #[export] Hint Rewrite @cast_id : cast_simpl_db. -Tactic Notation "simpl_casts" := auto_cast_eqn (autorewrite with cast_simpl_db); repeat cast_irrelevance. -Tactic Notation "simpl_casts_in" hyp(H) := auto_cast_eqn (autorewrite with cast_simpl_db in H); repeat (apply cast_simplify in H). + +Ltac simpl_casts := + auto_cast_eqn (autorewrite with cast_simpl_db); + repeat cast_irrelevance. + +Ltac simpl_casts_in H := + auto_cast_eqn (autorewrite with cast_simpl_db in H); + repeat (apply cast_simplify in H). + +Tactic Notation "simpl_casts_in" hyp(H) := + auto_cast_eqn (autorewrite with cast_simpl_db in H); + repeat (apply cast_simplify in H). Lemma cast_stack_l : forall {nTop nTop' mTop mTop' nBot mBot} prfnTop prfmTop prfn prfm @@ -325,6 +341,26 @@ Qed. #[export] Hint Rewrite @cast_Z @cast_X: cast_simpl_db. +Lemma cast_Z_to_refl_r n m α {m' o' o} (zx : ZX m' o') Hm Ho : + Z n m α ⟷ cast m o Hm Ho zx = + Z n m' α ⟷ cast m' o eq_refl Ho zx. +Proof. now subst. Qed. + +Lemma cast_X_to_refl_r n m α {m' o' o} (zx : ZX m' o') Hm Ho : + X n m α ⟷ cast m o Hm Ho zx = + X n m' α ⟷ cast m' o eq_refl Ho zx. +Proof. now subst. Qed. + +Lemma cast_Z_contract_r n m α {m' o' o} (zx : ZX m' o') Hm Ho : + Z n m α ⟷ cast m o Hm Ho zx = + cast n o eq_refl Ho (Z n m' α ⟷ zx). +Proof. now subst. Qed. + +Lemma cast_X_contract_r n m α {m' o' o} (zx : ZX m' o') Hm Ho : + X n m α ⟷ cast m o Hm Ho zx = + cast n o eq_refl Ho (X n m' α ⟷ zx). +Proof. now subst. Qed. + Lemma cast_n_stack1 : forall {n n'} prfn prfm (zx : ZX 1 1), cast n' n' prfn prfm (n ↑ zx) ∝ n' ↑ zx. Proof. diff --git a/src/CoreRules/CoreAutomation.v b/src/CoreRules/CoreAutomation.v index f9483c9..9d1209f 100644 --- a/src/CoreRules/CoreAutomation.v +++ b/src/CoreRules/CoreAutomation.v @@ -20,9 +20,10 @@ match goal with | [ |- ?zx1 ∝ ?zx2] => try (wire_to_n_wire_safe_aux zx1); try (wire_to_n_wire_safe_aux zx2); repeat rewrite n_stack_n_wire_1_n_wire end. -Tactic Notation "bundle_wires" := wire_to_n_wire_safe; (* change wires to n_wires *) - repeat rewrite n_wire_stack; (* stack n_wire *) - repeat rewrite <- wire_to_n_wire. (* restore *) +Ltac bundle_wires := + wire_to_n_wire_safe; (* change wires to n_wires *) + repeat rewrite n_wire_stack; (* stack n_wire *) + repeat rewrite <- wire_to_n_wire. (* restore *) #[export] Hint Rewrite (fun n => @compose_empty_l n) @@ -39,7 +40,7 @@ Tactic Notation "bundle_wires" := wire_to_n_wire_safe; (* change wires to n_wire (fun n m o p => @nwire_stack_compose_topleft n m o p) (fun n m o p => @nwire_stack_compose_botleft n m o p) : cleanup_zx_db. -Tactic Notation "cleanup_zx" := auto_cast_eqn (autorewrite with cleanup_zx_db). +Ltac cleanup_zx := auto_cast_eqn (autorewrite with cleanup_zx_db). #[export] Hint Rewrite (fun n m o p => @cast_colorswap n m o p) diff --git a/src/CoreRules/SpiderInduction.v b/src/CoreRules/SpiderInduction.v index 6ed8d68..85d3e9c 100644 --- a/src/CoreRules/SpiderInduction.v +++ b/src/CoreRules/SpiderInduction.v @@ -4,17 +4,6 @@ Open Scope ZX_scope. (* Spider Induction *) -#[export] Hint Rewrite - Cmult_0_l - Cmult_0_r - Cplus_0_r - Cplus_0_l - Cmult_1_r - Cmult_1_l - : cleanup_C_db. - -Ltac cleanup_C := autorewrite with cleanup_C_db. - (* The first part that is necessary to prove spider edge count induction is the ability to split spiders off to the side. We only need to prove this one, the others follow through transposes *) @@ -34,7 +23,7 @@ Proof. replace (S (i + i))%nat with (2 * (S i) - 1)%nat by lia. assert (S i <> 0)%nat by easy. assert (2 * S i - 1 < S i * 2)%nat by lia. - specialize (Nat.div_lt_upper_bound (2 * S i - 1) (S i) (2) H H0). + specialize (Nat.Div0.div_lt_upper_bound (2 * S i - 1) (S i) (2) H0). intros. assert (0 < S i <= 2 * S i - 1)%nat by lia. specialize (Nat.div_str_pos (2 * S i - 1) (S i) H2). @@ -49,7 +38,7 @@ Proof. replace (S (S (S (i + i + (i + i)))))%nat with (4 * (S i) - 1)%nat by lia. assert (S i <> 0)%nat by easy. assert (4 * S i - 1 < S i * 4)%nat by lia. - specialize (Nat.div_lt_upper_bound (4 * S i - 1) (S i) (4) H H0). + specialize (Nat.Div0.div_lt_upper_bound (4 * S i - 1) (S i) (4) H0). intros. assert (S i * 3 <= 4 * S i - 1)%nat by lia. specialize (Nat.div_le_lower_bound (4 * S i - 1) (S i) 3 H H2). @@ -61,20 +50,20 @@ Proof. assert ( mod_2_comp : forall i, ((S (i + i)) mod (S i) = i)%nat ). { intros. rewrite plus_n_Sm. - rewrite Nat.add_mod by lia. - rewrite Nat.mod_same by lia. + rewrite Nat.Div0.add_mod by lia. + rewrite Nat.Div0.mod_same by lia. rewrite Nat.add_0_r. - rewrite Nat.mod_mod by lia. + rewrite Nat.Div0.mod_mod by lia. apply Nat.mod_small; lia. } assert ( mod_4_comp : forall i, ((S (S (S (i + i + (i + i))))) mod (S i) = i)%nat ). { intros. replace (S (S (S (i + i + (i + i))))) with ((S i) + ((S i) + ((S i) + i)))%nat by lia. - repeat (rewrite Nat.add_mod by lia; - rewrite Nat.mod_same by lia; + repeat (rewrite Nat.Div0.add_mod by lia; + rewrite Nat.Div0.mod_same by lia; rewrite Nat.add_0_l). - repeat rewrite Nat.mod_mod by lia. + repeat rewrite Nat.Div0.mod_mod by lia. apply Nat.mod_small; lia. } intros. simpl. @@ -178,7 +167,7 @@ Proof. * destruct (S (S y) / (S (S m)))%nat eqn:E; try lca. rewrite Nat.div_small_iff in E by auto. rewrite (Nat.mod_small (S (S y))) by auto. - repeat rewrite Nat.mod_0_l by auto. + repeat rewrite Nat.Div0.mod_0_l. lca. * lca. * lca. @@ -203,11 +192,12 @@ Qed. Lemma grow_Z_right_bot_1_2_base : forall α, Z 1 3 α ∝ Z 1 2 α ⟷ (— ↕ Z 1 2 0). Proof. - intros. prop_exists_nonzero 1. simpl; Msimpl. unfold Z_semantics. - gridify. - solve_matrix. - rewrite Cexp_0. - lca. + intros. prop_exists_nonzero 1. + rewrite Mscale_1_l. + prep_matrix_equivalence. + cbn [ZX_semantics]. + match goal with |- ?A ≡ ?B => compute_matrix A; compute_matrix B end. + now rewrite Cexp_0, Cmult_1_l. Qed. Lemma Z_wrap_over_top_right_base : forall n α, @@ -215,114 +205,76 @@ Lemma Z_wrap_over_top_right_base : forall n α, Proof. intros. prop_exists_nonzero 1. - simpl; Msimpl. - unfold Z_semantics, kron, Mmult. - prep_matrix_equality. - replace (2 ^ S n)%nat with (2 ^ n + 2 ^ n)%nat by (simpl; lia). - remember (2 ^ n)%nat as m. - assert (Hm : (m <> 0)%nat). - { rewrite Heqm. apply Nat.pow_nonzero. easy. } - assert (Hm_div : (((m + m - 1) / m) = 1)%nat). - { - replace (m + m - 1)%nat with (1 * m + (m - 1))%nat by lia. - rewrite Nat.div_add_l by assumption. - rewrite Nat.div_small by lia. - lia. - } - assert (Hm_mod : ((m + m - 1) mod m = m - 1)%nat). - { - replace (m + m - 1)%nat with (m + (m - 1))%nat by lia. - rewrite Nat.add_mod by auto. - rewrite Nat.mod_same by auto. - simpl. - repeat rewrite Nat.mod_small; lia. - } - bdestruct (x =? 1)%nat; bdestruct (y =? m + m - 1)%nat. - - rewrite H, H0. - rewrite Nat.mod_small by lia. - rewrite andb_true_l. - rewrite Hm_mod. - simpl. - unfold list2D_to_matrix, I. - simpl. - rewrite Hm_div. - rewrite Nat.eqb_refl. - lca. - - rewrite H. - simpl. - unfold list2D_to_matrix, I. - simpl. - bdestruct (y / m =? 1)%nat; bdestruct (y mod m =? m - 1)%nat. - + rewrite H1. - simpl. - contradict H0. - specialize (Nat.div_mod_eq y m); intros. - rewrite H0. - rewrite H1, H2. - lia. - + lca. - + destruct (y / m)%nat; try lca. - destruct n0; try lca. - contradict H1; lia. - + lca. - - destruct x. - + rewrite H0. - simpl. - unfold list2D_to_matrix, I. - simpl. - rewrite Hm_div, Hm_mod. - simpl. - destruct m; simpl. - * lia. - * rewrite Nat.sub_0_r. - rewrite <- plus_n_Sm. - lca. - + destruct x; [ contradict H; lia | ]. - unfold list2D_to_matrix, I. - simpl. - rewrite divmod_eq. - simpl. - destruct (fst (Nat.divmod x 1 0 1)); lca. - - rewrite andb_false_r. - destruct x,y. - + simpl. - unfold list2D_to_matrix, I. - simpl. - rewrite Nat.div_0_l, Nat.mod_0_l; try lia. - simpl. - destruct n; lca. - + simpl. - unfold list2D_to_matrix, I. - simpl. - cleanup_C. - specialize (Nat.div_mod_eq (S y) m). - intros. - bdestruct (S y / m =? 0)%nat; bdestruct (S y mod m =? 0). - * rewrite H2, H3. - simpl. - contradict H1. - rewrite H2, H3. - lia. - * rewrite H2. - simpl. - destruct (S y mod m)%nat; [ lia | lca ]. - * destruct (S y / m)%nat; [ lia | lca ]. - * destruct (S y mod m)%nat; [ lia | ]. - destruct (S y / m)%nat; [ lia | lca ]. - + unfold I, list2D_to_matrix. - destruct x; [ lia | ]. - simpl. - rewrite divmod_eq. - fold (x / 2)%nat. - simpl. - destruct (fst (Nat.divmod x 1 0 1)); simpl; lca. - + unfold I, list2D_to_matrix. - destruct x; [ lia | ]. - simpl. - rewrite divmod_eq. - fold (x / 2)%nat. - simpl. - destruct (fst (Nat.divmod x 1 0 1)); simpl; lca. + rewrite Mscale_1_l. + prep_matrix_equivalence. + cbn [ZX_semantics]. + rewrite Kronecker.kron_I_l, Kronecker.kron_I_r. + intros i j Hi Hj. + unfold Mmult. + unfold Z_semantics at 2. + destruct i as [|[]]; [..|cbn in Hi; lia]. + - rewrite Nat.Div0.mod_0_l. + cbn [Nat.add]. + change (0 =? 2 ^ 1 - 1) with false. + rewrite andb_false_l. + destruct j. + + apply big_sum_unique. + exists O. + split; [pose proof (Modulus.pow2_nonzero 3); lia|]. + rewrite !Nat.Div0.div_0_l, !Nat.Div0.mod_0_l, Nat.eqb_refl. + split; [cbn; destruct n; lca|]. + intros k Hk Hknz. + destruct k; [easy|]. + do 7 (try destruct k; cbn; [cbn; lca|]). + cbn in *; lia. + + apply (@big_sum_0_bounded C). + intros k Hk. + rewrite Nat.Div0.div_0_l. + cbn [Nat.pow Nat.mul Nat.add] in *. + do 8 (try destruct k); try apply Cmult_0_l; [..|lia]; + rewrite Modulus.if_true by reflexivity. + * rewrite !Nat.Div0.div_0_l, Nat.Div0.mod_0_l. + rewrite Nat.eqb_sym. + Modulus.bdestructΩ'; [|lca]. + rewrite Nat.div_small_iff in * by Modulus.show_nonzero. + rewrite Nat.mod_small by easy. + apply Cmult_1_l. + * change (6 / 4)%nat with 1%nat; change (4 / 2)%nat with 2%nat. + change (6 mod 4) with (2)%nat. + Modulus.bdestructΩ'; apply Cmult_0_r. + - rewrite Nat.eqb_refl, andb_true_l. + bdestruct (j =? 2 ^ (1 + n) - 1). + + apply big_sum_unique. + assert (j / 2 ^ n < 2)%nat by + (apply Nat.Div0.div_lt_upper_bound; cbn in *; lia). + destruct (j / 2 ^ n)%nat as [|one] eqn:e; + [rewrite Nat.div_small_iff in e; cbn in *; lia|]. + destruct one; [|lia]. + exists 7%nat. + split; [cbn; lia|]. + rewrite 2!Modulus.if_true by reflexivity. + change (7 mod 2 ^ 2) with 3%nat. + rewrite Modulus.mod_n_to_2n by (cbn in *; lia). + subst j. + split; [cbn; Modulus.bdestructΩ'; lca|]. + intros k Hk Hk7. + cbn [Nat.pow Nat.mul Nat.add Nat.sub] in *. + do 8 (try destruct k); try apply Cmult_0_l; [..|lia]; + rewrite Modulus.if_true by reflexivity; [|easy]. + apply Cmult_0_r. + + apply (@big_sum_0_bounded C). + intros k Hk. + cbn [Nat.pow Nat.mul Nat.add Nat.sub] in *. + do 8 (try destruct k); try apply Cmult_0_l; [..|lia]; + rewrite Modulus.if_true by reflexivity; rewrite Cmult_1_l; + Modulus.bdestructΩ'. + change (7 mod 4) with 3%nat. + assert (~ (j < 2 ^ n)%nat) by + (rewrite <- Nat.div_small_iff by Modulus.show_nonzero; + replace <- (j / 2 ^ n)%nat; easy). + cbn. + rewrite Modulus.mod_n_to_2n by lia. + Modulus.bdestructΩ'. Qed. Lemma Z_wrap_over_top_right_0 : forall n α, @@ -347,8 +299,8 @@ Proof. assert (Hm_mod : ((m + m - 1) mod m = m - 1)%nat). { replace (m + m - 1)%nat with (m + (m - 1))%nat by lia. - rewrite Nat.add_mod by auto. - rewrite Nat.mod_same by auto. + rewrite Nat.Div0.add_mod by auto. + rewrite Nat.Div0.mod_same by auto. simpl. repeat rewrite Nat.mod_small; lia. } @@ -361,7 +313,7 @@ Proof. simpl. unfold list2D_to_matrix, I. simpl. - cleanup_C. + Csimpl. destruct m; [ contradict Hm; lia | ]. simpl. rewrite <- plus_n_Sm. @@ -379,15 +331,15 @@ Proof. rewrite H1, H2. lia. + rewrite H1. - cleanup_C. + Csimpl. destruct y; [ contradict H1 | ]. - rewrite Nat.div_0_l by auto. + rewrite Nat.Div0.div_0_l. lia. lca. + destruct (y / m)%nat eqn:E; try lca. - cleanup_C. + Csimpl. destruct y. - * rewrite Nat.mod_0_l by auto. + * rewrite Nat.Div0.mod_0_l. destruct n; auto. * destruct (S y mod m) eqn:Ey. assert (contra : (S y <> 0)%nat) by lia. @@ -398,17 +350,16 @@ Proof. rewrite Ey, E. lia. lca. - * cleanup_C. + * Csimpl. destruct n0; [ contradict H1; easy | ]. simpl. - destruct y. - -- contradict E. - rewrite Nat.div_0_l by auto. - lia. - -- lca. - + cleanup_C. + destruct y; [|lca]. + contradict E. + rewrite Nat.Div0.div_0_l. + lia. + + Csimpl. destruct y. - * rewrite Nat.div_0_l, Nat.mod_0_l; try lia. + * rewrite Nat.Div0.div_0_l, Nat.Div0.mod_0_l. destruct n; lca. * specialize (Nat.div_mod_eq (S y) m); intros. destruct (S y / m)%nat, (S y mod m)%nat; try lca. @@ -427,7 +378,7 @@ Proof. rewrite Nat.eqb_refl. lca. + simpl. - cleanup_C. + Csimpl. rewrite H0. rewrite Hm_div. rewrite Hm_mod. @@ -438,11 +389,11 @@ Proof. + simpl. unfold list2D_to_matrix, I. simpl. - rewrite Nat.div_0_l, Nat.mod_0_l; try lia. + rewrite Nat.Div0.div_0_l, Nat.Div0.mod_0_l; lia. + simpl. unfold list2D_to_matrix, I. simpl. - cleanup_C. + Csimpl. specialize (Nat.div_mod_eq (S y) m). intros. bdestruct (S y / m =? 0)%nat; bdestruct (S y mod m =? 0); exfalso; lia. diff --git a/src/CoreRules/SwapRules.v b/src/CoreRules/SwapRules.v index ffb85fe..f168597 100644 --- a/src/CoreRules/SwapRules.v +++ b/src/CoreRules/SwapRules.v @@ -1,17 +1,21 @@ +Require Import QuantumLib.Kronecker QuantumLib.Modulus. Require Import CoreData. Require Import WireRules. Require Import CoreAutomation. Require Import StackComposeRules. Require Import CastRules. - +Require Import ZXpermFacts. Lemma swap_compose : ⨉ ⟷ ⨉ ∝ n_wire 2. -Proof. solve_prop 1. Qed. +Proof. + by_perm_eq_nosimpl; by_perm_cell; reflexivity. +Qed. Global Hint Rewrite swap_compose : cleanup_zx_db. -Lemma top_wire_to_bottom_ind : forall n, top_wire_to_bottom (S (S n)) = @Mmult _ (2 ^ (S (S n))) _ ((I 2) ⊗ top_wire_to_bottom (S n)) (swap ⊗ (I (2 ^ n))). +Lemma top_wire_to_bottom_ind : forall n, top_wire_to_bottom (S (S n)) = + @Mmult _ (2 ^ (S (S n))) _ ((I 2) ⊗ top_wire_to_bottom (S n)) (swap ⊗ (I (2 ^ n))). Proof. intros. induction n. @@ -72,12 +76,6 @@ Proof. easy. Qed. -Lemma swap_spec' : swap = ((ket 0 × bra 0) ⊗ (ket 0 × bra 0) .+ (ket 0 × bra 1) ⊗ (ket 1 × bra 0) - .+ (ket 1 × bra 0) ⊗ (ket 0 × bra 1) .+ (ket 1 × bra 1) ⊗ (ket 1 × bra 1)). -Proof. - solve_matrix. -Qed. - Lemma top_to_bottom_grow_l : forall n, top_to_bottom (S (S n)) ∝ (⨉ ↕ n_wire n) ⟷ (— ↕ top_to_bottom (S n)). Proof. easy. Qed. @@ -86,61 +84,43 @@ Lemma top_to_bottom_grow_r : forall n prf prf', top_to_bottom (S (S n)) ∝ cast _ _ prf' prf' (top_to_bottom (S n) ↕ —) ⟷ (cast _ _ prf prf (n_wire n ↕ ⨉)). Proof. intros. - induction n. - + simpl; cleanup_zx; simpl_casts. - bundle_wires. - cleanup_zx. - easy. - + simpl. - simpl in IHn. - rewrite IHn at 1. - simpl_casts. - rewrite (stack_assoc — (n_wire n) ⨉). - simpl_casts. - erewrite (@cast_stack_distribute - _ 1 _ 1 _ _ _ _ - _ _ _ _ _ _ — (n_wire n ↕ ⨉)). - rewrite (cast_id _ _ —). - erewrite (cast_compose_mid (S (S n)) _ _ (⨉ ↕ n_wire n)). - erewrite (@cast_stack_distribute - _ 1 _ 1 _ _ _ _ - _ _ _ _ _ _ — (top_to_bottom_helper n)). - rewrite cast_id. - rewrite stack_wire_distribute_r. - rewrite cast_compose_distribute. - rewrite stack_wire_distribute_l. - rewrite <- compose_assoc. - apply compose_simplify; [ | easy ]. - bundle_wires. - repeat rewrite cast_id. - symmetry. - erewrite (cast_compose_mid (S (S (S n)))). - simpl_casts. - apply compose_simplify; [ | rewrite (stack_assoc_back — (top_to_bottom_helper n) —); simpl_casts; easy ]. - eapply (cast_diagrams (2 + (1 + n)) (2 + (1 + n))). - rewrite cast_contract. - rewrite (stack_assoc ⨉ (n_wire n) —). - rewrite cast_contract. - rewrite cast_stack_distribute. - bundle_wires. - rewrite cast_n_wire. - simpl_casts. - easy. -Unshelve. - all: lia. + by_perm_eq_nosimpl. + rewrite perm_of_top_to_bottom_eq. + cbn. + rewrite 2!perm_of_zx_cast. + cbn. + rewrite perm_of_top_to_bottom_helper_eq, perm_of_n_wire. + intros i Hi. + rewrite stack_perms_WF_idn by cleanup_perm. + rewrite stack_perms_idn_f. + unfold compose. + bdestructΩ'; + unfold top_to_bottom_perm; [bdestructΩ'|]. + unfold swap_2_perm, swap_perm. + do 2 simplify_bools_lia_one_kernel. + bdestructΩ'. Qed. - + + + Lemma offset_swaps_comm_top_left : ⨉ ↕ — ⟷ (— ↕ ⨉) ∝ — ↕ ⨉ ⟷ (⨉ ↕ —) ⟷ (— ↕ ⨉) ⟷ (⨉ ↕ —). -Proof. (* solve_prop 1. Qed. *) Admitted. +Proof. + by_perm_eq_nosimpl. + by_perm_cell; reflexivity. +Qed. Lemma offset_swaps_comm_bot_right : — ↕ ⨉ ⟷ (⨉ ↕ —) ∝ ⨉ ↕ — ⟷ (— ↕ ⨉) ⟷ (⨉ ↕ —) ⟷ (— ↕ ⨉). -Proof. (* solve_prop 1. Qed. *) Admitted. +Proof. + by_perm_eq_nosimpl. + by_perm_cell; reflexivity. +Qed. -Lemma bottom_wire_to_top_ind : forall n, bottom_wire_to_top (S (S n)) = @Mmult _ (2 ^ (S (S n))) _ (swap ⊗ (I (2 ^ n))) ((I 2) ⊗ bottom_wire_to_top (S n)). +Lemma bottom_wire_to_top_ind : forall n, bottom_wire_to_top (S (S n)) = +@Mmult _ (2 ^ (S (S n))) _ (swap ⊗ (I (2 ^ n))) ((I 2) ⊗ bottom_wire_to_top (S n)). Proof. intros. apply transpose_matrices. @@ -175,26 +155,23 @@ Lemma bottom_to_top_grow_l : forall n prf prf', bottom_to_top (S (S n)) ∝ cast _ _ prf' prf'((cast _ _ prf prf (n_wire n ↕ ⨉)) ⟷ (bottom_to_top (S n) ↕ —)). Proof. intros. - apply transpose_diagrams. -Opaque top_to_bottom. - simpl. - unfold bottom_to_top. - rewrite cast_transpose. - simpl. - repeat rewrite cast_transpose. - simpl. - rewrite n_wire_transpose. - repeat rewrite Proportional.transpose_involutive. - rewrite top_to_bottom_grow_r. - rewrite cast_compose_distribute. - simpl_casts. - erewrite (cast_compose_mid (S (n + 1))). - simpl_casts. - apply compose_simplify; cast_irrelevance. -Unshelve. -all: lia. + by_perm_eq_nosimpl. + rewrite perm_of_bottom_to_top_eq, perm_of_zx_cast. + rewrite perm_of_zx_compose_spec, perm_of_zx_cast. + rewrite 2!perm_of_zx_stack_spec, perm_of_n_wire. + rewrite perm_of_bottom_to_top_eq. + cbn. + intros i Hi. + rewrite stack_perms_WF_idn by cleanup_perm. + rewrite stack_perms_idn_f. + unfold compose. + unfold bottom_to_top_perm. + destruct i. + - cbn [Nat.leb]. unfold swap_2_perm, swap_perm; bdestructΩ'. + - simplify_bools_lia_one_kernel. + unfold swap_2_perm, swap_perm. + bdestructΩ'. Qed. -Transparent top_to_bottom. Lemma top_to_bottom_transpose : forall n, (top_to_bottom n)⊤ ∝ bottom_to_top n. Proof. @@ -214,78 +191,38 @@ Qed. Lemma a_swap_grow : forall n, a_swap (S (S (S n))) ∝ (⨉ ↕ n_wire (S n)) ⟷ (— ↕ a_swap (S (S n))) ⟷ (⨉ ↕ n_wire (S n)). Proof. intros. - remember (⨉ ↕ n_wire S n ⟷ (— ↕ a_swap (S (S n))) ⟷ (⨉ ↕ n_wire S n)) as right_side. - unfold a_swap at 1. - rewrite bottom_to_top_grow_r. - rewrite top_to_bottom_grow_l. - simpl. - rewrite compose_assoc. - rewrite stack_wire_distribute_l. - rewrite <- (compose_assoc (⨉ ↕ (— ↕ n_wire n))). - rewrite stack_assoc_back. - rewrite (stack_assoc_back — ⨉ (n_wire n)). - simpl_casts. - rewrite <- (@stack_nwire_distribute_r _ _ _ n (⨉ ↕ —) (— ↕ ⨉)). - rewrite offset_swaps_comm_top_left. - rewrite bottom_to_top_grow_r. - rewrite stack_wire_distribute_l. - rewrite (compose_assoc _ (— ↕ (⨉ ↕ n_wire n))). - rewrite (stack_assoc_back — ⨉ (n_wire n)). - simpl_casts. - rewrite <- (compose_assoc (— ↕ ⨉ ↕ n_wire n)). - rewrite <- (@stack_nwire_distribute_r _ _ _ n (— ↕ ⨉) (— ↕ ⨉ ⟷ (⨉ ↕ —) ⟷ (— ↕ ⨉) ⟷ (⨉ ↕ —))). - repeat rewrite <- compose_assoc. - rewrite <- stack_wire_distribute_l. - rewrite swap_compose. - cleanup_zx. - repeat rewrite stack_nwire_distribute_r. - rewrite (stack_assoc ⨉ — (n_wire n)). - rewrite 2 (stack_assoc_back — —). - simpl_casts. - bundle_wires. - repeat rewrite <- compose_assoc. - rewrite (nwire_stack_compose_topleft (bottom_to_top (S n)) ⨉). - rewrite <- nwire_stack_compose_botleft. - repeat rewrite compose_assoc. - rewrite (nwire_stack_compose_botleft ⨉ (top_to_bottom_helper n)). - rewrite <- (nwire_stack_compose_topleft (top_to_bottom_helper n) ⨉). - simpl. - rewrite stack_empty_r. - simpl_casts. - rewrite 3 (stack_assoc —). - simpl_casts. - rewrite Heqright_side. - repeat rewrite compose_assoc. - apply compose_simplify; [ easy | ]. - repeat rewrite <- compose_assoc. - apply compose_simplify; [ | easy ]. - simpl. - rewrite <- 2 stack_wire_distribute_l. - apply stack_simplify; [ easy | ]. - rewrite <- bottom_to_top_grow_r. - easy. -Unshelve. -all: lia. + by_perm_eq_nosimpl. + cbn -[a_swap n_stack1]. + rewrite 2!perm_of_a_swap, perm_of_n_wire. + rewrite 2!swap_perm_defn by lia. + rewrite (stack_perms_defn 1). + rewrite stack_perms_WF_idn by cleanup_perm. + unfold swap_2_perm, swap_perm. + intros i Hi. + unfold compose at 1. + bdestructΩ'; unfold compose; bdestructΩ'. Qed. Lemma a_swap_2_is_swap : a_swap 2 ∝ ⨉. Proof. - unfold a_swap. - unfold bottom_to_top. - simpl. - cleanup_zx. - simpl_casts. - bundle_wires. - cleanup_zx. - easy. + by_perm_eq_nosimpl; by_perm_cell; reflexivity. Qed. Lemma a_swap_3_order_indep : I 2 ⊗ swap × (swap ⊗ I 2) × (I 2 ⊗ swap) = (swap ⊗ I 2) × (I 2 ⊗ swap) × (swap ⊗ I 2). Proof. - (* solve_matrix *) (* Commented out for performance*) -Admitted. + rewrite swap_eq_kron_comm. + change 2%nat with (2^1)%nat. + rewrite <- perm_to_matrix_idn. + rewrite kron_comm_pows2_eq_perm_to_matrix_big_swap. + restore_dims. + rewrite <- !perm_to_matrix_of_stack_perms by auto with perm_db. + restore_dims. + rewrite <- !perm_to_matrix_compose by auto with perm_db. + apply perm_to_matrix_eq_of_perm_eq. + by_perm_cell; reflexivity. +Qed. Lemma a_swap_semantics_ind : forall n, a_swap_semantics (S (S (S n))) = swap ⊗ (I (2 ^ (S n))) × (I 2 ⊗ a_swap_semantics (S (S n))) × (swap ⊗ (I (2 ^ (S n)))). Proof. @@ -346,43 +283,26 @@ Qed. Lemma a_swap_transpose : forall n, (a_swap n) ⊤ ∝ a_swap n. Proof. - intros. - strong induction n. - destruct n; [ easy | ]. - destruct n; [ simpl; cleanup_zx; simpl_casts; easy | ]. - destruct n; [ rewrite a_swap_2_is_swap; easy | ]. - rewrite a_swap_grow. -Local Opaque a_swap. - simpl. - repeat rewrite n_wire_transpose. - rewrite compose_assoc. - rewrite H by lia. + by_perm_eq_nosimpl. + rewrite perm_of_zx_transpose by auto with zxperm_db. + rewrite perm_of_a_swap. + bdestruct (n =? 0); [subst; now intros i Hi|]. + rewrite swap_perm_inv' by lia. easy. Qed. (* n_swap proofs *) -Opaque a_swap a_swap_semantics. (* For n_swap proofs we don't want a_swap to unfold, instead we use lemmata from above*) - Lemma n_swap_2_is_swap : n_swap 2 ∝ ⨉. Proof. - intros. - simpl. - unfold bottom_to_top. - simpl. - cleanup_zx. - simpl_casts. - bundle_wires. - cleanup_zx. - easy. + by_perm_eq_nosimpl. + by_perm_cell; reflexivity. Qed. Lemma n_swap_1_is_wire : n_swap 1 ∝ —. Proof. - simpl. - cleanup_zx. - simpl_casts. - easy. + by_perm_eq_nosimpl. + by_perm_cell; reflexivity. Qed. Lemma n_swap_grow_l : forall n, @@ -399,48 +319,20 @@ Qed. Lemma n_swap_grow_r : forall n, n_swap (S n) ∝ (— ↕ n_swap n) ⟷ top_to_bottom (S n). Proof. - induction n. - - simpl. - cleanup_zx. - easy. - - simpl. - fold (top_to_bottom (S n)). - rewrite <- (n_swap_grow_l n). - rewrite IHn at 1. - rewrite bottom_to_top_grow_r. - rewrite stack_wire_distribute_l. - rewrite (stack_assoc_back — —). - simpl_casts. - bundle_wires. - repeat rewrite compose_assoc. - rewrite <- (compose_assoc (⨉ ↕ n_wire n)). - rewrite (nwire_stack_compose_botleft ⨉ (n_swap n)). - rewrite <- (nwire_stack_compose_topleft (n_swap n) ⨉). - repeat rewrite <- compose_assoc. - simpl. - cleanup_zx. - simpl_casts. - rewrite stack_wire_distribute_l. - repeat rewrite compose_assoc. - rewrite (stack_assoc_back — — (n_swap _)). - cleanup_zx. - simpl_casts. - easy. -Unshelve. -all: lia. + by_perm_eq. + rewrite !reflect_perm_defn, stack_perms_defn. + change (S n) with (1 + n)%nat. + rewrite (rotr_add_l 1 n). + unfold big_swap_perm, compose. + intros i Hi. + bdestructΩ'. Qed. Lemma n_swap_transpose : forall n, (n_swap n) ⊤ ∝ n_swap n. Proof. - induction n; try easy. - - simpl. - rewrite IHn. - unfold bottom_to_top at 1. - rewrite Proportional.transpose_involutive. - rewrite <- n_swap_grow_l. - rewrite <- n_swap_grow_r. - easy. + intros. + by_perm_eq. Qed. #[export] Hint Rewrite @@ -453,54 +345,29 @@ Qed. Lemma top_to_bottom_colorswap : forall n, ⊙ (top_to_bottom n) ∝ top_to_bottom n. Proof. - destruct n; [ easy | ]. - induction n. - - easy. - - simpl. - fold (top_to_bottom (S n)). - rewrite IHn. - rewrite n_wire_colorswap. - easy. + intros n. + now rewrite zxperm_colorswap_eq by auto with zxperm_db. Qed. Lemma bottom_to_top_colorswap : forall n, ⊙ (bottom_to_top n) ∝ bottom_to_top n. Proof. - destruct n; [easy | ]. - induction n. - - easy. - - unfold bottom_to_top. - rewrite top_to_bottom_grow_l. - simpl. - fold (top_to_bottom (S n)). - fold (bottom_to_top (S n)). - rewrite IHn. - rewrite n_wire_transpose. - rewrite n_wire_colorswap. - easy. + intros n. + now rewrite zxperm_colorswap_eq by auto with zxperm_db. Qed. Lemma a_swap_colorswap : forall n, ⊙ (a_swap n) ∝ a_swap n. Proof. - induction n. - - easy. - - Local Transparent a_swap. - simpl. - rewrite bottom_to_top_colorswap. - rewrite top_to_bottom_colorswap. - easy. + intros n. + now rewrite zxperm_colorswap_eq by auto with zxperm_db. Qed. Lemma n_swap_colorswap : forall n, ⊙ (n_swap n) ∝ n_swap n. Proof. - induction n. - - easy. - - simpl. - rewrite IHn. - rewrite bottom_to_top_colorswap. - easy. + intros n. + now rewrite zxperm_colorswap_eq by auto with zxperm_db. Qed. #[export] Hint Rewrite @@ -511,39 +378,11 @@ Qed. : colorswap_db. Lemma swap_pullthrough_top_right_Z_1_1 : forall α, (Z 1 1 α) ↕ — ⟷ ⨉ ∝ ⨉ ⟷ (— ↕ (Z 1 1 α)). -Proof. intros. solve_prop 1. Qed. - - -Lemma swap_pullthrough_top_right_Z : forall n α prfn prfm, ((Z (S n) 1 α) ↕ —) ⟷ ⨉ ∝ cast _ _ prfn prfm (n_swap _ ⟷ (— ↕ (Z (S n) 1 α))). -Proof. - intro n. - induction n; intros. - - simpl_casts. - cleanup_zx. - rewrite n_swap_2_is_swap. - rewrite swap_pullthrough_top_right_Z_1_1. - easy. - - rewrite SpiderInduction.grow_Z_left_2_1 at 1. - rewrite stack_wire_distribute_r. - rewrite compose_assoc. - rewrite IHn. - simpl_casts. - rewrite n_swap_grow_l. - rewrite compose_assoc. - rewrite (cast_compose_mid_contract _ (S (S n))). - simpl_casts. - rewrite (stack_assoc (Z 2 1 _) (n_wire n) —). - bundle_wires. - rewrite bottom_to_top_grow_r. - simpl_casts. - rewrite (cast_compose_mid (S (S n))). - erewrite <- (@cast_n_wire (S n)). - rewrite cast_stack_r. - rewrite cast_contract. - simpl_casts. - erewrite (cast_compose_mid_contract _ (S (S n)) _ _ _ _ _ _ _ (— ↕ bottom_to_top (S n)) (⨉ ↕ n_wire n)). - simpl_casts. -Abort. +Proof. + intros. + rewrite <- zx_comm_1_1_swap. + now rewrite zx_comm_commutes_r. +Qed. Lemma swap_pullthrough_top_right_X_1_1 : forall α, (X 1 1 α) ↕ — ⟷ ⨉ ∝ ⨉ ⟷ (— ↕ (X 1 1 α)). diff --git a/src/CoreRules/WireRules.v b/src/CoreRules/WireRules.v index 1ae874b..f64bd16 100644 --- a/src/CoreRules/WireRules.v +++ b/src/CoreRules/WireRules.v @@ -8,37 +8,24 @@ Lemma Z_0_is_wire : Z 1 1 0 ∝ —. Proof. intros. prop_exists_nonzero 1. - simpl. - unfold Z_semantics. - autorewrite with Cexp_db. - solve_matrix. - assert (forall x y, (x =? 0) && (y =? 0) = (x =? y) && (x <=? 0))%nat. - { - intros. - bdestruct (x0 <=? 0). - - apply Nat.le_0_r in H; subst. - rewrite Nat.eqb_refl, andb_true_r, andb_true_l. - destruct y0; easy. - - rewrite andb_false_r. - destruct x0; easy. - } - rewrite H. - easy. + rewrite Mscale_1_l. + lma'. + apply Cexp_0. Qed. Lemma Z_2_0_0_is_cap : Z 2 0 0 ∝ ⊃. Proof. prop_exists_nonzero 1. - simpl. - solve_matrix. + rewrite Mscale_1_l. + lma'. apply Cexp_0. Qed. Lemma Z_0_2_0_is_cup : Z 0 2 0 ∝ ⊂. Proof. prop_exists_nonzero 1. - simpl. - solve_matrix. + rewrite Mscale_1_l. + lma'. apply Cexp_0. Qed. @@ -46,16 +33,16 @@ Lemma yank_r : (⊂ ↕ —) ⟷ (— ↕ ⊃) ∝ —. Proof. prop_exists_nonzero 1. - simpl. - solve_matrix. + rewrite Mscale_1_l. + lma'. Qed. Lemma yank_l : (— ↕ ⊂) ⟷ (⊃ ↕ —) ∝ —. Proof. prop_exists_nonzero 1. - simpl. - solve_matrix. + rewrite Mscale_1_l. + lma'. Qed. Lemma n_wire_stack : forall n m, n_wire n ↕ n_wire m ∝ n_wire (n + m). @@ -79,42 +66,12 @@ Lemma stack_nwire_distribute_r : forall {n m o p} (zx0 : ZX n m) (zx1 : ZX m o), (zx0 ⟷ zx1) ↕ n_wire p ∝ (zx0 ↕ n_wire p) ⟷ (zx1 ↕ n_wire p). Proof. intros. - induction p. - - repeat rewrite stack_empty_r. - eapply (cast_diagrams n o). - repeat rewrite cast_contract. - rewrite cast_id. - rewrite cast_compose_distribute. - simpl_casts. - erewrite (cast_compose_mid m _ _ ($ n, m + 0 ::: zx0 $)). - simpl_casts. - easy. - Unshelve. - all: lia. - - rewrite n_stack1_r. - repeat rewrite cast_stack_r. - eapply (cast_diagrams (n + (p + 1)) (o + (p + 1))). - rewrite cast_contract. - rewrite cast_id. - rewrite cast_compose_distribute. - simpl_casts. - erewrite (cast_compose_mid (m + (p + 1)) _ _ - ($ n + (p + 1), m + (S p) ::: zx0 ↕ (n_wire p ↕ —)$)). - simpl_casts. - rewrite 3 stack_assoc_back. - eapply (cast_diagrams (n + p + 1) (o + p + 1)). - rewrite cast_contract. - rewrite cast_id. - rewrite cast_compose_distribute. - rewrite 2 cast_contract. - erewrite (cast_compose_mid (m + p + 1) _ _ - ($ n + p + 1, m + (p + 1) ::: zx0 ↕ n_wire p ↕ — $)). - simpl_casts. - rewrite <- stack_wire_distribute_r. - rewrite <- IHp. - easy. - Unshelve. - all: lia. + prop_exists_nonzero 1. + rewrite Mscale_1_l. + cbn. + rewrite n_wire_semantics. + restore_dims. + apply kron_id_dist_r; auto_wf. Qed. Lemma wire_to_n_wire : @@ -122,8 +79,7 @@ Lemma wire_to_n_wire : Proof. simpl. auto_cast_eqn (rewrite stack_empty_r). - simpl_casts. - easy. + now rewrite cast_id. Qed. Lemma wire_transpose : —⊤ ∝ —. @@ -152,8 +108,13 @@ Qed. Lemma wire_loop : — ∝ (⊂ ↕ —) ⟷ (— ↕ ⨉) ⟷ (⊃ ↕ —). Proof. prop_exists_nonzero 1. - Msimpl; simpl. - solve_matrix. + rewrite Mscale_1_l. + prep_matrix_equivalence. + cbn. + rewrite <- (make_WF_equiv _ _ (list2D_to_matrix _)). + rewrite <- (make_WF_equiv _ _ (list2D_to_matrix (_ :: _ :: _))). + match goal with |- _ ≡ ?B => compute_matrix B end. + now by_cell. Qed. Lemma n_stack_n_wire_1_n_wire : forall n, n ↑ (n_wire 1) ∝ n_wire n. diff --git a/src/CoreRules/XRules.v b/src/CoreRules/XRules.v index 7a7749d..1b4cbc8 100644 --- a/src/CoreRules/XRules.v +++ b/src/CoreRules/XRules.v @@ -3,6 +3,7 @@ Require Import WireRules. Require Import CapCupRules. Require Import CoreAutomation. Require Import SwapRules. +Require Import ZXpermFacts. Require Import ZRules. Lemma grow_X_top_left : forall (nIn nOut : nat) α, @@ -25,6 +26,9 @@ Lemma grow_X_bot_right : forall {n m} o {α}, X n (m + 1) α ⟷ (n_wire m ↕ X 1 o 0). Proof. intros. colorswap_of (@grow_Z_bot_right n m o α). Qed. +Lemma X_rot_passthrough : forall α β, + (X 1 1 α ↕ — ⟷ X 2 1 β) ∝ X 2 1 β ⟷ X 1 1 α. +Proof. intros. colorswap_of Z_rot_passthrough. Qed. Lemma X_rot_l : forall n m α β, X (S n) m (α + β) ∝ X 1 1 α ↕ n_wire n ⟷ X (S n) m β. @@ -40,6 +44,10 @@ Proof. intros. colorswap_of (@Z_add_r_base_rot n). Qed. Lemma X_add_l_base_rot : forall {n} m o {α}, X (n + m) o α ∝ (X n 1 0 ↕ X m 1 0) ⟷ X 2 o α. Proof. intros. colorswap_of (@Z_add_l_base_rot n). Qed. +Lemma X_appendix_base : forall α β, + (X 0 1 α ↕ — ⟷ X 2 1 β) ∝ X 1 1 (α + β). +Proof. intros. colorswap_of (Z_appendix_base α β). Qed. + Lemma X_appendix_rot_l : forall n m α β, X n m (α + β) ∝ (X 0 1 α ↕ n_wire n) ⟷ X (S n) m β. Proof. intros. colorswap_of Z_appendix_rot_l. Qed. @@ -169,6 +177,74 @@ Proof. colorswap_of Z_self_bottom_to_top_absorbtion_right_base. Qed. Lemma X_a_swap_absorbtion_right_base : forall n m α, X n m α ⟷ a_swap m ∝ X n m α. Proof. colorswap_of Z_a_swap_absorbtion_right_base. Qed. +Lemma X_stacked_a_swap_absorbtion_right n m0 m1 m2 α : + X n (m0 + m1 + m2) α ⟷ (n_wire m0 ↕ a_swap m1 ↕ n_wire m2) ∝ + X n (m0 + m1 + m2) α. +Proof. colorswap_of (Z_stacked_a_swap_absorbtion_right n m0 m1 m2 α). Qed. + +Lemma X_zx_to_bot_absorbtion_right n m α a : + X n m α ⟷ zx_to_bot a m ∝ X n m α. +Proof. colorswap_of (Z_zx_to_bot_absorbtion_right n m α a). Qed. + +Lemma X_zx_of_swap_list_absorbtion_right n α l : + X n (length l) α ⟷ zx_of_swap_list l ∝ X n (length l) α. +Proof. colorswap_of (Z_zx_of_swap_list_absorbtion_right n α l). Qed. + +Section Absorbtion. +(* This is a section only to localize the following hint, + which may be too costly to want to use globally *) + +Local Hint Rewrite @zxperm_colorswap_eq using auto with zxperm_db : + colorswap_db. + +Lemma X_zx_of_perm_absorbtion_right n m α f : + X n m α ⟷ zx_of_perm m f ∝ X n m α. +Proof. colorswap_of (Z_zx_of_perm_absorbtion_right n m α f). Qed. + +Lemma X_zxperm_absorbtion_right n m α (zx : ZX m m) (Hzx : ZXperm m zx) : + X n m α ⟷ zx ∝ X n m α. +Proof. colorswap_of (Z_zxperm_absorbtion_right n m α zx Hzx). Qed. + +Lemma X_zxperm_absorbtion_left n m α (zx : ZX n n) (Hzx : ZXperm n zx) : + zx ⟷ X n m α ∝ X n m α. +Proof. + transpose_of (X_zxperm_absorbtion_right m n α + (zx⊤) (transpose_zxperm Hzx)). +Qed. + +End Absorbtion. + +Lemma X_zx_comm_absorbtion_right n p q α : + X n (p + q) α ⟷ zx_comm p q ∝ + X n (q + p) α. +Proof. colorswap_of (Z_zx_comm_absorbtion_right n p q α). Qed. + +Lemma X_zx_comm_absorbtion_left p q m α : + zx_comm p q ⟷ X (q + p) m α ∝ + X (p + q) m α. +Proof. colorswap_of (Z_zx_comm_absorbtion_left p q m α). Qed. + +Lemma X_zx_gap_comm_absorbtion_right n p m q α : + X n (p + m + q) α ⟷ zx_gap_comm p m q ∝ + X n (q + m + p) α. +Proof. colorswap_of (Z_zx_gap_comm_absorbtion_right n p m q α). Qed. + +Lemma X_zx_gap_comm_absorbtion_left p n q m α : + zx_gap_comm p n q ⟷ X (q + n + p) m α ∝ + X (p + n + q) m α. +Proof. colorswap_of (Z_zx_gap_comm_absorbtion_left p n q m α). Qed. + +Lemma X_swap_pullthrough_top_right : forall n α prfn prfm, + ((X (S n) 1 α) ↕ —) ⟷ ⨉ ∝ + cast _ _ prfn prfm (n_swap _ ⟷ (— ↕ (X (S n) 1 α))). +Proof. intros. (* colorswap_of fails because it simplifies too aggressively *) + apply colorswap_diagrams. + autorewrite with colorswap_db. + cbn [color_swap]. + autorewrite with colorswap_db. + exact (Z_swap_pullthrough_top_right n α prfn prfm). +Qed. + Lemma X_n_swap_absorbtion_right_base : forall n m α, X n m α ⟷ n_swap m ∝ X n m α. Proof. colorswap_of Z_n_swap_absorbtion_right_base. Qed. diff --git a/src/CoreRules/ZRules.v b/src/CoreRules/ZRules.v index 6f6cae1..c7f6517 100644 --- a/src/CoreRules/ZRules.v +++ b/src/CoreRules/ZRules.v @@ -6,6 +6,7 @@ Require Import StackComposeRules. Require Import SwapRules. Require Import WireRules. Require Import SpiderInduction. +Require Import ZXpermFacts. Lemma grow_Z_top_left : forall (nIn nOut : nat) α, Z (S (S nIn)) nOut α ∝ @@ -39,7 +40,29 @@ Lemma grow_Z_bot_left : forall n {m o α}, Z (n + m) o α ∝ (n_wire n ↕ Z m 1 0) ⟷ Z (n + 1) o α. Proof. -Admitted. + intros n m o α. + prop_exists_nonzero 1. + cbn. + rewrite Mscale_1_l. + rewrite !Z_semantics_equiv, n_wire_semantics. + simpl. + rewrite Cexp_0. + Msimpl. + restore_dims. + distribute_plus. + distribute_scale. + rewrite 2!(kron_n_m_split n 1), !kron_n_1 by auto_wf. + rewrite !Mmult_assoc. + restore_dims. + rewrite !kron_mixed_product, !Mmult_1_r by auto_wf. + restore_dims. + rewrite <- !Mmult_assoc. + rewrite Mmult00, Mmult01, Mmult10, Mmult11. + Msimpl. + restore_dims. + Msimpl. + now rewrite <- !kron_n_m_split by auto_wf. +Qed. Lemma grow_Z_bot_right : forall {n m} o {α}, Z n (m + o) α ∝ @@ -53,13 +76,13 @@ Proof. apply grow_Z_bot_left. Qed. +Lemma Z_rot_passthrough : forall α β, + (Z 1 1 α ↕ — ⟷ Z 2 1 β) ∝ Z 2 1 β ⟷ Z 1 1 α. +Proof. intros ? ?; prop_exists_nonzero 1; lma'. Qed. Lemma Z_rot_l : forall n m α β, Z (S n) m (α + β) ∝ Z 1 1 α ↕ n_wire n ⟷ Z (S n) m β. Proof. - assert (Z_rot_passthrough : forall α β, - (Z 1 1 α ↕ — ⟷ Z 2 1 β) ∝ Z 2 1 β ⟷ Z 1 1 α). - { solve_prop 1. } induction n; intros. - cleanup_zx. simpl_casts. @@ -92,12 +115,21 @@ Proof. apply Z_rot_l. Qed. +Lemma Z_appendix_base : forall α β, + (Z 0 1 α ↕ — ⟷ Z 2 1 β) ∝ Z 1 1 (α + β). +Proof. + intros. + prop_exists_nonzero 1. + Msimpl. + prep_matrix_equivalence. + cbn; unfold Z_semantics. + rewrite Cexp_add. + by_cell; lca. +Qed. + Lemma Z_appendix_rot_l : forall n m α β, Z n m (α + β) ∝ (Z 0 1 α ↕ n_wire n) ⟷ Z (S n) m β. Proof. - assert (Z_appendix_base : forall α β, - (Z 0 1 α ↕ — ⟷ Z 2 1 β) ∝ Z 1 1 (α + β)). - { solve_prop 1. } induction n; intros. - cleanup_zx. simpl_casts. @@ -257,7 +289,13 @@ Proof. intros. transpose_of (@Z_add_r_base_rot o n m). Qed. Lemma Z_1_2_1_fusion : forall α β, (Z 1 2 α ⟷ Z 2 1 β) ∝ (Z 1 1 (α + β)). -Proof. solve_prop 1. Qed. +Proof. + prop_exists_nonzero 1. + prep_matrix_equivalence. + cbn; unfold Z_semantics. + rewrite Cexp_add. + by_cell; lca. +Qed. Lemma Z_absolute_fusion : forall {n m o} α β, (Z n (S m) α ⟷ Z (S m) o β) ∝ @@ -398,25 +436,14 @@ Proof. intros. prop_exists_nonzero 1. Msimpl. - simpl. - solve_matrix. - replace ((2 ^ n + (2 ^ n + 0) - 1)%nat) with (2 ^ (S n) - 1)%nat by (simpl; lia). - assert (exists n', 2 ^ S n = (S (S n')))%nat. - { - intros. - induction n. - - exists 0%nat. - easy. - - destruct IHn. - rewrite Nat.pow_succ_r'. - rewrite H. - exists ((2 * x + 2))%nat. - lia. - } - destruct H. - rewrite H. - simpl. - lca. + prep_matrix_equivalence. + intros i j Hi Hj. + destruct i as [|[]]; [..|cbn in Hi; lia]; + cbn; [|lca]. + destruct j; [destruct n; cbn -[Nat.eqb]; + [cbn|pose proof (Modulus.pow2_nonzero n); + Modulus.bdestructΩ']; lca|]. + Modulus.bdestructΩ'; lca. Qed. Lemma Z_self_cap_absorbtion_top : forall {n m α}, (Z) n (S (S m)) α ⟷ (⊃ ↕ n_wire m) ∝ Z n m α. @@ -458,7 +485,7 @@ Proof. Qed. Lemma Z_self_swap_absorbtion_right_base : forall {n α}, Z n 2 α ⟷ ⨉ ∝ Z n 2 α. -Proof. intros. solve_prop 1. Qed. +Proof. intros. prop_exists_nonzero 1. lma'. Qed. Lemma Z_self_swap_absorbtion_right_top : forall {n m α}, Z n (S (S m)) α ⟷ (⨉ ↕ n_wire m) ∝ Z n (S (S m)) α. Proof. @@ -512,7 +539,7 @@ Proof. repeat rewrite cast_compose_distribute. simpl_casts. erewrite (@cast_compose_mid (n + 0) (n + 1 + 1) 3 (n + 2) _ _ ($ n + 0, n + 1 + 1 ::: n_wire n ↕ ⊂ $)). - simpl_casts. + rewrite !cast_contract, !cast_id. rewrite <- Z_0_2_0_is_cup. bundle_wires. rewrite <- (stack_compose_distr @@ -559,20 +586,18 @@ Proof. induction m; intros. - simpl. cleanup_zx. - simpl_casts. - bundle_wires. - cleanup_zx. - rewrite Z_self_swap_absorbtion_right_base. - easy. + rewrite cast_id. + rewrite wire_to_n_wire, n_wire_stack, nwire_removal_r. + apply Z_self_swap_absorbtion_right_base. - rewrite top_to_bottom_grow_r. erewrite <- (@cast_Z n _ ((S (S m)) + 1)). rewrite Z_add_r_base_rot. rewrite (cast_compose_mid ((S (S m)) + 1)). rewrite cast_contract. - simpl_casts. + rewrite cast_id. rewrite compose_assoc. rewrite cast_compose_l. - simpl_casts. + rewrite !cast_contract, cast_id. rewrite <- (compose_assoc (Z 1 (S (S m)) 0 ↕ Z 1 1 0)). rewrite <- stack_compose_distr. rewrite IHm. @@ -586,8 +611,7 @@ Proof. replace ⦰ with (n_wire 0) by easy. rewrite cast_id. rewrite Z_self_swap_absorbtion_right. - simpl_casts. - easy. + apply cast_Z. Unshelve. all: lia. Qed. @@ -604,11 +628,8 @@ Proof. unfold bottom_to_top, top_to_bottom. simpl. cleanup_zx. - simpl_casts. - bundle_wires. - cleanup_zx. - rewrite Z_self_swap_absorbtion_right_base. - easy. + rewrite cast_id, wire_to_n_wire, n_wire_stack, nwire_removal_l. + apply Z_self_swap_absorbtion_right_base. - rewrite bottom_to_top_grow_r. erewrite <- (@cast_Z n _ (1 + (S (S m)))). rewrite Z_add_r_base_rot. @@ -656,36 +677,146 @@ Unshelve. all: lia. Qed. -Lemma Z_n_swap_absorbtion_right_base : forall n m α, Z n m α ⟷ n_swap m ∝ Z n m α. +Lemma Z_stacked_a_swap_absorbtion_right n m0 m1 m2 α : + Z n (m0 + m1 + m2) α ⟷ (n_wire m0 ↕ a_swap m1 ↕ n_wire m2) ∝ + Z n (m0 + m1 + m2) α. Proof. - intros n m. - generalize dependent n. - strong induction m. - intros. - destruct m; [ simpl; cleanup_zx; easy | ]. - destruct m; [ simpl; cleanup_zx; easy | ]. - simpl. - rewrite <- compose_assoc. - rewrite (Z_self_bottom_to_top_absorbtion_right_base n (S (S m)) α). - rewrite <- (@cast_Z n _ (1 + (S m))) at 1. - rewrite Z_add_r_base_rot at 1. - simpl_casts. + rewrite 2!Z_add_r_base_rot, compose_assoc. + rewrite <- (nwire_removal_l (Z 1 m2 0)). + rewrite stack_compose_distr, compose_assoc. + rewrite <- stack_compose_distr. + rewrite <- (stack_compose_distr (Z 1 m0 0)). + rewrite 2!nwire_removal_r. + now rewrite Z_a_swap_absorbtion_right_base. +Qed. + +Lemma Z_zx_to_bot_absorbtion_right n m α a : + Z n m α ⟷ zx_to_bot a m ∝ + Z n m α. +Proof. + unfold zx_to_bot. + rewrite cast_Z_contract_r. + rewrite grow_Z_bot_right, compose_assoc, <- stack_compose_distr. + rewrite Z_a_swap_absorbtion_right_base, nwire_removal_l. + rewrite <- grow_Z_bot_right. + now simpl_casts. +Qed. + +Lemma Z_zx_of_swap_list_absorbtion_right n α l : + Z n (length l) α ⟷ zx_of_swap_list l ∝ + Z n (length l) α. +Proof. + revert n α; + induction l; intros n α. + - simpl. + now cleanup_zx. + - simpl. + rewrite <- compose_assoc. + rewrite Z_zx_to_bot_absorbtion_right. + rewrite cast_Z_contract_r. + rewrite Z_add_r_base_rot, compose_assoc. + rewrite <- (stack_compose_distr (Z 1 (length l) 0)). + rewrite wire_removal_r, IHl. + rewrite <- Z_add_r_base_rot. + now simpl_casts. +Qed. + +Lemma Z_zx_of_perm_absorbtion_right n m α f : + Z n m α ⟷ zx_of_perm m f ∝ + Z n m α. +Proof. + unfold zx_of_perm. + rewrite cast_Z_contract_r. + unfold zx_of_perm_uncast. + rewrite Z_zx_of_swap_list_absorbtion_right. + now simpl_casts. +Qed. + +Lemma Z_zxperm_absorbtion_right n m α + (zx : ZX m m) (Hzx : ZXperm m zx) : + Z n m α ⟷ zx ∝ + Z n m α. +Proof. + rewrite <- (zx_of_perm_of_zx Hzx). + apply Z_zx_of_perm_absorbtion_right. +Qed. + +Lemma Z_zxperm_absorbtion_left n m α + (zx : ZX n n) (Hzx : ZXperm n zx) : + zx ⟷ Z n m α ∝ + Z n m α. +Proof. + transpose_of (Z_zxperm_absorbtion_right m n α + (zx⊤) (transpose_zxperm Hzx)). +Qed. + +Lemma Z_zx_comm_absorbtion_right n p q α : + Z n (p + q) α ⟷ zx_comm p q ∝ + Z n (q + p) α. +Proof. + unfold zx_comm. + rewrite cast_Z_contract_r, Z_zx_of_perm_absorbtion_right. + now simpl_casts. +Qed. + +Lemma Z_zx_comm_absorbtion_left p q m α : + zx_comm p q ⟷ Z (q + p) m α ∝ + Z (p + q) m α. +Proof. transpose_of (Z_zx_comm_absorbtion_right m q p α). Qed. + +Lemma Z_zx_gap_comm_absorbtion_right n p m q α : + Z n (p + m + q) α ⟷ zx_gap_comm p m q ∝ + Z n (q + m + p) α. +Proof. + unfold zx_gap_comm. + rewrite cast_Z_contract_r. + rewrite <- compose_assoc, Z_zx_comm_absorbtion_right. + rewrite grow_Z_bot_right, compose_assoc, <- stack_nwire_distribute_l. + rewrite Z_zx_comm_absorbtion_right. + rewrite <- grow_Z_bot_right. + now simpl_casts. +Qed. + +Lemma Z_zx_gap_comm_absorbtion_left p n q m α : + zx_gap_comm p n q ⟷ Z (q + n + p) m α ∝ + Z (p + n + q) m α. +Proof. transpose_of (Z_zx_gap_comm_absorbtion_right m q n p α). Qed. + +Lemma Z_swap_pullthrough_top_right : forall n α prfn prfm, + ((Z (S n) 1 α) ↕ —) ⟷ ⨉ ∝ + cast _ _ prfn prfm (n_swap _ ⟷ (— ↕ (Z (S n) 1 α))). +Proof. + intros. + rewrite swap_commutes_r. + auto_cast_eqn rewrite (cast_compose_mid_contract _ (1 + (1 + n))%nat). + rewrite n_swap_grow_l. + auto_cast_eqn rewrite (cast_compose_mid_contract _ (1 + (1 + n))%nat). + rewrite cast_id. + (* rewrite cast_fn_eq_dim. *) + change (S n) with (1 + n)%nat. + change 2%nat with (1 + 1)%nat. + auto_cast_eqn rewrite cast_stack_distribute. + rewrite 2!cast_id. rewrite compose_assoc. - rewrite <- (stack_compose_distr (Z 1 1 0) —). - rewrite <- compose_assoc. - rewrite (Z_self_bottom_to_top_absorbtion_right_base). - rewrite <- (@cast_Z 1 _ (1 + m) (S m)). - rewrite Z_add_r_base_rot. + rewrite <- stack_wire_distribute_l. + rewrite Z_zxperm_absorbtion_left by auto with zxperm_db. + apply compose_simplify; [|easy]. + unfold zx_comm. simpl_casts. - rewrite compose_assoc. - rewrite <- (stack_compose_distr (Z 1 1 0) —). - rewrite (H m); [ | lia ]. - rewrite wire_removal_r. - rewrite <- (Z_add_r_base_rot 1 m). - rewrite <- (Z_add_r_base_rot 1 (1 + m)). - easy. -Unshelve. - all: lia. + by_perm_eq_nosimpl. + rewrite perm_of_bottom_to_top_eq. + change (S (1 + n)) with (1 + (1 + n))%nat. + rewrite (Nat.add_comm 1 (1 + n)). + cleanup_perm_of_zx. + rewrite rotl_eq_rotr_sub. + rewrite Nat.mod_small by lia. + now rewrite Nat.add_sub. +Qed. + +Lemma Z_n_swap_absorbtion_right_base : forall n m α, Z n m α ⟷ n_swap m ∝ Z n m α. +Proof. + intros. + apply Z_zxperm_absorbtion_right; auto with zxperm_db. Qed. Lemma Z_n_wrap_under_r_base_unswapped : forall n m α, Z (n + m) 0 α ∝ (Z n m α ↕ n_wire m) ⟷ n_cup_unswapped m. diff --git a/src/CoreRules/ZXRules.v b/src/CoreRules/ZXRules.v index f1afa10..04724a0 100644 --- a/src/CoreRules/ZXRules.v +++ b/src/CoreRules/ZXRules.v @@ -16,35 +16,48 @@ Proof. assert (X_state_copy_ind : (X 0 1 (INR r * PI) ⟷ Z 1 2 0) ∝ X 0 1 (INR r * PI) ↕ X 0 1 (INR r * PI)). { - prop_exists_nonzero (/ (√ 2)%R); Msimpl; simpl. - unfold X_semantics; unfold Z_semantics. - simpl. solve_matrix. - all: autorewrite with Cexp_db. - all: destruct (INR_pi_exp r); rewrite H. - all: try lca; C_field_simplify; try lca. - all: nonzero. + prop_exists_nonzero (/ (√ 2)%R). + prep_matrix_equivalence. + cbn. + unfold X_semantics. + rewrite kron_n_1, Mmult_1_r by auto_wf. + rewrite <- kron_mixed_product. + restore_dims. + compute_matrix (hadamard ⊗ hadamard). + group_radicals. + compute_matrix + (Z_semantics 0 1 (INR r * PI) ⊗ Z_semantics 0 1 (INR r * PI)). + compute_matrix (Z_semantics 1 2 0). + rewrite Cexp_0. + rewrite <- Cexp_add, <- Rmult_plus_distr_r, <- plus_INR. + rewrite double_mult, mult_INR. + rewrite !INR_IZR_INZ, <- mult_IZR, Cexp_2nPI. + unfold scale; + by_cell; cbn; lca. } induction n; [| destruct n]. - - simpl. - simpl_casts. - prop_exists_nonzero (√ 2)%R; Msimpl; simpl. - unfold X_semantics; unfold Z_semantics. - simpl. - solve_matrix. - destruct (INR_pi_exp r); rewrite H. - all: autorewrite with Cexp_db. - all: C_field_simplify; try lca; try nonzero. + - simpl. + rewrite cast_id. + prop_exists_nonzero (√ 2)%R; Msimpl. + cbn; unfold X_semantics. + rewrite kron_n_1, Mmult_1_r by auto_wf. + prep_matrix_equivalence. + by_cell; unfold scale; + cbn. + rewrite Cexp_0. + C_field. + lca. - simpl. rewrite Z_0_is_wire. - simpl_casts. + rewrite cast_id. rewrite stack_empty_r. - simpl_casts. + rewrite cast_id. cleanup_zx. easy. - eapply (cast_diagrams (S (S n) * 0) (S (S n) * 1)). rewrite cast_contract. rewrite cast_compose_distribute. - simpl_casts. + rewrite cast_X, cast_Z, cast_id. simpl. eapply (@cast_simplify 0 (S n * 0)%nat (S n) (S n * 1)%nat) in IHn. rewrite cast_compose_distribute in IHn. @@ -61,7 +74,7 @@ Proof. rewrite X_state_copy_ind. cleanup_zx. rewrite (stack_assoc (X 0 1 (INR r * PI)) (X 0 1 (INR r * PI))). - simpl_casts. + rewrite cast_id. easy. Unshelve. all: lia. @@ -149,32 +162,43 @@ Proof. assert (Z_copy_ind : (Z 1 1 (INR r * PI) ⟷ X 1 2 0) ∝ X 1 2 0 ⟷ (Z 1 1 (INR r * PI) ↕ Z 1 1 (INR r * PI))). { - prop_exists_nonzero (1); Msimpl; simpl. - unfold X_semantics; unfold Z_semantics. - simpl. solve_matrix. - all: autorewrite with Cexp_db. - all: destruct (INR_pi_exp r); rewrite H. - all: try lca; C_field_simplify; try lca. - all: nonzero. + prop_exists_nonzero (1); rewrite Mscale_1_l. + cbn. + rewrite <- X_semantics_transpose, X_2_1_0_semantics. + restore_dims. + compute_matrix (Z_semantics 1 1 (INR r * PI) + ⊗ Z_semantics 1 1 (INR r * PI)). + rewrite <- Cexp_add, <- Rmult_plus_distr_r, + <- plus_INR, double_mult, mult_INR, + !INR_IZR_INZ, <- mult_IZR. + rewrite Cexp_2nPI. + lma'. } eapply (cast_diagrams 1 (n * 1)). rewrite 2 cast_compose_distribute. simpl_casts. erewrite (@cast_compose_mid _ _ _ (n * 1)%nat _ _ (X 1 n 0)). - simpl_casts. + rewrite cast_X, cast_contract, cast_id. induction n; [ | destruct n]. - simpl. - solve_prop 1. + prop_exists_nonzero 1. + rewrite Mscale_1_l. + prep_matrix_equivalence. + cbn. + unfold X_semantics. + rewrite kron_n_1, 2!Mmult_1_l by auto_wf. + by_cell; cbn; + rewrite Cexp_0; + lca. - simpl. repeat rewrite X_0_is_wire. cleanup_zx. - simpl_casts. - easy. + now rewrite cast_id. - simpl. rewrite grow_X_top_right. simpl in IHn. rewrite <- compose_assoc. - rewrite IHn. + rewrite IHn by lia. rewrite compose_assoc. rewrite <- (stack_compose_distr (Z 1 1 (INR r * PI)) (X 1 2 0) @@ -185,7 +209,7 @@ Proof. rewrite stack_compose_distr. rewrite compose_assoc. rewrite (stack_assoc (Z 1 1 (INR r * PI))). - simpl_casts. + rewrite cast_id. easy. Unshelve. all: lia. diff --git a/src/DiagramRules/Bell.v b/src/DiagramRules/Bell.v index f65d316..8849708 100644 --- a/src/DiagramRules/Bell.v +++ b/src/DiagramRules/Bell.v @@ -12,7 +12,8 @@ Proof. assert (X 0 1 0 ⟷ □ ∝ Z 0 1 0) as H. { replace (X 0 1 0) with (⊙ (Z 0 1 0)) at 1 by easy. - rewrite colorswap_is_bihadamard; simpl; cleanup_zx; simpl_casts. + rewrite colorswap_is_bihadamard; simpl. + cleanup_zx. rewrite cast_id. rewrite compose_assoc; cleanup_zx; easy. } rewrite H; cleanup_zx. @@ -25,7 +26,7 @@ Proof. rewrite (stack_assoc (n_wire 1) (n_wire 1)); simpl_casts. rewrite <- (stack_compose_distr (n_wire 1) (n_wire 1) (n_wire 1 ↕ X 0 1 0)). rewrite (dominated_X_spider_fusion_bot_right 0 0 1). - cleanup_zx; simpl_casts. + cleanup_zx; rewrite cast_id. rewrite Rplus_0_r; rewrite X_0_is_wire. bundle_wires; cleanup_zx. rewrite <- cap_Z. @@ -49,22 +50,20 @@ Proof. } rewrite H. rewrite (stack_empty_r_rev (X 1 0 _)). - simpl_casts. + rewrite cast_id. rewrite <- (stack_compose_distr (X 2 1 0) (X 1 0 _) (Z 1 0 _) ⦰). rewrite X_spider_1_1_fusion. cleanup_zx. rewrite (stack_assoc_back (X 1 1 _ ⟷ Z 1 1 _) (X 2 0 _) (Z 1 0 _)). - simpl_casts. + rewrite cast_id. rewrite <- (nwire_removal_l (X 2 0 _)). - simpl; rewrite stack_empty_r; simpl_casts. + simpl; rewrite stack_empty_r, cast_id. rewrite stack_compose_distr. - rewrite (stack_assoc_back (X 1 1 _) — —). - simpl_casts. + rewrite (stack_assoc_back (X 1 1 _) — —), cast_id. rewrite <- (compose_empty_r (Z 1 0 _)). rewrite stack_compose_distr. rewrite <- compose_assoc. - rewrite (stack_assoc (X 1 1 _ ↕ —) — (Z 1 0 _)). - simpl_casts. + rewrite (stack_assoc (X 1 1 _ ↕ —) — (Z 1 0 _)), cast_id. rewrite <- (stack_compose_distr ⊂ (X 1 1 _ ↕ —) (Z 1 2 0) (— ↕ Z 1 0 _)). rewrite cap_X. rewrite wire_to_n_wire at 1 2. @@ -77,11 +76,11 @@ Proof. rewrite (X_add_l 1 1). rewrite stack_nwire_distribute_l. rewrite (stack_assoc_back (n_wire 1) (X 1 1 _)). - rewrite stack_empty_r. - simpl_casts. + rewrite stack_empty_r, !cast_id. rewrite compose_assoc. rewrite <- (compose_assoc (X 0 (1 + 1) _ ↕ Z 1 (1 + 0) _)). - rewrite <- (stack_compose_distr (X 0 (1 + 1) _) (n_wire 1 ↕ X 1 1 _) (Z 1 (1 + 0) _) (X 1 1 _)). + rewrite <- (stack_compose_distr (X 0 (1 + 1) _) (n_wire 1 ↕ X 1 1 _) + (Z 1 (1 + 0) _) (X 1 1 _)). rewrite (dominated_X_spider_fusion_bot_left 1 0). replace ((INR b * PI + (INR b * PI + 0)))%R with (INR b * 2 * PI)%R by lra. rewrite X_2_PI. @@ -93,12 +92,12 @@ Proof. repeat rewrite <- compose_assoc. rewrite (compose_assoc (n_wire 0 ↕ Z 1 (1 + 0) (INR a * PI + 0))). rewrite yank_r. - cleanup_zx; simpl_casts. + cleanup_zx. rewrite cast_id. rewrite Z_spider_1_1_fusion. replace (INR a * PI + 0 + INR a * PI)%R with ((INR a * 2 * PI))%R by lra. rewrite Z_2_PI. rewrite Z_0_is_wire. easy. Unshelve. -all: lia. +all: reflexivity. Qed. \ No newline at end of file diff --git a/src/DiagramRules/Bialgebra.v b/src/DiagramRules/Bialgebra.v index f282b22..fb4912d 100644 --- a/src/DiagramRules/Bialgebra.v +++ b/src/DiagramRules/Bialgebra.v @@ -1,63 +1,62 @@ +Require Import ZXpermFacts. Require Import CoreData. Require Import CoreRules. -Definition bi_alg_Z_X := ((Z_Spider 1 2 0) ↕ (Z_Spider 1 2 0) ⟷ (— ↕ ⨉ ↕ —) ⟷ ((X_Spider 2 1 0) ↕ (X_Spider 2 1 0))). -Definition bi_alg_X_Z := ((X_Spider 1 2 0) ↕ (X_Spider 1 2 0) ⟷ (— ↕ ⨉ ↕ —) ⟷ ((Z_Spider 2 1 0) ↕ (Z_Spider 2 1 0))). +Definition bi_alg_Z_X := ((Z_Spider 1 2 0) ↕ (Z_Spider 1 2 0) + ⟷ (— ↕ ⨉ ↕ —) ⟷ ((X_Spider 2 1 0) ↕ (X_Spider 2 1 0))). +Definition bi_alg_X_Z := ((X_Spider 1 2 0) ↕ (X_Spider 1 2 0) + ⟷ (— ↕ ⨉ ↕ —) ⟷ ((Z_Spider 2 1 0) ↕ (Z_Spider 2 1 0))). Theorem bi_algebra_rule_Z_X : (X_Spider 2 1 0) ⟷ (Z_Spider 1 2 0) ∝ bi_alg_Z_X. Proof. - prop_exists_nonzero 1. + prop_exists_nonzero (√ 2). simpl. - rewrite X_semantics_equiv, Z_semantics_equiv. - unfold_dirac_spider. - autorewrite with Cexp_db. + unfold X_semantics. + cbn [kron_n]. Msimpl. - repeat rewrite kron_plus_distr_l. - repeat rewrite kron_plus_distr_r. - repeat rewrite kron_plus_distr_l. - repeat rewrite Mmult_plus_distr_l. - repeat rewrite Mmult_plus_distr_r. - repeat rewrite Mmult_plus_distr_l. - assert (forall (ket0 : Matrix 2 1) (bra0 : Matrix 1 2) (ket1 : Matrix 2 1) (bra1 : Matrix 1 2), - WF_Matrix ket0 -> WF_Matrix ket1 -> - ket0⊤ = bra0 -> ket1⊤ = bra1 -> - (ket0 × (bra0 ⊗ bra0)) ⊗ (ket1 × (bra1 ⊗ bra1)) × (I 2 ⊗ swap ⊗ I 2) - = (ket0 × (bra0 ⊗ bra1) ⊗ (ket1 × (bra0 ⊗ bra1))))%M. - { - intros. - subst bra0 bra1. - rewrite kron_assoc; try auto with wf_db. - rewrite <- 2 kron_mixed_product. - rewrite Mmult_assoc. - apply Mmult_simplify; [ easy | ]. - restore_dims. - repeat rewrite kron_assoc by auto with wf_db. - rewrite (kron_mixed_product (ket0⊤) (ket0⊤ ⊗ (ket1⊤ ⊗ ket1⊤)) (I 2) _)%M. - Msimpl. - apply kron_simplify; [ easy | ]. - rewrite <- 2 kron_assoc by auto with wf_db. - rewrite (kron_mixed_product (ket0⊤ ⊗ ket1⊤) (ket1⊤) swap _)%M. - Msimpl. - apply kron_simplify; [ | easy]. - apply transpose_matrices. - rewrite Mmult_transpose. - rewrite swap_transpose. - rewrite <- 2 kron_transpose. - rewrite 2 Matrix.transpose_involutive. - rewrite swap_spec by auto with wf_db. - easy. - } - repeat rewrite <- Mmult_assoc. restore_dims. - rewrite bra0_equiv, bra1_equiv, ket0_equiv, ket1_equiv. - repeat rewrite H; try auto with wf_db. - 2-9: apply transpose_matrices; try rewrite braplus_transpose_ketplus; try rewrite braminus_transpose_ketminus; rewrite Matrix.transpose_involutive; easy. + Import ZXpermAutomation. + compute_matrix (hadamard × Z_semantics 2 1 0 × (hadamard ⊗ hadamard)). + rewrite Cexp_0, 2!Cmult_1_r. + group_radicals. + autorewrite with C_db. + rewrite Cmult_comm, <- Cmult_assoc. + autorewrite with C_db. + change (2)%nat with (2^1)%nat. + rewrite <- perm_to_matrix_idn. + replace swap with (perm_to_matrix 2 (swap_perm 0 1 2)) by + (prep_matrix_equivalence; by_cell; reflexivity). + restore_dims. + rewrite <- perm_to_matrix_of_stack_perms by auto with perm_db. restore_dims. - repeat rewrite (kron_mixed_product (xbasis_plus × (_ ⊗ _)) (xbasis_plus × (_ ⊗ _)) ((ket _ ⊗ ket _) × bra _) ((ket _ ⊗ ket _) × bra _)). - repeat rewrite (kron_mixed_product (xbasis_minus × (_ ⊗ _)) (xbasis_minus × (_ ⊗ _)) ((ket _ ⊗ ket _) × bra _) ((ket _ ⊗ ket _) × bra _)). - repeat rewrite Mmult_assoc. -Admitted. + rewrite <- perm_to_matrix_of_stack_perms by auto with perm_db. + cbn. + restore_dims. + compute_matrix (Z_semantics 1 2 0 ⊗ Z_semantics 1 2 0). + unfold perm_to_matrix. + rewrite perm_mat_permutes_matrix_r_eq by auto with wf_db perm_db. + unfold perm_inv; + simpl; + match goal with |- context[@make_WF ?n ?m ?A] => + match A with + | list2D_to_matrix _ => fail + | _ => compute_matrix (@make_WF n m A) + end + end. + rewrite Cexp_0; Csimpl. + symmetry. + rewrite Mscale_inv by nonzero. + match goal with |- ?A = ?B => compute_matrix B end. + match goal with |- context [?A ⊗ ?B] => compute_matrix (A ⊗ B) end. + group_radicals. + rewrite Cexp_0. + Csimpl. + prep_matrix_equivalence. + rewrite !make_WF_equiv. + unfold Mmult. + by_cell; cbn; lca. +Qed. Theorem bi_algebra_rule_X_Z : (Z_Spider 2 1 0) ⟷ (X_Spider 1 2 0) ∝ bi_alg_X_Z. @@ -69,6 +68,31 @@ Qed. Theorem hopf_rule_Z_X : (Z_Spider 1 2 0) ⟷ (X_Spider 2 1 0) ∝ (Z_Spider 1 0 0) ⟷ (X_Spider 0 1 0). Proof. + (* Faster, semantic proof: + + prop_exists_nonzero (/2). + prep_matrix_equivalence. + simpl. + unfold X_semantics. + cbn [kron_n]. + rewrite kron_1_l, Mmult_1_r by (auto using WF_Matrix_dim_change with wf_db). + rewrite (Z_semantics_comm 1 2 0), (Z_semantics_comm 1 0 0), Ropp_0. + restore_dims. + compute_matrix (hadamard × Z_semantics 2 1 0 × (hadamard ⊗ hadamard)). + compute_matrix (hadamard × Z_semantics 0 1 0). + rewrite Cexp_0. + rewrite 2!Cmult_1_r. + group_radicals. + rewrite Copp_involutive, 2!Cplus_opp_r. + rewrite <- Cmult_plus_distr_l, Cplus_div2, Cmult_1_r, <- Cdouble. + compute_matrix (Z_semantics 2 1 0). + compute_matrix (Z_semantics 0 1 0). + rewrite !make_WF_equiv. + rewrite Cexp_0. + replace (C2 * /√2) with (√2 : C) by C_field. + unfold adjoint, Mmult, scale. + by_cell; cbn; rewrite ?Cconj_R; try lca; C_field. + *) intros. rewrite <- (@nwire_removal_r 2). simpl. @@ -176,7 +200,7 @@ Transparent n_stack1. rewrite Hr. easy. Unshelve. -all: lia. +all: reflexivity. Qed. Theorem hopf_rule_X_Z : diff --git a/src/DiagramRules/Completeness.v b/src/DiagramRules/Completeness.v index 34341ce..33e4eb4 100644 --- a/src/DiagramRules/Completeness.v +++ b/src/DiagramRules/Completeness.v @@ -8,29 +8,16 @@ Require Import CompletenessComp. Lemma completeness_SUP : forall α, ((Z 0 1 α) ↕ (Z 0 1 (α + PI))) ⟷ (X 2 1 0) ∝ Z 0 2 (2 *α + PI) ⟷ X 2 1 0. Proof. intros. - prop_exists_nonzero 1; - simpl; - unfold X_semantics. - solve_matrix. - - C_field_simplify; [ | split; nonzero ]. - repeat rewrite Cexp_add. - autorewrite with Cexp_db. - C_field_simplify. - repeat rewrite <- Cexp_add. - replace ((R1 + R1)%R, (R0 + R0)%R) with C2 by lca. - apply Cplus_simplify; try easy. - rewrite <- 3 Cmult_assoc. - apply Cmult_simplify; try easy. - rewrite Cmult_assoc. - rewrite <- Cexp_add. - replace (α + α)%R with (2 * α)%R by lra. - lca. - - C_field_simplify; [ | split; nonzero ]. - repeat rewrite Cexp_add. - autorewrite with Cexp_db. - C_field_simplify. - repeat rewrite <- Cexp_add. - lca. + prop_exists_nonzero 1. + (* prep_matrix_equivalence. *) + rewrite Mscale_1_l. + cbn [ZX_semantics Nat.add]. + rewrite X_2_1_0_semantics. + compute_matrix (Z_semantics 0 1 α ⊗ Z_semantics 0 1 (α + PI)). + compute_matrix (Z_semantics 0 2 (2 * α + PI)). + rewrite <- Cexp_add, <- Rplus_assoc, 3!Cexp_plus_PI, Rplus_diag. + prep_matrix_equivalence. + by_cell; lca. Qed. (* @nocheck name *) @@ -51,11 +38,11 @@ Proof. (* solve matrix takes forever *) simpl. rewrite Heqcs1. rewrite Heqcs1pi. - clear Heqcs1; clear Heqcs1pi; clear cs1; clear cs1pi. + clear cs1 cs1pi Heqcs1 Heqcs1pi. rewrite c_step_1, c_step_1_pi. autorewrite with scalar_move_db. rewrite Cmult_1_l. - apply Mscale_simplify; [| C_field]. + apply Mscale_simplify; [| easy]. replace ((Cexp β .* ∣0⟩⟨0∣ .+ ∣0⟩⟨1∣ .+ ∣1⟩⟨0∣ .+ Cexp β .* ∣1⟩⟨1∣)) with (Cexp β .* (I 2) .+ ∣0⟩⟨1∣ .+ ∣1⟩⟨0∣) by (rewrite <- Mplus01; lma). replace ((∣0⟩⟨0∣ .+ Cexp α .* ∣0⟩⟨1∣ .+ Cexp α .* ∣1⟩⟨0∣ .+ ∣1⟩⟨1∣)) with (I 2 .+ Cexp α .* (∣0⟩⟨1∣ .+ ∣1⟩⟨0∣)) by (rewrite <- Mplus01; lma). fold (⟦ Z 1 2 0 ⟧). diff --git a/src/DiagramRules/CompletenessComp.v b/src/DiagramRules/CompletenessComp.v index 2bd876e..6084a1a 100644 --- a/src/DiagramRules/CompletenessComp.v +++ b/src/DiagramRules/CompletenessComp.v @@ -2,6 +2,8 @@ Require Import CoreData. From QuantumLib Require Import Polar. Require Import CoreRules. +Import Complex. + Lemma c_step_1 : forall α, ⟦ (Z 0 1 α ↕ —) ⟷ X 2 1 0 ⟧ = /(√2)%R .* (∣0⟩⟨0∣ .+ @@ -26,8 +28,12 @@ Proof. Msimpl. unfold xbasis_minus, xbasis_plus, braplus, braminus. autorewrite with scalar_move_db. - replace ((/ (√ 2)%R + Cexp α * / (√ 2)%R) * / (√ 2)%R * / (√ 2)%R) with ((1 + Cexp α) / (2 * (√2)%R)) by C_field. - replace ((/ (√ 2)%R + Cexp α * - / (√ 2)%R) * / (√ 2)%R * / (√ 2)%R) with ((1 - Cexp α) / (2 * (√2)%R)) by C_field. + + assert (H : ((/ (√ 2)%R + Cexp α * / (√ 2)%R) * / (√ 2)%R * / (√ 2)%R)%C + = ((1 + Cexp α) / (2 * (√2)%R)) )by C_field. + rewrite H. + replace ((/ (√ 2)%R + Cexp α * - / (√ 2)%R) * / (√ 2)%R * / (√ 2)%R) + with ((1 - Cexp α) / (2 * (√2)%R)) by C_field. repeat rewrite Mmult_plus_distr_r. repeat rewrite Mmult_plus_distr_l. remember ((C1 + Cexp α) / (C2 * (√ 2)%R)) as σ1. @@ -220,12 +226,10 @@ Proof. repeat rewrite kron_mixed_product. Msimpl. repeat rewrite Mmult_assoc. - replace (⟨-∣×σx) with (-1 .* ⟨-∣) by solve_matrix. - replace (⟨+∣×σx) with (⟨+∣). + replace (⟨-∣×σx) with (-1 .* ⟨-∣) by lma'. + replace (⟨+∣×σx) with (⟨+∣) by lma'. autorewrite with scalar_move_db. lma. - unfold braplus. - solve_matrix. Qed. Lemma c_step_3_flipped : forall γ, @@ -235,7 +239,7 @@ Proof. intros. rewrite ZX_semantic_equiv. unfold_dirac_spider. - autorewrite with Cexp_db. + rewrite Cexp_0. Msimpl. rewrite kron_plus_distr_r. rewrite kron_plus_distr_l. @@ -269,12 +273,10 @@ Proof. repeat rewrite kron_mixed_product. Msimpl. repeat rewrite Mmult_assoc. - replace (⟨-∣×σx) with (-1 .* ⟨-∣) by solve_matrix. - replace (⟨+∣×σx) with (⟨+∣). + replace (⟨-∣×σx) with (-1 .* ⟨-∣) by lma'. + replace (⟨+∣×σx) with (⟨+∣) by lma'. autorewrite with scalar_move_db. lma. - unfold braplus. - solve_matrix. Qed. (* @nocheck name *) diff --git a/src/Gates/GateRules.v b/src/Gates/GateRules.v index f15489c..d9ac509 100644 --- a/src/Gates/GateRules.v +++ b/src/Gates/GateRules.v @@ -8,49 +8,58 @@ Local Open Scope ZX_scope. Lemma Z_is_Z : ⟦ _Z_ ⟧ = σz. Proof. - simpl. - unfold Z_semantics. - autorewrite with Cexp_db. - simpl. - solve_matrix. + apply z_1_1_pi_σz. Qed. Lemma X_is_X : ⟦ _X_ ⟧ = σx. Proof. - simpl. - unfold X_semantics; solve_matrix. - all: autorewrite with Cexp_db. - all: C_field_simplify; try lca. - all: split; nonzero. + apply x_1_1_pi_σx. Qed. Lemma _H_is_box : _H_ ∝ □. Proof. prop_exists_nonzero (Cexp (PI/4)). + prep_matrix_equivalence. simpl. - unfold X_semantics, Z_semantics. - Msimpl. - solve_matrix; - field_simplify_eq [Cexp_PI2 Cexp_PI4 Ci2 Csqrt2_sqrt2_inv Csqrt2_inv]; - try apply c_proj_eq; try simpl; try R_field_simplify; try reflexivity; (try split; try apply RtoC_neq; try apply sqrt2_neq_0; try auto). + unfold X_semantics. + rewrite kron_n_1 by auto_wf. + restore_dims. + rewrite Mmult_assoc. + restore_dims. + compute_matrix (hadamard × Z_semantics 1 1 (PI / 2) + × (hadamard × Z_semantics 1 1 (PI / 2))). + group_radicals. + rewrite <- Cmult_assoc, <- Cexp_add. + replace (PI/2+PI/2)%R with PI by lra. + compute_matrix (Z_semantics 1 1 (PI/2)). + rewrite Cexp_PI, Cexp_PI2. + replace (-1:C) with (- C1) by lca. + autorewrite with C_db. + compute_matrix (Cexp (PI / 4) .* hadamard). + rewrite <-Copp_mult_distr_r, (Cmult_comm _ (/ √ 2)). + rewrite Cexp_PI4, Cmult_plus_distr_l. + group_radicals. + by_cell; lca. Qed. Lemma _Rz_is_Rz : forall α, ⟦ _Rz_ α ⟧ = phase_shift α. Proof. intros. - simpl. - unfold Z_semantics, phase_shift. - simpl. - lma. + lma'. Qed. Lemma cnot_l_is_cnot : ⟦ _CNOT_ ⟧ = (/ (√ 2)%R) .* cnot. Proof. - simpl. - unfold Z_semantics, X_semantics. - solve_matrix. - all: autorewrite with Cexp_db. - all: lca. + prep_matrix_equivalence. + cbn. + rewrite X_2_1_0_semantics. + restore_dims. + compute_matrix (/ √ 2 .* cnot). + compute_matrix (Z_semantics 1 2 0). + rewrite Cexp_0. + rewrite 2!make_WF_equiv. + rewrite Kronecker.kron_I_l, Kronecker.kron_I_r. + by_cell; cbv; lca. Qed. Lemma cnot_involutive : _CNOT_R ⟷ _CNOT_ ∝ n_wire 2. @@ -68,8 +77,11 @@ Proof. rewrite 2 stack_compose_distr. rewrite (stack_assoc_back — — (X 1 2 0)). rewrite (stack_assoc_back — — (X 2 1 0)). - simpl_casts. - bundle_wires. + rewrite !cast_id. + change (n_wire 2) with (— ↕ n_wire (0 + 1)). + rewrite <- wire_to_n_wire, wire_to_n_wire, 2!n_wire_stack, + <- wire_to_n_wire. + change (1 + (0 + 1))%nat with 2%nat. rewrite (compose_assoc (— ↕ (⊂ ↕ —))). rewrite wire_to_n_wire at 4. rewrite (nwire_stack_compose_topleft (X 2 1 0) (Z 2 2 (0 + 0))). @@ -79,24 +91,24 @@ Proof. rewrite <- (stack_compose_distr (n_wire 2) (n_wire (1 + 1)) (X 2 1 0) (X 1 2 0)). rewrite X_spider_1_1_fusion. rewrite Rplus_0_r. - simpl; cleanup_zx; simpl_casts. + simpl; cleanup_zx; rewrite !cast_id. rewrite (compose_assoc _ (— ↕ — ↕ X 2 2 _)). - rewrite stack_assoc. - simpl_casts. + rewrite stack_assoc. (* simpl_casts. *) + rewrite cast_id. rewrite <- (stack_compose_distr — — (— ↕ X 2 2 _)). cleanup_zx. rewrite wire_to_n_wire at 7. rewrite <- X_wrap_over_top_left. rewrite (stack_assoc_back — ⊂ —). - rewrite stack_assoc_back. - simpl_casts. + rewrite (stack_assoc_back _ — —). + rewrite !cast_id. rewrite <- (stack_compose_distr (— ↕ ⊂) (Z 2 2 _ ↕ —) — —). cleanup_zx. rewrite wire_to_n_wire at 1. erewrite <- (cast_id _ _ (n_wire 1 ↕ ⊂)). rewrite <- Z_wrap_under_bot_left. - erewrite <- (cast_id _ _ (Z _ (1 + 2) _)); - simpl_casts. + change (2 + 1)%nat with (1 + 2)%nat. + rewrite wire_to_n_wire. rewrite grow_Z_bot_right. rewrite grow_X_top_left. @@ -105,7 +117,7 @@ Proof. repeat rewrite <- compose_assoc. rewrite (compose_assoc _ (n_wire 1 ↕ Z 1 2 0 ↕ n_wire 1)). rewrite stack_assoc. - simpl_casts. + rewrite cast_id. rewrite <- wire_to_n_wire. rewrite <- (stack_compose_distr — — (Z 1 2 0 ↕ —)). rewrite <- stack_compose_distr. @@ -116,7 +128,7 @@ Proof. rewrite stack_nwire_distribute_l. repeat rewrite <- compose_assoc. rewrite stack_assoc_back. - simpl_casts. + rewrite cast_id. rewrite <- (stack_nwire_distribute_r (Z 1 (1 + 1) 0) (n_wire 1 ↕ Z 1 0 0 )). rewrite <- grow_Z_bot_right. rewrite compose_assoc. @@ -129,7 +141,7 @@ Proof. cleanup_zx. easy. Unshelve. -all: lia. +all: reflexivity. Qed. Lemma cnot_is_cnot_r : _CNOT_ ∝ _CNOT_R. @@ -175,14 +187,149 @@ Unshelve. all: lia. Qed. +Import Setoid. +Import Kronecker. +Require Import ZXpermFacts. +Import CoreRules. + + +Add Parametric Morphism n : (zx_of_perm n) with signature + perm_eq n ==> eq as zx_of_perm_proper. +Proof. + intros. + now apply zx_of_perm_eq_of_perm_eq. +Qed. + Lemma cnot_inv_is_swapped_cnot : _CNOT_inv_ ∝ ⨉ ⟷ _CNOT_ ⟷ ⨉. -Admitted. +Proof. + symmetry. + rewrite <- compose_assoc. + rewrite swap_commutes_l. + rewrite !compose_assoc. + rewrite (swap_pullthrough_l — (X 2 1 0)). + rewrite <- (compose_assoc (zx_comm 1 2)). + unfold zx_comm. + simpl_casts. + rewrite compose_zx_of_perm by auto with perm_db. + assert (H : perm_eq (1 + 2) (rotr (1 + 2) 1 ∘ rotr (1 + 2) 1)%prg + (big_swap_perm 1 2)) + by (rewrite rotr_add_l; + intros [|[|[|]]]; [reflexivity..|lia]). + rewrite H. + rewrite <- (compose_assoc _ _ (2 ↑ □)). + rewrite <- colorswap_is_bihadamard. + simpl. + prop_exists_nonzero 1. + rewrite Mscale_1_l. + simpl. + rewrite zx_of_perm_semantics by auto with perm_db. + simpl_rewrite' (kron_comm_pows2_eq_perm_to_matrix_big_swap 2 1). + rewrite !X_semantics_equiv, !Z_semantics_equiv. + simpl. + rewrite Cexp_0. + Msimpl. + restore_dims. + distribute_plus. + restore_dims. + rewrite 2!kron_id_dist_r by auto_wf. + rewrite 2!(Mmult_assoc _ _ (kron_comm 2 4)). + restore_dims. + rewrite 2!kron_assoc by auto_wf. + restore_dims. + rewrite 2!kron_comm_commutes_r by auto_wf. + rewrite kron_comm_1_l. + rewrite 2!Mmult_1_l by auto_wf. + rewrite <- kron_plus_distr_r, <- kron_plus_distr_l, <- !Mmult_plus_distr_r. + rewrite <- kron_plus_distr_l. + restore_dims. + unfold xbasis_plus, xbasis_minus, braplus, braminus. + autorewrite with scalar_move_db. + f_equal; [lca|]. + rewrite <- (kron_1_r _ _ (_ ⊗ I 2)). + restore_dims. + rewrite 2!kron_mixed_product. + rewrite !Mmult_1_l by auto_wf. -Lemma notc_is_swapp_cnot : _NOTC_ ∝ ⨉ ⟷ _CNOT_ ⟷ ⨉. -Admitted. + rewrite <- (kron_1_r _ _ ((_ .+ _ .* _) ⊗ I 2)). + restore_dims. + rewrite 2!kron_mixed_product. + rewrite !Mmult_1_l by auto_wf. + prep_matrix_equivalence. + replace (∣0⟩ .+ ∣1⟩) with (@const_matrix 2 1 1) by lma'. + replace (⟨0∣ .+ ⟨1∣) with (@const_matrix 1 2 1) by lma'. + rewrite Mmult_const. + replace (-1:C) with (- C1) by lca. + compute_matrix ((∣0⟩ .+ - C1 .* ∣1⟩) × (⟨0∣ .+ - C1 .* ⟨1∣)). + autorewrite with C_db. + match goal with |- context [?A .+ ?B] => + compute_matrix (A .+ B) end. + compute_matrix (I 2 ⊗ (∣0⟩ ⊗ ∣0⟩ × ⟨0∣ .+ ∣1⟩ ⊗ ∣1⟩ × ⟨1∣)). + restore_dims. + compute_matrix (∣0⟩ × (⟨0∣ ⊗ ⟨0∣) .+ ∣1⟩ × (⟨1∣ ⊗ ⟨1∣)). + match goal with |- context [?A .+ ?B] => + compute_matrix (A .+ B) end. + autorewrite with C_db. + rewrite !make_WF_equiv, kron_I_l, kron_I_r. + by_cell; cbv; lca. +Qed. + +Lemma notc_is_swapp_cnot : _NOTC_ ∝ ⨉ ⟷ _CNOT_ ⟷ ⨉. +Proof. + symmetry. + rewrite <- compose_assoc. + rewrite swap_commutes_l. + rewrite !compose_assoc. + rewrite (swap_pullthrough_l — (X 2 1 0)). + rewrite <- (compose_assoc (zx_comm 1 2)). + unfold zx_comm. + simpl_casts. + rewrite compose_zx_of_perm by auto with perm_db. + assert (H : perm_eq (1 + 2) (rotr (1 + 2) 1 ∘ rotr (1 + 2) 1)%prg + (big_swap_perm 1 2)) + by (rewrite rotr_add_l; + intros [|[|[|]]]; [reflexivity..|lia]). + rewrite H. + clear H. + assert (H : zx_of_perm (1 + 2) (big_swap_perm 1 2) ∝ — ↕ ⨉ ⟷ (⨉ ↕ —)). 1: { + by_perm_eq_nosimpl. + rewrite perm_of_zx_of_perm_eq by auto with perm_db. + by_perm_cell; reflexivity. + } + rewrite H. + rewrite <- !compose_assoc, <- stack_wire_distribute_l. + rewrite Z_zxperm_absorbtion_right by constructor. + rewrite compose_assoc, <- (stack_wire_distribute_r ⨉ (X 2 1 0)). + now rewrite X_zxperm_absorbtion_left by constructor. +Qed. Lemma notc_r_is_swapp_cnot_r : _NOTC_R ∝ ⨉ ⟷ _CNOT_R ⟷ ⨉. -Admitted. +Proof. + symmetry. + rewrite <- compose_assoc. + rewrite swap_commutes_l. + rewrite !compose_assoc. + rewrite (swap_pullthrough_l (Z 2 1 0) —). + rewrite <- (compose_assoc (zx_comm 2 1)). + unfold zx_comm. + simpl_casts. + rewrite compose_zx_of_perm by auto with perm_db. + assert (H : perm_eq (2 + 1) (rotr (2 + 1) 2 ∘ rotr (2 + 1) 2)%prg + (big_swap_perm 2 1)) + by (by_perm_cell; reflexivity). + rewrite H. + clear H. + assert (H : zx_of_perm (2 + 1) (big_swap_perm 2 1) ∝ (⨉ ↕ —) ⟷ (— ↕ ⨉)). + 1: { + by_perm_eq_nosimpl. + rewrite perm_of_zx_of_perm_eq by auto with perm_db. + by_perm_cell; reflexivity. + } + rewrite H. + rewrite compose_assoc, <- (stack_wire_distribute_l ⨉ (Z 2 1 0)). + rewrite <- !compose_assoc, <- (stack_wire_distribute_r (X 1 2 0) ⨉). + rewrite Z_zxperm_absorbtion_left by constructor. + now rewrite X_zxperm_absorbtion_right by constructor. +Qed. Lemma notc_is_notc_r : _NOTC_ ∝ _NOTC_R. Proof. diff --git a/src/Ingest/Ingest.v b/src/Ingest/Ingest.v index 78bbda4..b13d496 100644 --- a/src/Ingest/Ingest.v +++ b/src/Ingest/Ingest.v @@ -1,6 +1,7 @@ Require Import SQIR.UnitarySem. Require Import SQIR.Equivalences. Require Import QuantumLib.Quantum. +Require Import QuantumLib.Kronecker. Require Import CoreData. Require Import CoreRules. Require Import Gates. @@ -16,17 +17,21 @@ Local Open Scope ZX_scope. Lemma a_swap_sem_base : forall n, a_swap_semantics (S (S n)) = uc_eval (@SWAP (S (S n)) 0 (S n)). Proof. intros. - assert (forall q q', q = qubit0 \/ q = qubit1 -> q' = qubit0 \/ q' = qubit1 -> swap × (I 2 ⊗ (q × q'†%M)) × swap = (q × q'†%M) ⊗ I 2). + assert (forall (q q' : Vector 2), WF_Matrix q -> WF_Matrix q' -> + swap × (I 2 ⊗ (q × q'†%M)) × swap = (q × q'†%M) ⊗ I 2). { intros. - destruct H; destruct H0; subst; solve_matrix. + rewrite swap_eq_kron_comm. + rewrite Kronecker.kron_comm_commutes_l by auto_wf. + rewrite Mmult_assoc, Kronecker.kron_comm_mul_inv. + apply Mmult_1_r; auto_wf. } induction n. - simpl. rewrite denote_swap. unfold ueval_swap. simpl. - gridify. + rewrite !kron_1_r. unfold Swaps.bottom_wire_to_top. unfold Swaps.top_wire_to_bottom. rewrite unfold_pad. @@ -37,44 +42,46 @@ Proof. rewrite kron_1_r. replace 4%nat with (2 * 2)%nat by lia. rewrite swap_transpose. - Msimpl. + rewrite Mmult_1_l, Mmult_1_r, kron_1_l, kron_1_r by auto_wf. apply swap_spec'. - rewrite a_swap_semantics_ind. rewrite IHn. - simpl. + (* simpl. *) rewrite 2 denote_swap. unfold ueval_swap. - simpl. + cbn [Nat.ltb Nat.leb]. + rewrite Nat.sub_0_r. rewrite 2 unfold_pad. - simpl. - rewrite Nat.add_1_r. - rewrite Nat.leb_refl. - Msimpl. - rewrite Nat.sub_diag. - simpl. - Msimpl. + replace (S n - 1)%nat with (n)%nat by lia. + replace (0 + (1 + n + 1))%nat with (S (S n)) by lia. + replace ((0 + (1 + (S (S n) - 0 - 1) + 1)))%nat with (S (S (S n))) by lia. + rewrite 2!Nat.leb_refl. + rewrite 2!Nat.sub_diag. + change (2^0)%nat with (S O). + replace (S (S n) - 0 - 1)%nat with (S n) by lia. + cbn -[Nat.pow]. + (* rewrite kron_1_l by (auto 100 using WF_Matrix_dim_change with wf_db). auto_wf. + Msimpl. *) restore_dims. - repeat rewrite kron_plus_distr_l. - repeat rewrite <- kron_assoc; try auto with wf_db. + replace (0 <=? n) with true by easy. + Msimpl. + replace (2 ^ S n)%nat with (2 * 2 ^ n)%nat by (cbn; lia). + (* rewrite <- id_kron, <- kron_assoc by auto_wf. *) + (* restore_dims. *) + rewrite !(kron_assoc _ (I (2^n))) by auto_wf. restore_dims. - repeat rewrite (kron_assoc (I 2 ⊗ _) (I (2 ^ n)) _); try auto with wf_db. - replace (2 ^ n + (2 ^ n + 0))%nat with (2 ^ n * 2)%nat by lia. + distribute_plus. + rewrite <- !(kron_assoc (I 2)) by auto_wf. restore_dims. - repeat rewrite Mmult_plus_distr_l. - repeat rewrite Mmult_plus_distr_r. - repeat rewrite kron_mixed_product. - do 3 pose proof H. - specialize (H qubit0 qubit0). - specialize (H0 qubit0 qubit1). - specialize (H1 qubit1 qubit0). - specialize (H2 qubit1 qubit1). - rewrite H, H0, H1, H2 by auto. + rewrite !kron_mixed_product' by lia. + rewrite swap_eq_kron_comm. + rewrite !kron_comm_commutes_l by auto_wf. + rewrite !(Mmult_assoc _ (kron_comm 2 2)). + rewrite kron_comm_mul_inv. Msimpl. - repeat rewrite kron_assoc by auto with wf_db. - repeat rewrite <- (kron_assoc (I 2) _ _) by auto with wf_db. - rewrite id_kron. - replace (2 * 2 ^ n)%nat with (2 ^ n * 2)%nat by lia. + rewrite <- id_kron. + rewrite !kron_assoc by auto_wf. restore_dims. easy. Qed. @@ -122,7 +129,7 @@ Proof. replace ((2 ^ 0 * (1 * (2 * 2 ^ x0 * 2) * 2 ^ 0))%nat) with (2 ^ 0 * (2 * 2 ^ x0 * 2))%nat by (simpl; lia). apply kron_simplify; try easy. - Msimpl. + rewrite kron_1_r. easy. - destruct x; try (exfalso; lia). destruct (S x - y)%nat eqn:Hc; try (exfalso; lia). @@ -130,15 +137,17 @@ Proof. replace (S x - S y - 1 + 1)%nat with (S x - S y)%nat by lia. replace (S x - S y)%nat with n0 by lia. rewrite Nat.leb_refl. - Msimpl. + restore_dims. + rewrite kron_1_l by auto_wf. assert (x - y = S x0)%nat by lia. assert (x - y = n0)%nat by lia. replace (2 ^ S y * (1 * (2 * 2 ^ (n0 - 1) * 2) * 2 ^ (S n0 - S n0)))%nat with (2 ^ S y * (2 * 2 ^ x0 * 2))%nat; [ | shelve ]. apply kron_simplify; try easy. - rewrite Nat.sub_diag. - Msimpl. - replace ((2 * 2 ^ (n0 - 1) * 2 * 2 ^ 0)%nat) + rewrite Nat.sub_diag. + rewrite kron_1_r. + restore_dims. + replace ((2 * 2 ^ (n0 - 1) * 2)%nat) with (2 * 2 ^ x0 * 2)%nat; [ | shelve ]. apply kron_simplify; try easy. rewrite <- H6. @@ -232,9 +241,9 @@ Proof. simpl. rewrite Nat.leb_refl. rewrite Nat.sub_diag. - simpl. - Msimpl. + rewrite !kron_1_r. restore_dims. + rewrite 2!(kron_id_dist_r 2) by auto_wf. easy. - destruct n; try (exfalso; lia). bdestruct (0 (f i) ⊤) p. -Proof. - intros. - rewrite (big_sum_func_distr f transpose); easy. -Qed. - - - -Definition kron_comm p q : Matrix (p*q) (q*p):= - @make_WF (p*q) (q*p) (fun s t => - (* have blocks H_ij, p by q of them, and each is q by p *) - let i := (s / q)%nat in let j := (t / p)%nat in - let k := (s mod q)%nat in let l := (t mod p) in - (* let k := (s - q * i)%nat in let l := (t - p * t)%nat in *) - if (i =? l) && (j =? k) then C1 else C0 - (* s/q =? t mod p /\ t/p =? s mod q *) -). - -Lemma WF_kron_comm p q : WF_Matrix (kron_comm p q). -Proof. unfold kron_comm; - rewrite Nat.mul_comm; - trivial with wf_db. Qed. -#[export] Hint Resolve WF_kron_comm : wf_db. - -(* Lemma test_kron : kron_comm 2 3 = Matrix.Zero. -Proof. - apply mat_equiv_eq; unfold kron_comm; auto with wf_db. - print_LHS_matU. -*) - -Lemma kron_comm_transpose_mat_equiv : forall p q, - (kron_comm p q) ⊤ ≡ kron_comm q p. -Proof. - intros p q. - intros i j Hi Hj. - unfold kron_comm, transpose, make_WF. - rewrite andb_comm, Nat.mul_comm. - rewrite (andb_comm (_ =? _)). - easy. -Qed. - -Lemma kron_comm_transpose : forall p q, - (kron_comm p q) ⊤ = kron_comm q p. -Proof. - intros p q. - apply mat_equiv_eq; auto with wf_db. - apply kron_comm_transpose_mat_equiv. -Qed. - -Lemma kron_comm_1_r_mat_equiv : forall p, - (kron_comm p 1) ≡ Matrix.I p. -Proof. - intros p. - intros s t Hs Ht. - unfold kron_comm. - unfold make_WF. - unfold Matrix.I. - rewrite Nat.mul_1_r, Nat.div_1_r, Nat.mod_1_r, Nat.div_small, Nat.mod_small by lia. - bdestructΩ'. -Qed. - -Lemma kron_comm_1_r : forall p, - (kron_comm p 1) = Matrix.I p. -Proof. - intros p. - apply mat_equiv_eq; [|rewrite Nat.mul_1_l, Nat.mul_1_r|]; auto with wf_db. - apply kron_comm_1_r_mat_equiv. -Qed. - -Lemma kron_comm_1_l_mat_equiv : forall p, - (kron_comm 1 p) ≡ Matrix.I p. -Proof. - intros p. - intros s t Hs Ht. - unfold kron_comm. - unfold make_WF. - unfold Matrix.I. - rewrite Nat.mul_1_l, Nat.div_1_r, Nat.mod_1_r, Nat.div_small, Nat.mod_small by lia. - bdestructΩ'. -Qed. - -Lemma kron_comm_1_l : forall p, - (kron_comm 1 p) = Matrix.I p. -Proof. - intros p. - apply mat_equiv_eq; [|rewrite Nat.mul_1_l, Nat.mul_1_r|]; auto with wf_db. - apply kron_comm_1_l_mat_equiv. -Qed. - -Definition mx_to_vec {n m} (A : Matrix n m) : Vector (m * n) := - make_WF (fun i j => A (i mod n)%nat (i / n)%nat - (* Note: goes columnwise. Rowwise would be: - make_WF (fun i j => A (i / m)%nat (i mod n)%nat - *) -). - -Lemma WF_mx_to_vec {n m} (A : Matrix n m) : WF_Matrix (mx_to_vec A). -Proof. unfold mx_to_vec; auto with wf_db. Qed. -#[export] Hint Resolve WF_mx_to_vec : wf_db. - -(* Compute vec_to_list (mx_to_vec (Matrix.I 2)). *) -From Coq Require Import ZArith. -Ltac Zify.zify_post_hook ::= PreOmega.Z.div_mod_to_equations. - -Lemma kron_comm_mx_to_vec_helper : forall i p q, (i < p * q)%nat -> - (p * (i mod q) + i / q < p * q)%nat. -Proof. - intros i p q Hi. - show_moddy_lt. -Qed. - -Lemma mx_to_vec_additive_mat_equiv {n m} (A B : Matrix n m) : - mx_to_vec (A .+ B) ≡ mx_to_vec A .+ mx_to_vec B. -Proof. - intros i j Hi Hj. - replace j with O by lia; clear dependent j. - unfold mx_to_vec, make_WF, Mplus. - bdestructΩ'. -Qed. - -Lemma mx_to_vec_additive {n m} (A B : Matrix n m) : - mx_to_vec (A .+ B) = mx_to_vec A .+ mx_to_vec B. -Proof. - apply mat_equiv_eq; auto with wf_db. - apply mx_to_vec_additive_mat_equiv. -Qed. - -Lemma if_mult_dist_r (b : bool) (z : C) : - (if b then C1 else C0) * z = - if b then z else C0. -Proof. - destruct b; lca. -Qed. - -Lemma if_mult_dist_l (b : bool) (z : C) : - z * (if b then C1 else C0) = - if b then z else C0. -Proof. - destruct b; lca. -Qed. - -Lemma if_mult_and (b c : bool) : - (if b then C1 else C0) * (if c then C1 else C0) = - if (b && c) then C1 else C0. -Proof. - destruct b; destruct c; lca. -Qed. - -Lemma kron_comm_mx_to_vec_mat_equiv : forall p q (A : Matrix p q), - kron_comm p q × mx_to_vec A ≡ mx_to_vec (A ⊤). -Proof. - intros p q A. - intros i j Hi Hj. - replace j with O by lia; clear dependent j. - unfold transpose, mx_to_vec, kron_comm, make_WF, Mmult. - rewrite (Nat.mul_comm q p). - replace_bool_lia (i . - destruct p; [lia|]. - destruct q; [lia|]. - split. - + rewrite Nat.add_comm, Nat.mul_comm. - rewrite Nat.Div0.mod_add by easy. - rewrite Nat.mod_small; [lia|]. - show_moddy_lt. - + rewrite Nat.mul_comm, Nat.div_add_l by easy. - rewrite Nat.div_small; [lia|]. - show_moddy_lt. - - intros [Hmodp Hdivp]. - rewrite (Nat.div_mod_eq k p). - lia. - } - apply big_sum_unique. - exists (p * (i mod q) + i / q)%nat; repeat split; - [apply kron_comm_mx_to_vec_helper; easy | rewrite Nat.eqb_refl | intros; bdestructΩ'simp]. - destruct p; [lia|]; - destruct q; [lia|]. - f_equal. - - rewrite Nat.add_comm, Nat.mul_comm, Nat.Div0.mod_add, Nat.mod_small; try easy. - show_moddy_lt. - - rewrite Nat.mul_comm, Nat.div_add_l by easy. - rewrite Nat.div_small; [lia|]. - show_moddy_lt. -Qed. - -Lemma kron_comm_mx_to_vec : forall p q (A : Matrix p q), - kron_comm p q × mx_to_vec A = mx_to_vec (A ⊤). -Proof. - intros p q A. - apply mat_equiv_eq; auto with wf_db. - apply kron_comm_mx_to_vec_mat_equiv. -Qed. - -Lemma kron_comm_ei_kron_ei_sum_mat_equiv : forall p q, - kron_comm p q ≡ - big_sum (G:=Matrix (p*q) (q*p)) - (fun i => big_sum (fun j => - (@e_i p i ⊗ @e_i q j) × ((@e_i q j ⊗ @e_i p i) ⊤)) - q) p. -Proof. - intros p q. - intros i j Hi Hj. - rewrite Msum_Csum. - erewrite big_sum_eq_bounded. - 2: { - intros k Hk. - rewrite Msum_Csum. - erewrite big_sum_eq_bounded. - 2: { - intros l Hl. - unfold Mmult, kron, transpose, e_i. - erewrite big_sum_eq_bounded. - 2: { - intros m Hm. - (* replace m with O by lia. *) - rewrite Nat.div_1_r, Nat.mod_1_r. - replace_bool_lia (m =? 0) true; rewrite 4!andb_true_r. - rewrite 3!if_mult_and. - match goal with - |- context[if ?b then _ else _] => - replace b with ((i =? k * q + l) && (j =? l * p + k)) - end. - 1: reflexivity. (* set our new function *) - clear dependent m. - rewrite eq_iff_eq_true, 8!andb_true_iff, - 6!Nat.eqb_eq, 4!Nat.ltb_lt. - split. - - intros [Hieq Hjeq]. - subst i j. - rewrite 2!Nat.div_add_l, Nat.div_small, Nat.add_0_r by lia. - rewrite Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small, - Nat.div_small, Nat.add_0_r by lia. - rewrite Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small by lia. - easy. - - intros [[[] []] [[] []]]. - split. - + rewrite (Nat.div_mod_eq i q) by lia; lia. - + rewrite (Nat.div_mod_eq j p) by lia; lia. - } - simpl; rewrite Cplus_0_l. - reflexivity. - } - apply big_sum_unique. - exists (i mod q). - split; [|split]. - - apply Nat.mod_upper_bound; lia. - - reflexivity. - - intros l Hl Hnmod. - bdestructΩ'simp. - exfalso; apply Hnmod. - rewrite Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small by lia; lia. - } - symmetry. - apply big_sum_unique. - exists (j mod p). - repeat split. - - apply Nat.mod_upper_bound; lia. - - unfold kron_comm, make_WF. - replace_bool_lia (i big_sum (fun j => - (@e_i p i ⊗ @e_i q j) × ((@e_i q j ⊗ @e_i p i) ⊤)) - q) p. -Proof. - intros p q. - apply mat_equiv_eq; auto with wf_db. - apply kron_comm_ei_kron_ei_sum_mat_equiv. -Qed. - -Lemma kron_comm_ei_kron_ei_sum'_mat_equiv : forall p q, - kron_comm p q ≡ - big_sum (fun ij => - let i := (ij / q)%nat in let j := (ij mod q) in - ((@e_i p i ⊗ @e_i q j) × ((@e_i q j ⊗ @e_i p i) ⊤))) (p*q). -Proof. - intros p q. - rewrite kron_comm_ei_kron_ei_sum, big_sum_double_sum, Nat.mul_comm. - reflexivity. -Qed. - -(* TODO: put somewhere sensible *) -Lemma big_sum_mat_equiv_bounded : forall {o p} (f g : nat -> Matrix o p) (n : nat), - (forall x : nat, (x < n)%nat -> f x ≡ g x) -> big_sum f n ≡ big_sum g n. -Proof. - intros. - induction n. - - easy. - - simpl. - rewrite IHn, H; [easy|lia|auto]. -Qed. - -Lemma kron_comm_Hij_sum_mat_equiv : forall p q, - kron_comm p q ≡ - big_sum (fun i => big_sum (fun j => - @kron p q q p (@e_i p i × ((@e_i q j) ⊤)) - ((@Mmult p 1 q (@e_i p i) (((@e_i q j) ⊤))) ⊤)) q) p. -Proof. - intros p q. - rewrite kron_comm_ei_kron_ei_sum_mat_equiv. - apply big_sum_mat_equiv_bounded; intros i Hi. - apply big_sum_mat_equiv_bounded; intros j Hj. - rewrite kron_transpose, kron_mixed_product. - rewrite Mmult_transpose, transpose_involutive. - easy. -Qed. - -Lemma kron_comm_Hij_sum : forall p q, - kron_comm p q = - big_sum (fun i => big_sum (fun j => - e_i i × (e_i j) ⊤ ⊗ - (e_i i × (e_i j) ⊤) ⊤) q) p. -Proof. - intros p q. - apply mat_equiv_eq; [auto with wf_db.. | ]. - apply kron_comm_Hij_sum_mat_equiv. -Qed. - - -Lemma kron_comm_ei_kron_ei_sum' : forall p q, - kron_comm p q = - big_sum (fun ij => - let i := (ij / q)%nat in let j := (ij mod q) in - ((e_i i ⊗ e_i j) × ((e_i j ⊗ e_i i) ⊤))) (p*q). -Proof. - intros p q. - rewrite kron_comm_ei_kron_ei_sum, big_sum_double_sum, Nat.mul_comm. - reflexivity. -Qed. - -Local Notation H := (fun i j => e_i i × (e_i j)⊤). - -Lemma kron_comm_Hij_sum'_mat_equiv : forall p q, - kron_comm p q ≡ - big_sum ( fun ij => - let i := (ij / q)%nat in let j := (ij mod q) in - H i j ⊗ (H i j) ⊤) (p*q). -Proof. - intros p q. - rewrite kron_comm_Hij_sum_mat_equiv, big_sum_double_sum, Nat.mul_comm. - easy. -Qed. - -Lemma kron_comm_Hij_sum' : forall p q, - kron_comm p q = - big_sum (fun ij => - let i := (ij / q)%nat in let j := (ij mod q) in - H i j ⊗ (H i j) ⊤) (p*q). -Proof. - intros p q. - rewrite kron_comm_Hij_sum, big_sum_double_sum, Nat.mul_comm. - easy. -Qed. - - -Lemma div_eq_iff : forall a b c, b <> O -> - (a / b)%nat = c <-> (b * c <= a /\ a < b * (S c))%nat. -Proof. - intros a b c Hb. - split. - intros Hadivb. - split; - subst c. - - rewrite (Nat.div_mod_eq a b) at 2; lia. - - now apply Nat.mul_succ_div_gt. - - intros [Hge Hlt]. - symmetry. - apply (Nat.div_unique _ _ _ (a - b*c)); lia. -Qed. - -Lemma div_eqb_iff : forall a b c, b <> O -> - (a / b)%nat =? c = ((b * c <=? a) && (a - (o <> O) -> (m <> O) -> - (@e_i n k)⊤ ⊗ A = (fun i j => - if (i - (o <> O) -> (m <> O) -> - (@e_i n k)⊤ ⊗ A ≡ (fun i j => - if (i - (@e_i n k)⊤ ⊗ A ≡ (fun i j => - if (i - (o <> O) -> (m <> O) -> - (@e_i n k) ⊗ A = (fun i j => - if (j - (o <> O) -> (m <> O) -> - (@e_i n k) ⊗ A ≡ (fun i j => - if (j - (@e_i n k) ⊗ A ≡ (fun i j => - if (j - (o <> O) -> (m <> O) -> - (@e_i n k)⊤ ⊗ A = (fun i j => - if (i ((j/o)%nat=k)) by lia; - rewrite Hrw; clear Hrw. - symmetry. - rewrite div_eq_iff by lia. - lia. - - replace (i / m =? 0) with false. - rewrite andb_false_r; easy. - symmetry. - rewrite Nat.eqb_neq. - rewrite Nat.div_small_iff; lia. -Qed. - -Lemma kron_e_i_transpose_l'_mat_equiv : forall k n m o (A : Matrix m o), (k < n)%nat -> - (o <> O) -> (m <> O) -> - (@e_i n k)⊤ ⊗ A ≡ (fun i j => - if (i - (@e_i n k)⊤ ⊗ A ≡ (fun i j => - if (i - (o <> O) -> (m <> O) -> - (@e_i n k) ⊗ A = (fun i j => - if (j ((i/m)%nat=k)) by lia; - rewrite Hrw; clear Hrw. - symmetry. - rewrite div_eq_iff by lia. - lia. - - replace (j / o =? 0) with false. - rewrite andb_false_r; easy. - symmetry. - rewrite Nat.eqb_neq. - rewrite Nat.div_small_iff; lia. -Qed. - -Lemma kron_e_i_l'_mat_equiv : forall k n m o (A : Matrix m o), (k < n)%nat -> - (o <> O) -> (m <> O) -> - (@e_i n k) ⊗ A ≡ (fun i j => - if (j - (o <> O) -> (m <> O) -> - (@e_i n k) ⊗ A ≡ (fun i j => - if (j - (o <> O) -> (m <> O) -> - A ⊗ (@e_i n k) = (fun i j => - if (i mod n =? k) then A (i / n)%nat j else 0). -Proof. - intros k n m o A Hk Ho Hm. - apply functional_extensionality; intros i; - apply functional_extensionality; intros j. - unfold kron, e_i. - rewrite if_mult_dist_l, Nat.div_1_r. - rewrite Nat.mod_1_r, Nat.eqb_refl, andb_true_r. - replace (i mod n - (o <> O) -> (m <> O) -> - A ⊗ (@e_i n k) ≡ (fun i j => - if (i mod n =? k) then A (i / n)%nat j else 0). -Proof. - intros. - rewrite kron_e_i_r; easy. -Qed. - -Lemma kron_e_i_r_mat_equiv' : forall k n m o (A : Matrix m o), (k < n)%nat -> - A ⊗ (@e_i n k) ≡ (fun i j => - if (i mod n =? k) then A (i / n)%nat j else 0). -Proof. - intros. - destruct m; [|destruct o]; - try (intros i j Hi Hj; lia). - rewrite kron_e_i_r; easy. -Qed. - -Lemma kron_e_i_transpose_r : forall k n m o (A : Matrix m o), (k < n)%nat -> - (o <> O) -> (m <> O) -> - A ⊗ (@e_i n k) ⊤ = (fun i j => - if (j mod n =? k) then A i (j / n)%nat else 0). -Proof. - intros k n m o A Hk Ho Hm. - apply functional_extensionality; intros i; - apply functional_extensionality; intros j. - unfold kron, transpose, e_i. - rewrite if_mult_dist_l, Nat.div_1_r. - rewrite Nat.mod_1_r, Nat.eqb_refl, andb_true_r. - replace (j mod n - (o <> O) -> (m <> O) -> - A ⊗ (@e_i n k) ⊤ ≡ (fun i j => - if (j mod n =? k) then A i (j / n)%nat else 0). -Proof. - intros. - rewrite kron_e_i_transpose_r; easy. -Qed. - -Lemma kron_e_i_transpose_r_mat_equiv' : forall k n m o (A : Matrix m o), (k < n)%nat -> - A ⊗ (@e_i n k) ⊤ ≡ (fun i j => - if (j mod n =? k) then A i (j / n)%nat else 0). -Proof. - intros. - destruct m; [|destruct o]; - try (intros i j Hi Hj; lia). - rewrite kron_e_i_transpose_r; easy. -Qed. - -Lemma ei_kron_I_kron_ei : forall m n k, (k < n)%nat -> m <> O -> - (@e_i n k) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n k) = - (fun i j => if (i mod n =? k) && (j / m =? k)%nat - && (i / n =? j - k * m) && (i / n m <> O -> - (@e_i n k) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n k) ≡ - (fun i j => if (i mod n =? k) && (j / m =? k)%nat - && (i / n =? j - k * m) && (i / n - (@e_i n k) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n k) ≡ - (fun i j => if (i mod n =? k) && (j / m =? k)%nat - && (i / n =? j - k * m) && (i / n - (@e_i n j) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n j)) n. -Proof. - intros m n. - intros i j Hi Hj. - rewrite Msum_Csum. - erewrite big_sum_eq_bounded. - 2: { - intros ij Hij. - rewrite ei_kron_I_kron_ei by lia. - reflexivity. - } - unfold kron_comm, make_WF. - do 2 simplify_bools_lia_one_kernel. - replace (i / n (@e_i n j) ⊤ ⊗ (Matrix.I m) ⊗ (@e_i n j)) n. -Proof. - intros m n. - apply mat_equiv_eq; - [|eapply WF_Matrix_dim_change; [lia..|]|]; - [auto with wf_db..|]. - apply kron_comm_kron_form_sum_mat_equiv; easy. -Qed. - -Lemma kron_comm_kron_form_sum' : forall m n, - kron_comm m n = big_sum (fun i => - (@e_i m i) ⊗ (Matrix.I n) ⊗ (@e_i m i)⊤) m. -Proof. - intros. - rewrite <- (kron_comm_transpose n m). - rewrite (kron_comm_kron_form_sum n m). - replace (n * m)%nat with (1 * n * m)%nat by lia. - replace (m * n)%nat with (m * n * 1)%nat by lia. - rewrite (Nat.mul_1_r (m * n * 1)). - etransitivity; - [apply Msum_transpose|]. - apply big_sum_eq_bounded. - intros k Hk. - restore_dims. - rewrite !kron_transpose. - now rewrite id_transpose_eq, transpose_involutive. -Qed. - -Lemma kron_comm_kron_form_sum'_mat_equiv : forall m n, - kron_comm m n ≡ big_sum (fun i => - (@e_i m i) ⊗ (Matrix.I n) ⊗ (@e_i m i)⊤) m. -Proof. - intros. - rewrite kron_comm_kron_form_sum'; easy. -Qed. - -Lemma e_i_dot_is_component_mat_equiv : forall p k (x : Vector p), - (k < p)%nat -> - (@e_i p k) ⊤ × x ≡ x k O .* Matrix.I 1. -Proof. - intros p k x Hk. - intros i j Hi Hj; - replace i with O by lia; - replace j with O by lia; - clear i Hi; - clear j Hj. - unfold Mmult, transpose, scale, e_i, Matrix.I. - simpl_bools. - rewrite Cmult_1_r. - apply big_sum_unique. - exists k. - split; [easy|]. - bdestructΩ'simp. - rewrite Cmult_1_l. - split; [easy|]. - intros l Hl Hkl. - bdestructΩ'simp. -Qed. - -Lemma e_i_dot_is_component : forall p k (x : Vector p), - (k < p)%nat -> WF_Matrix x -> - (@e_i p k) ⊤ × x = x k O .* Matrix.I 1. -Proof. - intros p k x Hk HWF. - apply mat_equiv_eq; auto with wf_db. - apply e_i_dot_is_component_mat_equiv; easy. -Qed. - -Lemma kron_e_i_e_i : forall p q k l, - (k < p)%nat -> (l < q)%nat -> - @e_i q l ⊗ @e_i p k = @e_i (p*q) (l*p + k). -Proof. - intros p q k l Hk Hl. - apply functional_extensionality; intro i. - apply functional_extensionality; intro j. - unfold kron, e_i. - rewrite Nat.mod_1_r, Nat.div_1_r. - rewrite if_mult_and. - apply f_equal_if; [|easy..]. - rewrite Nat.eqb_refl, andb_true_r. - destruct (j =? 0); [|rewrite 2!andb_false_r; easy]. - rewrite 2!andb_true_r. - rewrite eq_iff_eq_true, 4!andb_true_iff, 3!Nat.eqb_eq, 3!Nat.ltb_lt. - split. - - intros [[] []]. - rewrite (Nat.div_mod_eq i p). - split; nia. - - intros []. - subst i. - rewrite Nat.div_add_l, Nat.div_small, Nat.add_0_r, - Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small by lia. - easy. -Qed. - -Lemma kron_e_i_e_i_mat_equiv : forall p q k l, - (k < p)%nat -> (l < q)%nat -> - @e_i q l ⊗ @e_i p k ≡ @e_i (p*q) (l*p + k). -Proof. - intros p q k l; intros. - rewrite (kron_e_i_e_i p q); easy. -Qed. - -Lemma kron_eq_sum_mat_equiv : forall p q (x : Vector q) (y : Vector p), - y ⊗ x ≡ big_sum (fun ij => - let i := (ij / q)%nat in let j := ij mod q in - (x j O * y i O) .* (@e_i p i ⊗ @e_i q j)) (p * q). -Proof. - intros p q x y. - erewrite big_sum_eq_bounded. - 2: { - intros ij Hij. - simpl. - rewrite (@kron_e_i_e_i q p) by - (try apply Nat.mod_upper_bound; try apply Nat.Div0.div_lt_upper_bound; lia). - rewrite (Nat.mul_comm (ij / q) q). - rewrite <- (Nat.div_mod_eq ij q). - reflexivity. - } - intros i j Hi Hj. - replace j with O by lia; clear j Hj. - simpl. - rewrite Msum_Csum. - symmetry. - apply big_sum_unique. - exists i. - split; [lia|]. - unfold e_i; split. - - unfold scale, kron; bdestructΩ'simp. - - intros j Hj Hij. - unfold scale, kron; bdestructΩ'simp. -Qed. - -Lemma kron_eq_sum : forall p q (x : Vector q) (y : Vector p), - WF_Matrix x -> WF_Matrix y -> - y ⊗ x = big_sum (fun ij => - let i := (ij / q)%nat in let j := ij mod q in - (x j O * y i O) .* (@e_i p i ⊗ @e_i q j)) (p * q). -Proof. - intros p q x y Hwfx Hwfy. - apply mat_equiv_eq; [| |]; auto with wf_db. - apply kron_eq_sum_mat_equiv. -Qed. - -Lemma kron_comm_commutes_vectors_l_mat_equiv : forall p q (x : Vector q) (y : Vector p), - kron_comm p q × (x ⊗ y) ≡ (y ⊗ x). -Proof. - intros p q x y. - rewrite kron_comm_ei_kron_ei_sum'_mat_equiv, Mmult_Msum_distr_r. - - rewrite (big_sum_mat_equiv_bounded _ - (fun k => x (k mod q) 0 * y (k / q) 0 .* (e_i (k / q) ⊗ e_i (k mod q)))%nat); - [rewrite <- kron_eq_sum_mat_equiv; easy|]. - intros k Hk. - simpl. - rewrite Mmult_assoc. - change 1%nat with (1 * 1)%nat. - restore_dims. - rewrite (kron_transpose' (@e_i q (k mod q)) (@e_i p (k / q))). - rewrite kron_mixed_product. - rewrite 2!(e_i_dot_is_component_mat_equiv) by show_moddy_lt. - rewrite Mscale_kron_dist_l, Mscale_kron_dist_r, Mscale_assoc. - rewrite kron_1_l, Mscale_mult_dist_r, Mmult_1_r by auto with wf_db. - reflexivity. -Qed. - -Lemma kron_comm_commutes_vectors_l : forall p q (x : Vector q) (y : Vector p), - WF_Matrix x -> WF_Matrix y -> - kron_comm p q × (x ⊗ y) = (y ⊗ x). -Proof. - intros p q x y Hwfx Hwfy. - apply mat_equiv_eq; auto with wf_db. - apply kron_comm_commutes_vectors_l_mat_equiv. -Qed. - -Lemma kron_basis_vector_basis_vector : forall p q k l, - (k < p)%nat -> (l < q)%nat -> - basis_vector q l ⊗ basis_vector p k = basis_vector (p*q) (l*p + k). -Proof. - intros p q k l Hk Hl. - apply functional_extensionality; intros i. - apply functional_extensionality; intros j. - unfold kron, basis_vector. - rewrite Nat.mod_1_r, Nat.div_1_r, Nat.eqb_refl, andb_true_r, if_mult_and. - pose proof (Nat.div_mod_eq i p). - bdestructΩ'simp. - rewrite Nat.div_add_l, Nat.div_small in * by lia. - lia. -Qed. - -Lemma kron_basis_vector_basis_vector_mat_equiv : forall p q k l, - (k < p)%nat -> (l < q)%nat -> - basis_vector q l ⊗ basis_vector p k ≡ basis_vector (p*q) (l*p + k). -Proof. - intros. - rewrite (kron_basis_vector_basis_vector p q); easy. -Qed. - -Lemma kron_extensionality_mat_equiv : forall n m s t (A B : Matrix (n*m) (s*t)), - (forall (x : Vector s) (y :Vector t), - A × (x ⊗ y) ≡ B × (x ⊗ y)) -> - A ≡ B. -Proof. - intros n m s t A B Hext. - apply mat_equiv_of_equiv_on_ei. - intros i Hi. - - pose proof (Nat.Div0.div_lt_upper_bound i t s ltac:(lia)). - pose proof (Nat.mod_upper_bound i s ltac:(lia)). - pose proof (Nat.mod_upper_bound i t ltac:(lia)). - - specialize (Hext (@e_i s (i / t)) (@e_i t (i mod t))). - rewrite (kron_e_i_e_i_mat_equiv t s) in Hext by lia. - (* simpl in Hext. *) - rewrite (Nat.mul_comm (i/t) t), <- (Nat.div_mod_eq i t) in Hext. - rewrite (Nat.mul_comm t s) in Hext. easy. -Qed. - -Lemma kron_extensionality : forall n m s t (A B : Matrix (n*m) (s*t)), - WF_Matrix A -> WF_Matrix B -> - (forall (x : Vector s) (y :Vector t), - WF_Matrix x -> WF_Matrix y -> - A × (x ⊗ y) = B × (x ⊗ y)) -> - A = B. -Proof. - intros n m s t A B HwfA HwfB Hext. - apply equal_on_basis_vectors_implies_equal; try easy. - intros i Hi. - - pose proof (Nat.Div0.div_lt_upper_bound i t s ltac:(lia)). - pose proof (Nat.mod_upper_bound i s ltac:(lia)). - pose proof (Nat.mod_upper_bound i t ltac:(lia)). - - specialize (Hext (basis_vector s (i / t)) (basis_vector t (i mod t)) - ltac:(apply basis_vector_WF; easy) - ltac:(apply basis_vector_WF; easy) - ). - rewrite (kron_basis_vector_basis_vector t s) in Hext by lia. - - simpl in Hext. - rewrite (Nat.mul_comm (i/t) t), <- (Nat.div_mod_eq i t) in Hext. - rewrite (Nat.mul_comm t s) in Hext. easy. -Qed. - -Lemma kron_comm_commutes_mat_equiv : forall n s m t - (A : Matrix n s) (B : Matrix m t), - kron_comm m n × (A ⊗ B) × (kron_comm s t) ≡ (B ⊗ A). -Proof. - intros n s m t A B. - apply kron_extensionality_mat_equiv. - intros x y. - rewrite (Mmult_assoc (_ × _)). - rewrite kron_comm_commutes_vectors_l_mat_equiv. - rewrite Mmult_assoc, kron_mixed_product. - rewrite kron_comm_commutes_vectors_l_mat_equiv. - rewrite <- kron_mixed_product. - easy. -Qed. - -Lemma kron_comm_commutes : forall n s m t - (A : Matrix n s) (B : Matrix m t), - WF_Matrix A -> WF_Matrix B -> - kron_comm m n × (A ⊗ B) × (kron_comm s t) = (B ⊗ A). -Proof. - intros n s m t A B HwfA HwfB. - apply kron_extensionality; - auto with wf_db. - intros x y Hwfx Hwfy. - rewrite (Mmult_assoc (_ × _)). - rewrite kron_comm_commutes_vectors_l by easy. - rewrite Mmult_assoc, kron_mixed_product. - rewrite kron_comm_commutes_vectors_l by auto with wf_db. - rewrite <- kron_mixed_product. - easy. -Qed. - -Lemma commute_kron_mat_equiv : forall n s m t - (A : Matrix n s) (B : Matrix m t), - (A ⊗ B) ≡ kron_comm n m × (B ⊗ A) × (kron_comm t s). -Proof. - intros n s m t A B. - now rewrite kron_comm_commutes_mat_equiv. -Qed. - - -Lemma commute_kron : forall n s m t - (A : Matrix n s) (B : Matrix m t), - WF_Matrix A -> WF_Matrix B -> - (A ⊗ B) = kron_comm n m × (B ⊗ A) × (kron_comm t s). -Proof. - intros n s m t A B HA HB. - now rewrite kron_comm_commutes. -Qed. - -(* TODO: Move to the right place *) -Lemma WF_Matrix_dim_change_iff m n m' n' (A : Matrix m n) : - m = m' -> n = n' -> - @WF_Matrix m' n' A <-> WF_Matrix A. -Proof. - intros. - now subst. -Qed. - -Lemma kron_comm_pows2_eq_perm_to_matrix_rotr n o : - kron_comm (2^o) (2^n) = perm_to_matrix (n + o) (rotr (n + o) n). -Proof. - symmetry. - apply equal_on_basis_states_implies_equal; - [|rewrite WF_Matrix_dim_change_iff by show_pow2_le |]; - [auto with wf_db..|]. - intros f. - rewrite perm_to_matrix_permutes_qubits by auto with perm_db. - rewrite (f_to_vec_split'_eq _ _ f). - restore_dims. - rewrite kron_comm_commutes_vectors_l by auto with wf_db. - rewrite Nat.add_comm, f_to_vec_split'_eq. - f_equal; apply f_to_vec_eq; intros i Hi; f_equal; - unfold rotr; simplify_bools_lia; solve_simple_mod_eqns. -Qed. - -Lemma kron_comm_eq_perm_mat_of_kron_comm_perm p q : - kron_comm p q = perm_mat (p * q) (kron_comm_perm p q). -Proof. - apply mat_equiv_eq; auto using WF_Matrix_dim_change with wf_db zarith. - apply mat_equiv_of_equiv_on_ei. - intros k Hk. - rewrite (Nat.div_mod_eq k p) at 1. - rewrite (Nat.mul_comm p (k/p)), (Nat.mul_comm q p). - rewrite <- (kron_e_i_e_i p q) at 1 by show_moddy_lt. - restore_dims. - rewrite kron_comm_commutes_vectors_l by auto with wf_db. - rewrite perm_mat_permutes_ei_r by show_moddy_lt. - rewrite (kron_e_i_e_i q p) by show_moddy_lt. - rewrite Nat.mul_comm. - unfold kron_comm_perm. - bdestructΩ'. -Qed. - -Lemma kron_comm_mul_inv_mat_equiv : forall p q, - kron_comm p q × kron_comm q p ≡ Matrix.I (p * q). -Proof. - intros p q. - rewrite (kron_comm_eq_perm_mat_of_kron_comm_perm p q). - rewrite (kron_comm_eq_perm_mat_of_kron_comm_perm q p). - rewrite Nat.mul_comm. - rewrite perm_mat_Mmult by auto with perm_db. - cleanup_perm_inv. - now rewrite perm_mat_idn. -Qed. - -Lemma kron_comm_mul_inv : forall p q, - kron_comm p q × kron_comm q p = Matrix.I _. -Proof. - intros p q. - apply mat_equiv_eq; auto with wf_db. - rewrite kron_comm_mul_inv_mat_equiv; easy. -Qed. - -Lemma kron_comm_mul_transpose_r_mat_equiv : forall p q, - kron_comm p q × (kron_comm p q) ⊤ ≡ Matrix.I _. -Proof. - intros p q. - rewrite (kron_comm_transpose p q). - apply kron_comm_mul_inv_mat_equiv. -Qed. - -Lemma kron_comm_mul_transpose_r : forall p q, - kron_comm p q × (kron_comm p q) ⊤ = Matrix.I _. -Proof. - intros p q. - rewrite (kron_comm_transpose p q). - apply kron_comm_mul_inv. -Qed. - -Lemma kron_comm_mul_transpose_l_mat_equiv : forall p q, - (kron_comm p q) ⊤ × kron_comm p q ≡ Matrix.I _. -Proof. - intros p q. - rewrite <- (kron_comm_transpose q p). - rewrite (transpose_involutive _ _ (kron_comm q p)). - apply kron_comm_mul_transpose_r_mat_equiv. -Qed. - -Lemma kron_comm_mul_transpose_l : forall p q, - (kron_comm p q) ⊤ × kron_comm p q = Matrix.I _. -Proof. - intros p q. - rewrite <- (kron_comm_transpose q p). - rewrite (transpose_involutive _ _ (kron_comm q p)). - apply kron_comm_mul_transpose_r. -Qed. - -Lemma kron_comm_commutes_l_mat_equiv : forall n s m t - (A : Matrix n s) (B : Matrix m t), - kron_comm m n × (A ⊗ B) ≡ (B ⊗ A) × (kron_comm t s). -Proof. - intros n s m t A B. - match goal with |- ?A ≡ ?B => - rewrite <- (Mmult_1_r_mat_eq _ _ A), <- (Mmult_1_r_mat_eq _ _ B) - end. - rewrite (Nat.mul_comm t s). - rewrite <- (kron_comm_mul_transpose_r), <- 2!Mmult_assoc. - rewrite (kron_comm_commutes_mat_equiv n s m t). - apply Mmult_simplify_mat_equiv; [|easy]. - rewrite Mmult_assoc. - restore_dims. - rewrite (kron_comm_mul_inv_mat_equiv t s), Mmult_1_r_mat_eq. - easy. -Qed. - -Lemma kron_comm_commutes_l : forall n s m t - (A : Matrix n s) (B : Matrix m t), - WF_Matrix A -> WF_Matrix B -> - kron_comm m n × (A ⊗ B) = (B ⊗ A) × (kron_comm t s). -Proof. - intros n s m t A B HwfA HwfB. - apply mat_equiv_eq; auto with wf_db. - apply kron_comm_commutes_l_mat_equiv. -Qed. - -Lemma kron_comm_commutes_r_mat_equiv : forall n s m t - (A : Matrix n s) (B : Matrix m t), - (A ⊗ B) × kron_comm s t ≡ (kron_comm n m) × (B ⊗ A). -Proof. - intros. - rewrite kron_comm_commutes_l_mat_equiv; easy. -Qed. - -Lemma kron_comm_commutes_r : forall n s m t - (A : Matrix n s) (B : Matrix m t), - WF_Matrix A -> WF_Matrix B -> - (A ⊗ B) × kron_comm s t = (kron_comm n m) × (B ⊗ A). -Proof. - intros n s m t A B HA HB. - rewrite kron_comm_commutes_l; easy. -Qed. - - - -(* Lemma kron_comm_commutes_r : forall n s m t - (A : Matrix n s) (B : Matrix m t), - WF_Matrix A -> WF_Matrix B -> - kron_comm m n × (A ⊗ B) = (B ⊗ A) × (kron_comm t s). -Proof. - intros n s m t A B HwfA HwfB. - match goal with |- ?A = ?B => - rewrite <- (Mmult_1_r _ _ A), <- (Mmult_1_r _ _ B) ; auto with wf_db - end. - rewrite (Nat.mul_comm t s). - rewrite <- (kron_comm_mul_transpose_r), <- 2!Mmult_assoc. - rewrite (kron_comm_commutes n s m t) by easy. - apply Mmult_simplify; [|easy]. - rewrite Mmult_assoc. - rewrite (Nat.mul_comm s t), (kron_comm_mul_inv t s), Mmult_1_r by auto with wf_db. - easy. -Qed. *) - - -Lemma vector_eq_basis_comb_mat_equiv : forall n (y : Vector n), - y ≡ big_sum (fun i => y i O .* @e_i n i) n. -Proof. - intros n y. - intros i j Hi Hj. - replace j with O by lia; clear j Hj. - symmetry. - rewrite Msum_Csum. - apply big_sum_unique. - exists i. - repeat split; try easy. - - unfold ".*", e_i; bdestructΩ'simp. - - intros l Hl Hnk. - unfold ".*", e_i; bdestructΩ'simp. -Qed. - - -Lemma vector_eq_basis_comb : forall n (y : Vector n), - WF_Matrix y -> - y = big_sum (G:=Vector n) (fun i => y i O .* @e_i n i) n. -Proof. - intros n y Hwfy. - apply mat_equiv_eq; auto with wf_db. - apply vector_eq_basis_comb_mat_equiv. -Qed. - -(* Lemma kron_vecT_matrix_vec : forall m n o p - (P : Matrix m o) (y : Vector n) (z : Vector p), - WF_Matrix y -> WF_Matrix z -> WF_Matrix P -> - (z⊤) ⊗ P ⊗ y = @Mmult (m*n) (m*n) (o*p) (kron_comm m n) ((y × (z⊤)) ⊗ P). -Proof. - intros m n o p P y z Hwfy Hwfz HwfP. - match goal with |- ?A = ?B => - rewrite <- (Mmult_1_l _ _ A) ; auto with wf_db - end. - rewrite Nat.mul_1_l. - rewrite <- (kron_comm_mul_transpose_r), Mmult_assoc at 1. - rewrite Nat.mul_1_r, (Nat.mul_comm o p). - apply Mmult_simplify; [easy|]. - rewrite kron_comm_kron_form_sum. - rewrite Msum_transpose. - rewrite Mmult_Msum_distr_r. - erewrite big_sum_eq_bounded. - 2: { - intros k Hk. - pose proof (kron_transpose _ _ _ _ ((@e_i n k) ⊤ ⊗ Matrix.I m) (@e_i n k)) as H; - rewrite Nat.mul_1_l, Nat.mul_1_r, (Nat.mul_comm m n) in *; - rewrite H; clear H. - pose proof (kron_transpose _ _ _ _ ((@e_i n k) ⊤) (Matrix.I m)) as H; - rewrite Nat.mul_1_l in *; - rewrite H; clear H. - restore_dims. - rewrite 2!kron_mixed_product. - rewrite id_transpose_eq, Mmult_1_l by easy. - rewrite e_i_dot_is_component, transpose_involutive by easy. - (* rewrite <- Mmult_transpose. *) - rewrite Mscale_kron_dist_r, <- 2!Mscale_kron_dist_l. - rewrite kron_1_r. - rewrite <- Mscale_mult_dist_l. - reflexivity. - } - rewrite <- (kron_Msum_distr_r n _ P). - rewrite <- (Mmult_Msum_distr_r). - rewrite <- vector_eq_basis_comb by easy. - easy. -Qed. -*) - -Lemma kron_vecT_matrix_vec_mat_equiv : forall m n o p - (P : Matrix m o) (y : Vector n) (z : Vector p), - (z⊤) ⊗ P ⊗ y ≡ kron_comm m n × ((y × (z⊤)) ⊗ P). -Proof. - intros m n o p P y z. - match goal with |- ?A ≡ ?B => - rewrite <- (Mmult_1_l_mat_eq _ _ A) - end. - rewrite Nat.mul_1_l. - rewrite <- (kron_comm_mul_transpose_r_mat_equiv), Mmult_assoc at 1. - rewrite Nat.mul_1_r. - apply Mmult_simplify_mat_equiv; [easy|]. - rewrite kron_comm_kron_form_sum_mat_equiv. - replace (m * n)%nat with (1 * m * n)%nat by lia. - replace (n * m)%nat with (n * m * 1)%nat by lia. - rewrite (Msum_transpose (1*m*n) (n*m*1) n). - restore_dims. - rewrite Mmult_Msum_distr_r. - replace (n * m * 1)%nat with (1 * m * n)%nat by lia. - replace (p * o)%nat with (p * o * 1)%nat by lia. - rewrite (Nat.mul_1_r (p * o * 1)). - erewrite (big_sum_mat_equiv_bounded _ _ n). - 2: { - intros k Hk. - unshelve (instantiate (1:=_)). - refine (fun k : nat => y k 0%nat .* e_i k × (z) ⊤ ⊗ P); exact n. - pose proof (kron_transpose _ _ _ _ ((@e_i n k) ⊤ ⊗ Matrix.I m) (@e_i n k)) as H; - rewrite Nat.mul_1_l, Nat.mul_1_r, (Nat.mul_comm m n) in *; - rewrite H; clear H. - pose proof (kron_transpose _ _ _ _ ((@e_i n k) ⊤) (Matrix.I m)) as H; - rewrite Nat.mul_1_l in *; - rewrite H; clear H. - restore_dims. - rewrite 2!kron_mixed_product. - rewrite (id_transpose_eq m). - rewrite Mscale_mult_dist_l, transpose_involutive. - rewrite <- (kron_1_r _ _ P) at 2. - rewrite Mscale_kron_dist_l, <- !Mscale_kron_dist_r. - match goal with - |- (?A ⊗ ?B ⊗ ?C) ≡ _ => pose proof (kron_assoc_mat_equiv A B C) as H - end; - rewrite 4!Nat.mul_1_r in H; rewrite H by easy; clear H. - apply kron_simplify_mat_equiv; [easy|]. - epose proof (Mscale_kron_dist_r _ _ _ _ _ P (Matrix.I 1)) as H; - rewrite 2Nat.mul_1_r in H; - rewrite <- H; clear H. - match goal with - |- (?A ⊗ ?B) ≡ (?C ⊗ ?D) => pose proof (kron_simplify_mat_equiv A C B D) as H - end; - rewrite 2!Nat.mul_1_r in H. apply H. - - rewrite Mmult_1_l_mat_eq; easy. - - rewrite (e_i_dot_is_component_mat_equiv); easy. - } - rewrite <- (kron_Msum_distr_r n _ P). - rewrite <- (Mmult_Msum_distr_r). - replace (1*m*n)%nat with (n*m)%nat by lia. - replace (p*o*1)%nat with (p*o)%nat by lia. - apply kron_simplify_mat_equiv; [|easy]. - apply Mmult_simplify_mat_equiv; [|easy]. - symmetry. - apply vector_eq_basis_comb_mat_equiv. -Qed. - -Lemma kron_vecT_matrix_vec : forall m n o p - (P : Matrix m o) (y : Vector n) (z : Vector p), - WF_Matrix y -> WF_Matrix z -> WF_Matrix P -> - (z⊤) ⊗ P ⊗ y = kron_comm m n × ((y × (z⊤)) ⊗ P). -Proof. - intros m n o p P y z Hwfy Hwfz HwfP. - apply mat_equiv_eq; - [|rewrite ?Nat.mul_1_l, ?Nat.mul_1_r; apply WF_mult|]; - auto with wf_db. - apply kron_vecT_matrix_vec_mat_equiv. -Qed. - -Lemma kron_vec_matrix_vecT : forall m n o p - (Q : Matrix n o) (x : Vector m) (z : Vector p), - WF_Matrix x -> WF_Matrix z -> WF_Matrix Q -> - x ⊗ Q ⊗ (z⊤) = kron_comm m n × (Q ⊗ (x × z⊤)). -Proof. - intros m n o p Q x z Hwfx Hwfz HwfQ. - match goal with |- ?A = ?B => - rewrite <- (Mmult_1_l _ _ A) ; auto with wf_db - end. - rewrite Nat.mul_1_r. - rewrite <- (kron_comm_mul_transpose_r), Mmult_assoc at 1. - rewrite Nat.mul_1_l. - apply Mmult_simplify; [easy|]. - rewrite kron_comm_kron_form_sum'. - rewrite (Msum_transpose (m*n) (n*m) m). - restore_dims. - rewrite Mmult_Msum_distr_r. - erewrite big_sum_eq_bounded. - 2: { - intros k Hk. - restore_dims. - replace (@transpose (m*n) (n*m)) with - (@transpose (m*n*1) (1*n*m)) by (f_equal; lia). - rewrite kron_transpose. - rewrite kron_transpose, transpose_involutive. - restore_dims. - rewrite 2!kron_mixed_product. - rewrite id_transpose_eq, Mmult_1_l by easy. - rewrite e_i_dot_is_component, transpose_involutive by easy. - rewrite 2!Mscale_kron_dist_l, kron_1_l, <-Mscale_kron_dist_r by easy. - rewrite <- Mscale_mult_dist_l. - restore_dims. - reflexivity. - } - erewrite big_sum_eq_bounded. - 2: { - intros k Hk. - rewrite transpose_involutive. - reflexivity. - } - rewrite <- (kron_Msum_distr_l m _ Q). - rewrite <- (Mmult_Msum_distr_r). - rewrite <- vector_eq_basis_comb by easy. - easy. -Qed. - -(* TODO: Relocate *) -Lemma kron_1_l_mat_equiv : forall {n m} (A : Matrix n m), - Matrix.I 1 ⊗ A ≡ A. -Proof. - intros n m A. - intros i j Hi Hj. - unfold kron, I. - rewrite 2!Nat.div_small, 2!Nat.mod_small by lia. - rewrite Cmult_1_l. - easy. -Qed. - -Lemma kron_1_r_mat_equiv : forall {n m} (A : Matrix n m), - A ⊗ Matrix.I 1 ≡ A. -Proof. - intros n m A. - intros i j Hi Hj. - unfold kron, I. - rewrite 2!Nat.div_1_r, 2!Nat.mod_1_r by lia. - rewrite Cmult_1_r. - easy. -Qed. - -Lemma kron_vec_matrix_vecT_mat_equiv : forall m n o p - (Q : Matrix n o) (x : Vector m) (z : Vector p), - x ⊗ Q ⊗ (z⊤) ≡ kron_comm m n × (Q ⊗ (x × z⊤)). -Proof. - intros m n o p Q x z. - match goal with |- ?A ≡ ?B => - rewrite <- (Mmult_1_l_mat_eq _ _ A) - end. - rewrite Nat.mul_1_r. - rewrite <- (kron_comm_mul_transpose_r_mat_equiv), Mmult_assoc at 1. - rewrite Nat.mul_1_l. - apply Mmult_simplify_mat_equiv; [easy|]. - rewrite kron_comm_kron_form_sum'. - replace (@transpose (m*n) (n*m)) with - (@transpose (m*n*1) (1*n*m)) by (f_equal; lia). - rewrite (Msum_transpose (m*n*1) (1*n*m) m). - restore_dims. - rewrite Mmult_Msum_distr_r. - replace (@mat_equiv (n*m) (o*p)) - with (@mat_equiv (m*n*1) (1*o*p)) by (f_equal; lia). - erewrite (big_sum_mat_equiv_bounded). - 2: { - intros k Hk. - unshelve (instantiate (1:=(fun k : nat => - @kron n o m p Q - (@Mmult m 1 p (@scale m 1 (x k 0%nat) (@e_i m k)) - (@transpose p 1 z))))). - rewrite 2!kron_transpose. - restore_dims. - rewrite 2!kron_mixed_product. - rewrite id_transpose_eq, transpose_involutive. - rewrite Mscale_mult_dist_l, Mscale_kron_dist_r, <- Mscale_kron_dist_l. - replace (m*n*1)%nat with (1*n*m)%nat by lia. - replace (@kron n o m p) with (@kron (1*n) (1*o) m p) by (f_equal; lia). - apply kron_simplify_mat_equiv; [|easy]. - intros i j Hi Hj. - unfold kron. - rewrite (Mmult_1_l_mat_eq _ _ Q) by (apply Nat.mod_upper_bound; lia). - (* revert i j Hi Hj. *) - rewrite (e_i_dot_is_component_mat_equiv m k x Hk) by (apply Nat.Div0.div_lt_upper_bound; lia). - set (a:= (@kron 1 1 n o ((x k 0%nat .* Matrix.I 1)) Q) i j). - match goal with - |- ?A = _ => change A with a - end. - unfold a. - clear a. - rewrite Mscale_kron_dist_l. - unfold scale. - rewrite kron_1_l_mat_equiv by lia. - easy. - } - rewrite <- (kron_Msum_distr_l m _ Q). - rewrite <- (Mmult_Msum_distr_r). - rewrite (Nat.mul_comm m n). - rewrite Nat.mul_1_r, Nat.mul_1_l. - rewrite <- vector_eq_basis_comb_mat_equiv. - easy. -Qed. - -Lemma kron_comm_triple_cycle_mat : forall m n s t p q (A : Matrix m n) - (B : Matrix s t) (C : Matrix p q), - A ⊗ B ⊗ C ≡ (kron_comm (m*s) p) × (C ⊗ A ⊗ B) × (kron_comm q (t*n)). -Proof. - intros m n s t p q A B C. - rewrite (commute_kron_mat_equiv _ _ _ _ (A ⊗ B) C) by auto with wf_db. - rewrite (Nat.mul_comm n t), (Nat.mul_comm q (t*n)). - apply Mmult_simplify_mat_equiv; [|easy]. - apply Mmult_simplify_mat_equiv; [easy|]. - rewrite (Nat.mul_comm t n). - intros i j Hi Hj; - rewrite <- (kron_assoc_mat_equiv C A B); - [easy|lia|lia]. -Qed. - -Lemma kron_comm_triple_cycle : forall m n s t p q (A : Matrix m n) - (B : Matrix s t) (C : Matrix p q), WF_Matrix A -> WF_Matrix B -> WF_Matrix C -> - A ⊗ B ⊗ C = (kron_comm (m*s) p) × (C ⊗ A ⊗ B) × (kron_comm q (t*n)). -Proof. - intros m n s t p q A B C HA HB HC. - rewrite (commute_kron _ _ _ _ (A ⊗ B) C) by auto with wf_db. - rewrite kron_assoc by easy. - f_equal; try lia; f_equal; lia. -Qed. - -Lemma kron_comm_triple_cycle2_mat_equiv : forall m n s t p q (A : Matrix m n) - (B : Matrix s t) (C : Matrix p q), - A ⊗ (B ⊗ C) ≡ (kron_comm m (s*p)) × (B ⊗ C ⊗ A) × (kron_comm (q*t) n). -Proof. - intros m n s t p q A B C. - rewrite kron_assoc_mat_equiv. - intros i j Hi Hj. - rewrite (commute_kron_mat_equiv _ _ _ _ A (B ⊗ C)) by lia. - rewrite (Nat.mul_comm t q). - apply Mmult_simplify_mat_equiv; [|easy + lia..]. - apply Mmult_simplify_mat_equiv; [easy|]. - rewrite (Nat.mul_comm q t). - apply kron_assoc_mat_equiv. -Qed. - -Lemma kron_comm_triple_cycle2 : forall m n s t p q (A : Matrix m n) - (B : Matrix s t) (C : Matrix p q), WF_Matrix A -> WF_Matrix B -> WF_Matrix C -> - A ⊗ (B ⊗ C) = (kron_comm m (s*p)) × (B ⊗ C ⊗ A) × (kron_comm (q*t) n). -Proof. - intros m n s t p q A B C HA HB HC. - apply mat_equiv_eq; auto with wf_db. - apply kron_comm_triple_cycle2_mat_equiv. -Qed. - - - - - -(* #[export] Instance big_sum_mat_equiv_morphism {n m : nat} : - Proper (pointwise_relation nat (@mat_equiv n m) - ==> pointwise_relation nat (@mat_equiv n m)) - (@big_sum (Matrix n m) (M_is_monoid n m)) := big_sum_mat_equiv. *) - -(* Instance forall_mat_equiv_morphism {A: Type} {n m : nat} {f g : A -> Matrix m n}: - pointwise_relation A mat_equiv (fun x => f x) (fun x => f x). - -Instance forall_mat_equiv_morphism `{Equivalence A eqA, Equivalence B eqB} : - Proper ((eqA ==> eqB) ==> list_equiv eqA ==> list_equiv eqB) (@map A B). - -Goal (forall_relation (fun n:nat => @mat_equiv m m)) (fun n => Matrix.I m × direct_sum' (@Zero 0 0) (Matrix.I m)) (fun n => Matrix.I m). -setoid_rewrite Mmult_1_l_mat_eq. *) - - -Lemma id_eq_sum_kron_e_is_mat_equiv : forall n, - Matrix.I n ≡ big_sum (G:=Square n) (fun i => @e_i n i ⊗ (@e_i n i) ⊤) n. -Proof. - intros n. - symmetry. - intros i j Hi Hj. - rewrite Msum_Csum. - erewrite big_sum_eq_bounded. - 2: { - intros k Hk. - rewrite kron_e_i_l by lia. - unfold transpose, e_i. - rewrite <- andb_if. - replace_bool_lia (j @e_i n i ⊗ (@e_i n i) ⊤) n. -Proof. - intros n. - apply mat_equiv_eq; auto with wf_db. - apply id_eq_sum_kron_e_is_mat_equiv. -Qed. - -Lemma kron_comm_cycle_indices : forall t s n, - kron_comm (t*s) n = @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) - (kron_comm s (n*t)) (kron_comm t (s*n)). -Proof. - intros t s n. - rewrite kron_comm_kron_form_sum. - erewrite big_sum_eq_bounded. - 2: { - intros j Hj. - rewrite (Nat.mul_comm t s), <- id_kron, <- kron_assoc by auto with wf_db. - restore_dims. - rewrite kron_assoc by auto with wf_db. - (* rewrite (kron_assoc ((@e_i n j)⊤ ⊗ Matrix.I t) (Matrix.I s) (@e_i n j)) by auto with wf_db. *) - lazymatch goal with - |- ?A ⊗ ?B = _ => rewrite (commute_kron _ _ _ _ A B) by auto with wf_db - end. - (* restore_dims. *) - reflexivity. - } - (* rewrite ?Nat.mul_1_r, ?Nat.mul_1_l. *) - (* rewrite <- Mmult_Msum_distr_r. *) - - rewrite <- (Mmult_Msum_distr_r n _ (kron_comm (t*1) (n*s))). - rewrite <- Mmult_Msum_distr_l. - erewrite big_sum_eq_bounded. - 2: { - intros j Hj. - rewrite <- kron_assoc, (kron_assoc (Matrix.I t)) by auto with wf_db. - restore_dims. - reflexivity. - } - (* rewrite Nat.mul_1_l *) - rewrite <- (kron_Msum_distr_r n _ (Matrix.I s)). - rewrite <- (kron_Msum_distr_l n _ (Matrix.I t)). - rewrite 2!Nat.mul_1_r, 2!Nat.mul_1_l. - rewrite <- (id_eq_sum_kron_e_is n). - rewrite 2!id_kron. - restore_dims. - rewrite Mmult_1_r by auto with wf_db. - rewrite (Nat.mul_comm t n), (Nat.mul_comm n s). - easy. -Qed. - -Lemma kron_comm_cycle_indices_mat_equiv : forall t s n, - (kron_comm (t*s) n ≡ @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n))). -Proof. - intros t s n. - rewrite kron_comm_cycle_indices; easy. -Qed. - -Lemma kron_comm_cycle_indices_rev : forall t s n, - @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) = kron_comm (t*s) n. -Proof. - intros. - rewrite <- kron_comm_cycle_indices. - easy. -Qed. - -Lemma kron_comm_cycle_indices_rev_mat_equiv : forall t s n, - @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) ≡ kron_comm (t*s) n. -Proof. - intros. - rewrite <- kron_comm_cycle_indices. - easy. -Qed. - -Lemma kron_comm_triple_id : forall t s n, - (kron_comm (t*s) n) × (kron_comm (s*n) t) × (kron_comm (n*t) s) = Matrix.I (t*s*n). -Proof. - intros t s n. - rewrite kron_comm_cycle_indices. - restore_dims. - rewrite (Mmult_assoc (kron_comm s (n*t))). - restore_dims. - rewrite (kron_comm_mul_inv t (s*n)). - restore_dims. - rewrite Mmult_1_r by auto with wf_db. - rewrite (kron_comm_mul_inv). - f_equal; lia. -Qed. - -Lemma kron_comm_triple_id_mat_equiv : forall t s n, - (kron_comm (t*s) n) × (kron_comm (s*n) t) × (kron_comm (n*t) s) ≡ Matrix.I (t*s*n). -Proof. - intros t s n. - setoid_rewrite kron_comm_triple_id; easy. -Qed. - -Lemma kron_comm_triple_id' : forall n t s, - (kron_comm n (t*s)) × (kron_comm t (s*n)) × (kron_comm s (n*t)) = Matrix.I (t*s*n). -Proof. - intros n t s. - apply transpose_matrices. - rewrite 2!Mmult_transpose. - rewrite (kron_comm_transpose s (n*t)). - rewrite (kron_comm_transpose n (t*s)). - restore_dims. - rewrite (Nat.mul_assoc s n t), <- (Nat.mul_assoc t s n). - - rewrite (kron_comm_transpose t (s*n)). - rewrite Nat.mul_assoc. - replace (t*(s*n))%nat with (n*t*s)%nat by lia. - rewrite id_transpose_eq. - replace (n*t*s)%nat with (t*n*s)%nat by lia. - rewrite <- (kron_comm_triple_id t n s). - rewrite Mmult_assoc. - restore_dims. - replace (s*(t*n))%nat with (s*(n*t))%nat by lia. - replace (n*(t*s))%nat with (n*(s*t))%nat by lia. - replace (n*t*s)%nat with (t*n*s)%nat by lia. - apply Mmult_simplify; [f_equal; lia|]. - repeat (f_equal; try lia). -Qed. - -Lemma kron_comm_triple_id'_mat_equiv : forall t s n, - (kron_comm n (t*s)) × (kron_comm t (s*n)) × (kron_comm s (n*t)) = Matrix.I (t*s*n). -Proof. - intros t s n. - rewrite (kron_comm_triple_id' n t s). - easy. -Qed. - -Lemma kron_comm_triple_id'C : forall n t s, - (kron_comm n (s*t)) × (kron_comm t (n*s)) × (kron_comm s (t*n)) = Matrix.I (t*s*n). -Proof. - intros n t s. - rewrite <- (kron_comm_triple_id' n t s). - rewrite (Nat.mul_comm s t), (Nat.mul_comm n s), - (Nat.mul_comm t n). - easy. -Qed. - -Lemma kron_comm_triple_id'C_mat_equiv : forall n t s, - (kron_comm n (s*t)) × (kron_comm t (n*s)) × (kron_comm s (t*n)) ≡ Matrix.I (t*s*n). -Proof. - intros n t s. - rewrite <- (kron_comm_triple_id'C n t s). - easy. -Qed. - -Tactic Notation "restore_dims" "in" ident(H) := - match type of H with - | ?A => let A' := restore_dims_rec A in - replace A with A' in H by unify_matrix_dims - ltac:((repeat rewrite Nat.pow_1_l); try ring; unify_pows_two; simpl; lia) - end. - -Lemma kron_comm_triple_indices_collapse_mat_equiv : forall s n t, - @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) - ≡ (kron_comm (t*s) n). -Proof. - intros s n t. - rewrite <- (Mmult_1_r_mat_eq _ _ (_ × _)). - (* replace (t*(s*n))%nat with (n*(t*s))%nat by lia. *) - rewrite <- (kron_comm_mul_inv_mat_equiv). - rewrite <- Mmult_assoc. - (* restore_dims. *) - pose proof (kron_comm_triple_id'C s t n) as Hrw. - apply (f_equal (fun A => A × kron_comm (t*s) n)) in Hrw. - replace (t*n*s)%nat with (t*s*n)%nat in Hrw by lia. - restore_dims in Hrw. - rewrite (Mmult_1_l _ _ (kron_comm (t*s) n)) in Hrw by auto with wf_db. - rewrite <- Hrw. - rewrite !Mmult_assoc. - restore_dims. - replace (n*(t*s))%nat with (t*(s*n))%nat by lia. - apply Mmult_simplify_mat_equiv; [easy|]. - replace (n*t*s)%nat with (t*(s*n))%nat by lia. - apply Mmult_simplify_mat_equiv; [easy|]. - restore_dims. - rewrite 2!kron_comm_mul_inv. - now replace (t*(s*n))%nat with (n*(t*s))%nat by lia. -Qed. - -Lemma kron_comm_triple_indices_collapse : forall s n t, - @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) - = (kron_comm (t*s) n). -Proof. - intros s n t. - apply mat_equiv_eq; - [restore_dims; apply WF_Matrix_dim_change; [lia..|]..|]; - auto with wf_db. - apply kron_comm_triple_indices_collapse_mat_equiv. -Qed. - -Lemma kron_comm_triple_indices_collapse_mat_equivC : forall s n t, - @Mmult (s*(t*n)) (s*(t*n)) (t*(n*s)) (kron_comm s (t*n)) (kron_comm t (n*s)) - ≡ (kron_comm (t*s) n). -Proof. - intros s n t. - rewrite (Nat.mul_comm t n), (Nat.mul_comm n s). - rewrite kron_comm_triple_indices_collapse_mat_equiv. - easy. -Qed. - -Lemma kron_comm_triple_indices_collapseC : forall s n t, - @Mmult (s*(t*n)) (s*(t*n)) (t*(n*s)) (kron_comm s (t*n)) (kron_comm t (n*s)) - = (kron_comm (t*s) n). -Proof. - intros s n t. - apply mat_equiv_eq; - [restore_dims; apply WF_Matrix_dim_change; [lia..|]..|]; - auto with wf_db. - apply kron_comm_triple_indices_collapse_mat_equivC. -Qed. - -(* -Not sure what this is, or if it's true: -Lemma kron_comm_triple_indices_commute : forall t s n, - @Mmult (s*t*n) (s*t*n) (t*(s*n)) (kron_comm (s*t) n) (kron_comm t (s*n)) = - @Mmult (t*(s*n)) (t*(s*n)) (s*t*n) (kron_comm t (s*n)) (kron_comm (s*t) n). *) -Lemma kron_comm_triple_indices_commute_mat_equiv : forall t s n, - @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) ≡ - @Mmult (t*(s*n)) (t*(s*n)) (s*(n*t)) (kron_comm t (s*n)) (kron_comm s (n*t)). -Proof. - intros t s n. - rewrite kron_comm_triple_indices_collapse_mat_equiv. - rewrite (Nat.mul_comm t s). - rewrite <- (kron_comm_triple_indices_collapseC t n s). - easy. -Qed. - -Lemma kron_comm_triple_indices_commute : forall t s n, - @Mmult (s*(n*t)) (s*(n*t)) (t*(s*n)) (kron_comm s (n*t)) (kron_comm t (s*n)) = - @Mmult (t*(s*n)) (t*(s*n)) (s*(n*t)) (kron_comm t (s*n)) (kron_comm s (n*t)). -Proof. - intros t s n. - apply mat_equiv_eq; - [restore_dims; apply WF_Matrix_dim_change; [lia..|]..|]; - auto with wf_db. - apply kron_comm_triple_indices_commute_mat_equiv. -Qed. - -Lemma kron_comm_triple_indices_commute_mat_equivC : forall t s n, - @Mmult (s*(t*n)) (s*(t*n)) (t*(n*s)) (kron_comm s (t*n)) (kron_comm t (n*s)) ≡ - @Mmult (t*(s*n)) (t*(s*n)) (s*(n*t)) (kron_comm t (s*n)) (kron_comm s (n*t)). -Proof. - intros t s n. - rewrite (Nat.mul_comm t n), (Nat.mul_comm n s). - apply kron_comm_triple_indices_commute_mat_equiv. -Qed. - -Lemma kron_comm_triple_indices_commuteC : forall t s n, - @Mmult (s*(t*n)) (s*(t*n)) (t*(n*s)) (kron_comm s (t*n)) (kron_comm t (n*s)) = - @Mmult (t*(s*n)) (t*(s*n)) (s*(n*t)) (kron_comm t (s*n)) (kron_comm s (n*t)). -Proof. - intros t s n. - rewrite (Nat.mul_comm t n), (Nat.mul_comm n s). - apply kron_comm_triple_indices_commute. -Qed. - -Lemma kron_comm_kron_of_mult_commute1_mat_equiv : forall m n p q s t - (A : Matrix m n) (B : Matrix p q) (C : Matrix q s) (D : Matrix n t), - @mat_equiv (m*p) (s*t) ((kron_comm m p) × ((B × C) ⊗ (A × D))) - ((A ⊗ B) × kron_comm n q × (C ⊗ D)). -Proof. - intros m n p q s t A B C D. - rewrite <- kron_mixed_product. - rewrite (Nat.mul_comm p m), <- Mmult_assoc. - rewrite kron_comm_commutes_r_mat_equiv. - match goal with (* TODO: Make a lemma *) - |- ?A ≡ ?B => enough (H : A = B) by (rewrite H; easy) - end. - repeat (f_equal; try lia). -Qed. - -Lemma kron_comm_kron_of_mult_commute2_mat_equiv : forall m n p q s t - (A : Matrix m n) (B : Matrix p q) (C : Matrix q s) (D : Matrix n t), - ((A ⊗ B) × kron_comm n q × (C ⊗ D)) ≡ (A × D ⊗ (B × C)) × kron_comm t s. -Proof. - intros m n p q s t A B C D. - rewrite Mmult_assoc, kron_comm_commutes_l_mat_equiv, <-Mmult_assoc, - <- kron_mixed_product. - easy. -Qed. - -Lemma kron_comm_kron_of_mult_commute3_mat_equiv : forall m n p q s t - (A : Matrix m n) (B : Matrix p q) (C : Matrix q s) (D : Matrix n t), - (A × D ⊗ (B × C)) × kron_comm t s ≡ - (Matrix.I m) ⊗ (B × C) × kron_comm m s × (Matrix.I s ⊗ (A × D)). -Proof. - intros m n p q s t A B C D. - rewrite <- 2!kron_comm_commutes_l_mat_equiv, Mmult_assoc. - restore_dims. - rewrite kron_mixed_product. - rewrite Mmult_1_r_mat_eq, Mmult_1_l_mat_eq. - easy. -Qed. - -Lemma kron_comm_kron_of_mult_commute4_mat_equiv : forall m n p q s t - (A : Matrix m n) (B : Matrix p q) (C : Matrix q s) (D : Matrix n t), - @mat_equiv (m*p) (s*t) - ((Matrix.I m) ⊗ (B × C) × kron_comm m s × (Matrix.I s ⊗ (A × D))) - ((A × D) ⊗ (Matrix.I p) × kron_comm t p × ((B × C) ⊗ Matrix.I t)). -Proof. - intros m n p q s t A B C D. - rewrite <- 2!kron_comm_commutes_l_mat_equiv, 2!Mmult_assoc. - restore_dims. - rewrite 2!kron_mixed_product. - rewrite (Nat.mul_comm m p), 2!Mmult_1_r_mat_eq. - rewrite 2!Mmult_1_l_mat_eq. - easy. -Qed. - -Lemma trace_mmult_trans : forall m n (A B : Matrix m n), - trace (A⊤ × B) = Σ (fun j => Σ (fun i => A i j * B i j) m) n. -Proof. - intros m n A B. - apply big_sum_eq_bounded. - intros j Hj. - apply big_sum_eq_bounded. - intros i Hi; reflexivity. -Qed. - -Lemma trace_mmult_trans' : forall m n (A B : Matrix m n), - trace (A⊤ × B) = Σ (fun ij => let j := (ij / m)%nat in - let i := ij mod m in - A i j * B i j) (m*n). -Proof. - intros m n A B. - rewrite trace_mmult_trans, big_sum_double_sum. - reflexivity. -Qed. - -Lemma trace_0_l : forall (A : Square 0), - trace A = 0. -Proof. - intros A. - unfold trace. - easy. -Qed. - -Lemma trace_0_r : forall n, - trace (@Zero n n) = 0. -Proof. - intros A. - unfold trace. - rewrite big_sum_0; easy. -Qed. - -Lemma trace_mplus : forall n (A B : Square n), - trace (A .+ B) = trace A + trace B. -Proof. - intros n A B. - induction n. - - rewrite 3!trace_0_l; lca. - - unfold trace in *. - rewrite <- 3!big_sum_extend_r. - setoid_rewrite (IHn A B). - lca. -Qed. - -Lemma trace_big_sum : forall n k f, - trace (big_sum (G:=Square n) f k) = Σ (fun x => trace (f x)) k. -Proof. - intros n k f. - induction k. - - rewrite trace_0_r; easy. - - rewrite <- 2!big_sum_extend_r, <-IHk. - setoid_rewrite trace_mplus. - easy. -Qed. - -Lemma Hij_decomp_mat_equiv : forall n m (A : Matrix n m), - A ≡ big_sum (G:=Matrix n m) (fun ij => - let i := (ij/m)%nat in let j := ij mod m in - A i j .* H i j) (n*m). -Proof. - intros n m A. - intros i j Hi Hj. - rewrite Msum_Csum. - symmetry. - apply big_sum_unique. - exists (i*m + j)%nat. - simpl. - repeat split. - - nia. - - rewrite Nat.div_add_l, Nat.div_small, Nat.add_0_r by lia. - rewrite Nat.add_comm, Nat.Div0.mod_add, Nat.mod_small by lia. - unfold scale, Mmult. - erewrite big_sum_unique, Cmult_1_r; [easy|]. - exists O; repeat split; auto; - unfold transpose, e_i; - intros; - rewrite !Nat.eqb_refl; - simpl_bools; - bdestructΩ'simp. - - intros ab Hab Habneq. - unfold scale, Mmult, transpose, e_i. - simpl. - rewrite Cplus_0_l. - simpl_bools. - bdestructΩ'simp. - exfalso; apply Habneq. - symmetry. - rewrite (Nat.div_mod_eq ab m) at 1 by lia. - lia. -Qed. - -Lemma Mmult_Hij_Hij_mat_equiv : forall n m o i j k l, (j < m)%nat -> - @Mmult n m o (H i j) (H k l) ≡ (if (j =? k) then H i l else Zero). -Proof. - intros n m o i j k l Hj. - intros a b Ha Hb. - unfold Mmult, transpose, e_i. - simpl. - bdestruct (j =? k). - - subst k. - rewrite Cplus_0_l. - bdestruct (a =? i); simpl; - bdestruct (b =? l); simpl; - Csimpl. - 1: simpl_bools; - replace_bool_lia (a (j < m)%nat -> - (H i j : Matrix n m) × A ≡ big_sum (G:=Matrix n o) - (fun kl : nat => A (kl / o)%nat (kl mod o) - .* (if j =? kl / o then @e_i n i × (@e_i o (kl mod o)) ⊤ else Zero)) (m * o). -Proof. - intros n m o A i j Hi Hj. - rewrite (Hij_decomp_mat_equiv _ _ A) at 1. - rewrite Mmult_Msum_distr_l. - simpl. - set (f := fun a b => A a b .* (if j =? a then @e_i n i × (@e_i o (b)) ⊤ else Zero)). - rewrite (big_sum_mat_equiv_bounded _ (fun kl => f (kl/o)%nat (kl mod o))). - 2:{ - intros kl Hkl. - rewrite Mscale_mult_dist_r. - rewrite Mmult_Hij_Hij_mat_equiv by easy. - easy. - } - easy. -Qed. - -Lemma Hij_elem : forall n m i j k l, - ((H i j) : Matrix n m) k l = if (k=?i)&&(l=?j)&&(i (j < m)%nat -> - trace (H i j × (A⊤)) = A i j. -Proof. - intros n m A i j Hi Hj. - rewrite (Hij_decomp_mat_equiv _ _ A) at 1. - rewrite (Msum_transpose n m (n*m)). - simpl. - rewrite Mmult_Hij_l_mat_equiv by easy. - erewrite big_sum_eq_bounded. - 2: { - intros ij Hij. - rewrite Msum_Csum. - erewrite big_sum_eq_bounded. - 2: { - intros k Hk. - unfold scale, transpose, Mmult, e_i. - simpl; rewrite Cplus_0_l. - rewrite if_mult_and. - replace (ij / n Σ (fun j => A i j * B j i) m) n. -Proof. - reflexivity. -Qed. - -Lemma trace_mmult_eq_comm : forall {n m} (A : Matrix n m) (B : Matrix m n), - trace (A×B) = trace (B×A). -Proof. - intros n m A B. - rewrite 2!trace_mmult_eq_ptwise. - rewrite big_sum_swap_order. - do 2 (apply big_sum_eq_bounded; intros). - apply Cmult_comm. -Qed. - -Lemma trace_transpose : forall {n} (A : Square n), - trace (A ⊤) = trace A. -Proof. - reflexivity. -Qed. - -Lemma trace_mmult_transpose_Hij_l : forall {n m} (A: Matrix m n) i j, - (i < m)%nat -> (j < n)%nat -> - trace ((H i j)⊤ × A) = A i j. -Proof. - intros n m A i j Hi Hj. - rewrite trace_mmult_eq_comm, <- trace_transpose, 3!Mmult_transpose, - 2!transpose_involutive, trace_mmult_Hij_transpose_l; try easy. -Qed. - - -Lemma trace_kron : forall {n p} (A : Square n) (B : Square p), - trace (A ⊗ B) = trace A * trace B. -Proof. - intros n p A B. - destruct p; - [rewrite Nat.mul_0_r, 2!trace_0_l; lca|]. - unfold trace. - simpl_rewrite big_sum_product; [|easy]. - reflexivity. -Qed. - -Lemma trace_kron_comm_kron : forall m n (A B : Matrix m n), - trace (kron_comm m n × (A ⊤ ⊗ B)) = trace (A⊤ × B). -Proof. - intros m n A B. - rewrite kron_comm_Hij_sum'. - rewrite Mmult_Msum_distr_r. - rewrite trace_mmult_trans', trace_big_sum. - set (f:= fun a b => A a b * B a b). - erewrite big_sum_eq_bounded. - 2:{ - intros ij Hij. - simpl. - rewrite kron_mixed_product' by lia. - rewrite trace_kron, trace_mmult_Hij_transpose_l by - (try apply Nat.Div0.div_lt_upper_bound; try apply Nat.mod_upper_bound; lia). - rewrite trace_mmult_transpose_Hij_l by - (try apply Nat.Div0.div_lt_upper_bound; try apply Nat.mod_upper_bound; lia). - fold (f (ij/n)%nat (ij mod n)). - reflexivity. - } - rewrite (Nat.mul_comm m n), <- (big_sum_double_sum f). - rewrite big_sum_swap_order. - rewrite big_sum_double_sum. - rewrite Nat.mul_comm. - easy. -Qed. - - -(* TODO: put a normal place *) -Lemma kron_comm_mx_to_vec_r_mat_equiv : forall p q (A : Matrix p q), - (mx_to_vec (A ⊤)) ⊤ × kron_comm p q ≡ (mx_to_vec A) ⊤. -Proof. - intros p q A. - match goal with - |- ?B ≡ ?C => rewrite <- (transpose_involutive _ _ B), <- (transpose_involutive _ _ C) - end. - apply transpose_simplify_mat_equiv. - rewrite Mmult_transpose. - rewrite kron_comm_transpose_mat_equiv. - rewrite 2!transpose_involutive. - apply (kron_comm_mx_to_vec_mat_equiv q p (A⊤)). -Qed. - -Lemma trace_mmult_eq_dot_mx_to_vec : forall {m n} (A B : Matrix m n), - trace (A⊤ × B) = mx_to_vec A ∘ mx_to_vec B. -Proof. - intros m n A B. - rewrite trace_mmult_eq_ptwise. - rewrite big_sum_double_sum. - unfold dot, mx_to_vec. - rewrite Nat.mul_comm. - apply big_sum_eq_bounded. - intros ij Hij. - unfold make_WF. - replace_bool_lia (ij enough (C ≡ D) by auto - end. - rewrite kron_comm_mx_to_vec_r_mat_equiv. - easy. -Qed. - -Lemma gcd_grow : forall n m, - Nat.gcd (S n) m = Nat.gcd (m mod S n) (S n). -Proof. reflexivity. Qed. - -Lemma gcd_le : forall n m, - (Nat.gcd (S n) (S m) <= S n /\ Nat.gcd (S n) (S m) <= S m)%nat. -Proof. - intros n m. - pose proof (Nat.gcd_divide (S n) (S m)). - split; apply Nat.divide_pos_le; try easy; lia. -Qed. - -Lemma div_mul_combine : forall a b c d, - Nat.divide b a -> Nat.divide d c -> - (a / b * (c / d) = (a * c) / (b * d))%nat. -Proof. - intros a b c d [a' Ha'] [c' Hc']. - subst a c. - destruct b; - [rewrite ?Nat.mul_0_r, ?Nat.mul_0_l; easy|]. - rewrite Nat.div_mul by easy. - destruct d; - [rewrite ?Nat.mul_0_r, ?Nat.mul_0_l; easy|]. - rewrite Nat.div_mul by easy. - rewrite <- Nat.mul_assoc, (Nat.mul_comm (S b)), <- Nat.mul_assoc, - Nat.mul_assoc, (Nat.mul_comm (S d)), Nat.div_mul by lia. - easy. -Qed. - -Lemma prod_eq_gcd_lcm : forall n m, - (S n * S m = Nat.gcd (S n) (S m) * Nat.lcm (S n) (S m))%nat. -Proof. - intros n m. - unfold Nat.lcm. - rewrite <- 2!Nat.Lcm0.divide_div_mul_exact, (Nat.mul_comm (Nat.gcd _ _)), - Nat.div_mul; try easy; - try (try apply Nat.divide_mul_r; apply Nat.gcd_divide; lia); - rewrite Nat.gcd_eq_0; lia. -Qed. - -Lemma gcd_eq_div_lcm : forall n m, - (Nat.gcd (S n) (S m) = (S n * S m) / (Nat.lcm (S n) (S m)))%nat. -Proof. - intros n m. - rewrite prod_eq_gcd_lcm, Nat.div_mul; try easy. - rewrite Nat.lcm_eq_0; lia. -Qed. - - - -Lemma times_n_C1 : forall n, - times_n C1 n = RtoC (INR n). -Proof. - induction n; [easy|]. - rewrite S_INR, RtoC_plus, <- IHn, Cplus_comm. - easy. -Qed. - - -Lemma div_0_r : forall n, - (n / 0 = 0)%nat. -Proof. - intros n. - easy. -Qed. - -Lemma div_divides : forall n m, - Nat.divide m n -> (n / m <> 0)%nat -> - Nat.divide (n / m) n. -Proof. - intros n m Hdiv Hnz. - assert (H: m <> O) by (intros Hfalse; subst m; rewrite div_0_r in *; lia). - exists m. - rewrite <- Nat.Lcm0.divide_div_mul_exact, Nat.mul_comm, Nat.div_mul; easy. -Qed. - -Lemma div_div : forall n m, - Nat.divide m n -> (n / m <> 0)%nat -> - (n / (n / m) = m)%nat. -Proof. - intros n m Hdiv Hnz. - rewrite <- (Nat.mul_cancel_r _ _ (n/m)) by easy. - rewrite Nat.mul_comm. - - assert (H: m <> O) by (intros Hfalse; subst m; rewrite div_0_r in *; lia). - rewrite <- Nat.Lcm0.divide_div_mul_exact, Nat.mul_comm, Nat.div_mul - by (try apply div_divides; easy). - now rewrite <- Nat.Lcm0.divide_div_mul_exact, Nat.mul_comm, Nat.div_mul. -Qed. \ No newline at end of file diff --git a/src/Permutations/MatEquivSetoid.v b/src/Permutations/MatEquivSetoid.v deleted file mode 100644 index fca3f79..0000000 --- a/src/Permutations/MatEquivSetoid.v +++ /dev/null @@ -1,382 +0,0 @@ -Require Export Setoid. -Require Export Morphisms. - -From Coq Require Export ZArith. -Ltac Zify.zify_post_hook ::= PreOmega.Z.div_mod_to_equations. - -(* Require Import PermutationAutomation. *) -From QuantumLib Require Import Matrix. - -(* This file was originally MatrixExampleBase from the ViCAR examples. - It contains instances relating to the Setoid of mat_equiv, especially - proofs that many of the common operations respect this relation. - It also contains a redefinition of direct_sum, called direct_sum' - which now respects mat_equiv. *) - -Open Scope matrix_scope. - -Definition direct_sum' {n m o p : nat} (A : Matrix n m) (B : Matrix o p) : - Matrix (n+o) (m+p) := - (fun i j => if (i WF_Matrix B -> - A .⊕' B = A .⊕ B. -Proof. - intros n m o p A B HA HB. - apply mat_equiv_eq; [|apply WF_direct_sum|]; auto with wf_db. - intros i j Hi Hj. - unfold direct_sum, direct_sum'. - bdestruct_all; try lia + easy; - rewrite HA by lia; easy. -Qed. - -Lemma direct_sum'_simplify_mat_equiv {n m o p} : forall (A B : Matrix n m) - (C D : Matrix o p), A ≡ B -> C ≡ D -> direct_sum' A C ≡ direct_sum' B D. -Proof. - intros A B C D HAB HCD i j Hi Hj. - unfold direct_sum'. - bdestruct (i (n <= n')%nat -> (m <= m')%nat -> - @WF_Matrix n' m' A. -Proof. - intros Ha Hn Hm i j Hij. - apply Ha; lia. -Qed. - -Lemma WF_Matrix_if {n m} (A B : Matrix n m) (b : bool) : - WF_Matrix A -> WF_Matrix B -> - WF_Matrix (if b then A else B). -Proof. - now destruct b. -Qed. - -#[export] Hint Resolve WF_Matrix_if : wf_db. - -Lemma direct_sum_0_r {n m} (A : Matrix n m) o p : - WF_Matrix A -> - @direct_sum' n m o p A Zero = A. -Proof. - intros HA. - apply mat_equiv_eq; - [auto with wf_db| - eapply WF_Matrix_monotone; auto with wf_db; lia| ]. - intros i j Hi Hj. - unfold direct_sum', Zero. - bdestruct_all; simpl; [easy|..]; - symmetry; apply HA; lia. -Qed. - -Lemma direct_sum_Mscale {n m p q} (A : Matrix n m) - (B : Matrix p q) (c : C) : - (c .* A) .⊕' (c .* B) = c .* (A .⊕' B). -Proof. - apply mat_equiv_eq; auto with wf_db. - intros i j Hi Hj. - autounfold with U_db. - bdestruct_all; simpl; now Csimpl. -Qed. - -Lemma ei_direct_sum_split n m k : - @e_i (n + m) k = - (if k B ≡ A. -Proof. - intros n m A B HAB i j Hi Hj. - rewrite HAB by easy. - easy. -Qed. - -Lemma mat_equiv_trans : forall {n m : nat} (A B C : Matrix n m), - A ≡ B -> B ≡ C -> A ≡ C. -Proof. - intros n m A B C HAB HBC i j Hi Hj. - rewrite HAB, HBC by easy. - easy. -Qed. - -Add Parametric Relation {n m} : (Matrix n m) mat_equiv - reflexivity proved by (mat_equiv_refl _ _) - symmetry proved by (mat_equiv_sym) - transitivity proved by (mat_equiv_trans) - as mat_equiv_rel. - -Lemma mat_equiv_eq_iff {n m} : forall (A B : Matrix n m), - WF_Matrix A -> WF_Matrix B -> A ≡ B <-> A = B. -Proof. - intros; split; try apply mat_equiv_eq; - intros; try subst A; easy. -Qed. - -Lemma Mmult_simplify_mat_equiv : forall {n m o} - (A B : Matrix n m) (C D : Matrix m o), - A ≡ B -> C ≡ D -> A × C ≡ B × D. -Proof. - intros n m o A B C D HAB HCD. - intros i j Hi Hj. - unfold Mmult. - apply big_sum_eq_bounded. - intros k Hk. - rewrite HAB, HCD by easy. - easy. -Qed. - -Add Parametric Morphism {n m o} : (@Mmult n m o) - with signature (@mat_equiv n m) ==> (@mat_equiv m o) ==> (@mat_equiv n o) - as mmult_mat_equiv_morph. -Proof. intros; apply Mmult_simplify_mat_equiv; easy. Qed. - -Lemma kron_simplify_mat_equiv {n m o p} : forall (A B : Matrix n m) - (C D : Matrix o p), A ≡ B -> C ≡ D -> A ⊗ C ≡ B ⊗ D. -Proof. - intros A B C D HAB HCD i j Hi Hj. - unfold kron. - rewrite HAB, HCD; try easy. - 1,2: apply Nat.mod_upper_bound; lia. - 1,2: apply Nat.div_lt_upper_bound; lia. -Qed. - -Add Parametric Morphism {n m o p} : (@kron n m o p) - with signature (@mat_equiv n m) ==> (@mat_equiv o p) - ==> (@mat_equiv (n*o) (m*p)) as kron_mat_equiv_morph. -Proof. intros; apply kron_simplify_mat_equiv; easy. Qed. - -Lemma Mplus_simplify_mat_equiv : forall {n m} - (A B C D : Matrix n m), - A ≡ B -> C ≡ D -> A .+ C ≡ B .+ D. -Proof. - intros n m A B C D HAB HCD. - intros i j Hi Hj; unfold ".+"; - rewrite HAB, HCD; try easy. -Qed. - -Add Parametric Morphism {n m} : (@Mplus n m) - with signature (@mat_equiv n m) ==> (@mat_equiv n m) ==> (@mat_equiv n m) - as Mplus_mat_equiv_morph. -Proof. intros; apply Mplus_simplify_mat_equiv; easy. Qed. - -Lemma scale_simplify_mat_equiv : forall {n m} - (x y : C) (A B : Matrix n m), - x = y -> A ≡ B -> x .* A ≡ y .* B. -Proof. - intros n m x y A B Hxy HAB i j Hi Hj. - unfold scale. - rewrite Hxy, HAB; easy. -Qed. - -Add Parametric Morphism {n m} : (@scale n m) - with signature (@eq C) ==> (@mat_equiv n m) ==> (@mat_equiv n m) - as scale_mat_equiv_morph. -Proof. intros; apply scale_simplify_mat_equiv; easy. Qed. - -Lemma Mopp_simplify_mat_equiv : forall {n m} (A B : Matrix n m), - A ≡ B -> Mopp A ≡ Mopp B. -Proof. - intros n m A B HAB i j Hi Hj. - unfold Mopp, scale. - rewrite HAB; easy. -Qed. - -Add Parametric Morphism {n m} : (@Mopp n m) - with signature (@mat_equiv n m) ==> (@mat_equiv n m) - as Mopp_mat_equiv_morph. -Proof. intros; apply Mopp_simplify_mat_equiv; easy. Qed. - -Lemma Mminus_simplify_mat_equiv : forall {n m} - (A B C D : Matrix n m), - A ≡ B -> C ≡ D -> Mminus A C ≡ Mminus B D. -Proof. - intros n m A B C D HAB HCD. - intros i j Hi Hj; unfold Mminus, Mopp, Mplus, scale; - rewrite HAB, HCD; try easy. -Qed. - -Add Parametric Morphism {n m} : (@Mminus n m) - with signature (@mat_equiv n m) ==> (@mat_equiv n m) ==> (@mat_equiv n m) - as Mminus_mat_equiv_morph. -Proof. intros; apply Mminus_simplify_mat_equiv; easy. Qed. - -Lemma dot_simplify_mat_equiv : forall {n} (A B : Vector n) - (C D : Vector n), A ≡ B -> C ≡ D -> dot A C = dot B D. -Proof. - intros n A B C D HAB HCD. - apply big_sum_eq_bounded. - intros k Hk. - rewrite HAB, HCD; unfold "<"%nat; easy. -Qed. - -Add Parametric Morphism {n} : (@dot n) - with signature (@mat_equiv n 1) ==> (@mat_equiv n 1) ==> (@eq C) - as dot_mat_equiv_morph. -Proof. intros; apply dot_simplify_mat_equiv; easy. Qed. - -Add Parametric Morphism {n m o p} : (@direct_sum' n m o p) - with signature (@mat_equiv n m) ==> (@mat_equiv o p) - ==> (@mat_equiv (n+o) (m+p)) as direct_sum'_mat_equiv_morph. -Proof. intros; apply direct_sum'_simplify_mat_equiv; easy. Qed. - -(* Search (Matrix ?n ?m -> ?Matrix ?n ?m). *) -Lemma transpose_simplify_mat_equiv {n m} : forall (A B : Matrix n m), - A ≡ B -> A ⊤ ≡ B ⊤. -Proof. - intros A B HAB i j Hi Hj. - unfold transpose; auto. -Qed. - -Lemma transpose_simplify_mat_equiv_inv {n m} : forall (A B : Matrix n m), - A ⊤ ≡ B ⊤ -> A ≡ B. -Proof. - intros A B HAB i j Hi Hj. - unfold transpose in *; auto. -Qed. - -Add Parametric Morphism {n m} : (@transpose n m) - with signature (@mat_equiv n m) ==> (@mat_equiv m n) - as transpose_mat_equiv_morph. -Proof. intros; apply transpose_simplify_mat_equiv; easy. Qed. - -Lemma adjoint_simplify_mat_equiv {n m} : forall (A B : Matrix n m), - A ≡ B -> A † ≡ B †. -Proof. - intros A B HAB i j Hi Hj. - unfold adjoint; - rewrite HAB by easy; easy. -Qed. - -Add Parametric Morphism {n m} : (@adjoint n m) - with signature (@mat_equiv n m) ==> (@mat_equiv m n) - as adjoint_mat_equiv_morph. -Proof. intros; apply adjoint_simplify_mat_equiv; easy. Qed. - -Lemma trace_of_mat_equiv : forall n (A B : Square n), - A ≡ B -> trace A = trace B. -Proof. - intros n A B HAB. - (* unfold trace. *) - apply big_sum_eq_bounded; intros i Hi. - rewrite HAB; auto. -Qed. - -Add Parametric Morphism {n} : (@trace n) - with signature (@mat_equiv n n) ==> (eq) - as trace_mat_equiv_morph. -Proof. intros; apply trace_of_mat_equiv; easy. Qed. - - -Lemma Mmult_assoc_mat_equiv : forall {n m o p} - (A : Matrix n m) (B : Matrix m o) (C : Matrix o p), - A × B × C ≡ A × (B × C). -Proof. - intros n m o p A B C. - rewrite Mmult_assoc. - easy. -Qed. - -Lemma mat_equiv_equivalence : forall {n m}, - equivalence (Matrix n m) mat_equiv. -Proof. - intros n m. - constructor. - - intros A. apply (mat_equiv_refl). - - intros A; apply mat_equiv_trans. - - intros A; apply mat_equiv_sym. -Qed. - - - -Lemma big_sum_mat_equiv : forall {o p} (f g : nat -> Matrix o p) - (Eq_on: forall x : nat, f x ≡ g x) (n : nat), big_sum f n ≡ big_sum g n. -Proof. - intros o p f g Eq_on n. - induction n. - - easy. - - simpl. - rewrite IHn, Eq_on; easy. -Qed. - -Add Parametric Morphism {n m} : (@big_sum (Matrix n m) (M_is_monoid n m)) - with signature - (pointwise_relation nat (@mat_equiv n m)) ==> (@eq nat) ==> - (@mat_equiv n m) - as big_sum_mat_equiv_morph. -Proof. intros f g Eq_on k. apply big_sum_mat_equiv; easy. Qed. \ No newline at end of file diff --git a/src/Permutations/PermMatrixFacts.v b/src/Permutations/PermMatrixFacts.v deleted file mode 100644 index 45dd5d2..0000000 --- a/src/Permutations/PermMatrixFacts.v +++ /dev/null @@ -1,853 +0,0 @@ -Require Import PermutationAutomation. -Require Import PermutationAuxiliary. -Require Import MatEquivSetoid. -Require Import PermutationFacts PermutationInstances. - -(* This file contains what was originally MatrixPermBase from the - ViCAR examples. It has been modified to fix the new perm_eq - notation, and also includes more results. *) - -Lemma perm_mat_permutes_ei_r : forall n f k, (k < n)%nat -> - (perm_mat n f) × (e_i k) = e_i (f k). -Proof. - intros n f k Hk. - rewrite <- mat_equiv_eq_iff by auto with wf_db. - intros i j Hi Hj. - replace j with O by lia; clear j Hj. - unfold e_i. - bdestruct (i =? f k). - - unfold perm_mat, Mmult. - bdestruct_one; [|lia]. - simpl. - apply big_sum_unique. - exists k. - repeat split; [lia | bdestructΩ'simp | ]. - intros k' Hk' Hk'k'. - bdestructΩ'simp. - - simpl. - unfold perm_mat, Mmult. - rewrite big_sum_0_bounded; [easy|]. - intros k' Hk'. - bdestructΩ'simp. -Qed. - -Lemma basis_vector_equiv_e_i : forall n k, - basis_vector n k ≡ e_i k. -Proof. - intros n k i j Hi Hj. - unfold basis_vector, e_i. - bdestructΩ'simp. -Qed. - -Lemma basis_vector_eq_e_i : forall n k, (k < n)%nat -> - basis_vector n k = e_i k. -Proof. - intros n k Hk. - rewrite <- mat_equiv_eq_iff by auto with wf_db. - apply basis_vector_equiv_e_i. -Qed. - -Lemma perm_mat_permutes_basis_vectors_r : forall n f k, (k < n)%nat -> - (perm_mat n f) × (basis_vector n k) = e_i (f k). -Proof. - intros n f k Hk. - rewrite basis_vector_eq_e_i by easy. - apply perm_mat_permutes_ei_r; easy. -Qed. - -Lemma mat_equiv_of_equiv_on_ei : forall {n m} (A B : Matrix n m), - (forall k, (k < m)%nat -> A × e_i k ≡ B × e_i k) -> - A ≡ B. -Proof. - intros n m A B Heq. - intros i j Hi Hj. - specialize (Heq j Hj). - rewrite <- 2!(matrix_by_basis _ _ Hj) in Heq. - specialize (Heq i O Hi ltac:(lia)). - unfold get_vec in Heq. - rewrite Nat.eqb_refl in Heq. - easy. -Qed. - -(* FIXME: Temp; only until pull mx stuff out of ZXExample *) -Lemma vector_eq_basis_comb : forall n (y : Vector n), - WF_Matrix y -> - y = big_sum (G:=Vector n) (fun i => y i O .* @e_i n i) n. -Proof. - intros n y Hwfy. - apply mat_equiv_eq; auto with wf_db. - intros i j Hi Hj. - replace j with O by lia; clear j Hj. - symmetry. - rewrite Msum_Csum. - apply big_sum_unique. - exists i. - repeat split; try easy. - - unfold ".*", e_i; bdestructΩ'simp. - - intros l Hl Hnk. - unfold ".*", e_i; bdestructΩ'simp. -Qed. - -Lemma vector_equiv_basis_comb : forall n (y : Vector n), - y ≡ big_sum (G:=Vector n) (fun i => y i O .* @e_i n i) n. -Proof. - intros n y. - intros i j Hi Hj. - replace j with O by lia; clear j Hj. - symmetry. - rewrite Msum_Csum. - apply big_sum_unique. - exists i. - repeat split; try easy. - - unfold ".*", e_i; bdestructΩ'simp. - - intros l Hl Hnk. - unfold ".*", e_i; bdestructΩ'simp. -Qed. - -Lemma perm_mat_permutes_matrix_r : forall n m f (A : Matrix n m), - permutation n f -> - (perm_mat n f) × A ≡ (fun i j => A (perm_inv n f i) j). -Proof. - intros n m f A Hperm. - apply mat_equiv_of_equiv_on_ei. - intros k Hk. - rewrite Mmult_assoc, <- 2(matrix_by_basis _ _ Hk). - rewrite (vector_equiv_basis_comb _ (get_vec _ _)). - rewrite Mmult_Msum_distr_l. - erewrite big_sum_eq_bounded. - 2: { - intros l Hl. - rewrite Mscale_mult_dist_r, perm_mat_permutes_ei_r by easy. - reflexivity. - } - intros i j Hi Hj; replace j with O by lia; clear j Hj. - rewrite Msum_Csum. - unfold get_vec, scale, e_i. - rewrite Nat.eqb_refl. - apply big_sum_unique. - exists (perm_inv n f i). - repeat split; auto with perm_bounded_db. - - rewrite (perm_inv_is_rinv_of_permutation n f Hperm i Hi), Nat.eqb_refl. - bdestructΩ'simp. - - intros j Hj Hjne. - bdestruct (i =? f j); [|bdestructΩ'simp]. - exfalso; apply Hjne. - apply (permutation_is_injective n f Hperm); auto with perm_bounded_db. - rewrite (perm_inv_is_rinv_of_permutation n f Hperm i Hi); easy. -Qed. - -Lemma perm_mat_equiv_of_perm_eq : forall n f g, - (perm_eq n f g) -> - perm_mat n f ≡ perm_mat n g. -Proof. - intros n f g Heq. - apply mat_equiv_of_equiv_on_ei. - intros k Hk. - rewrite 2!perm_mat_permutes_ei_r, Heq by easy. - easy. -Qed. - -#[export] Hint Resolve perm_mat_equiv_of_perm_eq : perm_inv_db. - -Lemma perm_mat_eq_of_perm_eq : forall n f g, - (perm_eq n f g) -> - perm_mat n f = perm_mat n g. -Proof. - intros. - apply mat_equiv_eq; auto with wf_db. - now apply perm_mat_equiv_of_perm_eq. -Qed. - -#[export] Hint Resolve perm_mat_eq_of_perm_eq : perm_inv_db. - -Lemma perm_mat_equiv_of_perm_eq' : forall n m f g, n = m -> - (perm_eq n f g) -> - perm_mat n f ≡ perm_mat m g. -Proof. - intros; subst n; apply perm_mat_equiv_of_perm_eq; easy. -Qed. - -Lemma perm_mat_transpose {n f} (Hf : permutation n f) : - (perm_mat n f) ⊤ ≡ perm_mat n (perm_inv n f). -Proof. - intros i j Hi Hj. - unfold "⊤". - unfold perm_mat. - simplify_bools_lia. - rewrite <- (@perm_inv_eqb_iff n f) by cleanup_perm. - now rewrite Nat.eqb_sym. -Qed. - -Lemma perm_mat_transpose_eq {n f} (Hf : permutation n f) : - (perm_mat n f) ⊤ = perm_mat n (perm_inv n f). -Proof. - apply mat_equiv_eq; auto with wf_db. - now apply perm_mat_transpose. -Qed. - -Lemma perm_mat_permutes_matrix_l : forall n m f (A : Matrix n m), - permutation m f -> - A × (perm_mat m f) ≡ (fun i j => A i (f j)). -Proof. - intros n m f A Hf. - apply transpose_simplify_mat_equiv_inv. - rewrite Mmult_transpose, perm_mat_transpose by easy. - rewrite perm_mat_permutes_matrix_r by auto with perm_db. - unfold Matrix.transpose. - intros i j Hi Hj. - cleanup_perm_inv. -Qed. - -Lemma make_WF_equiv n m (A : Matrix n m) : - make_WF A ≡ A. -Proof. - unfold make_WF. - intros i j Hi Hj. - bdestructΩ'. -Qed. - -Lemma perm_mat_permutes_matrix_l_eq : forall n m f (A : Matrix n m), - WF_Matrix A -> - permutation m f -> - A × (perm_mat m f) = make_WF (fun i j => A i (f j)). -Proof. - intros n m f A HA Hf. - apply mat_equiv_eq; auto with wf_db. - rewrite make_WF_equiv. - now apply perm_mat_permutes_matrix_l. -Qed. - -Lemma perm_mat_permutes_matrix_r_eq : forall n m f (A : Matrix n m), - WF_Matrix A -> - permutation n f -> - (perm_mat n f) × A = make_WF (fun i j => A (perm_inv n f i) j). -Proof. - intros n m f A HA Hf. - apply mat_equiv_eq; auto with wf_db. - rewrite make_WF_equiv. - now apply perm_mat_permutes_matrix_r. -Qed. - -Lemma Mmult_if_r {n m o} (A : Matrix n m) (B B' : Matrix m o) (b : bool) : - A × (if b then B else B') = - if b then A × B else A × B'. -Proof. - now destruct b. -Qed. - -Lemma Mmult_if_l {n m o} (A A' : Matrix n m) (B : Matrix m o) (b : bool) : - (if b then A else A') × B = - if b then A × B else A' × B. -Proof. - now destruct b. -Qed. - -Lemma perm_mat_idn n : - perm_mat n idn = I n. -Proof. - apply mat_equiv_eq; auto with wf_db. - intros i j Hi Hj. - unfold perm_mat, I. - bdestructΩ'. -Qed. - -Lemma perm_mat_perm_eq_idn n f : - perm_eq n f idn -> - perm_mat n f = I n. -Proof. - intros Heq. - rewrite (perm_mat_eq_of_perm_eq n f idn Heq). - apply perm_mat_idn. -Qed. - -Lemma perm_mat_transpose_rinv {n f} (Hf : permutation n f) : - (perm_mat n f) × (perm_mat n f) ⊤ = I n. -Proof. - rewrite perm_mat_transpose_eq by easy. - rewrite perm_mat_Mmult by auto with perm_db. - apply perm_mat_perm_eq_idn. - cleanup_perm_inv. -Qed. - -Lemma perm_mat_transpose_linv {n f} (Hf : permutation n f) : - (perm_mat n f) ⊤ × (perm_mat n f) = I n. -Proof. - rewrite perm_mat_transpose_eq by easy. - rewrite perm_mat_Mmult by auto with perm_db. - apply perm_mat_perm_eq_idn. - cleanup_perm_inv. -Qed. - -Lemma perm_mat_of_stack_perms n0 n1 f g : - perm_bounded n0 f -> perm_bounded n1 g -> - perm_mat (n0 + n1) (stack_perms n0 n1 f g) = - direct_sum' (perm_mat n0 f) (perm_mat n1 g). -Proof. - intros Hf Hg. - apply mat_equiv_eq; auto with wf_db. - apply mat_equiv_of_equiv_on_ei. - intros k Hk. - rewrite perm_mat_permutes_ei_r by easy. - rewrite 2!ei_direct_sum_split. - rewrite Mmult_if_r. - rewrite (direct_sum'_Mmult _ _ (e_i k) (Zero)). - rewrite (direct_sum'_Mmult _ _ (@Zero n0 0) (e_i (k - n0))). - rewrite 2!Mmult_0_r. - (* rewrite *) - bdestruct (k - @e_i n k ⊗ e_i l = - @e_i (n*m) (k*m + l). -Proof. - intros Hl. - apply mat_equiv_eq; auto with wf_db. - intros i j Hi Hj. - replace j with 0 by lia. - unfold e_i, kron. - do 2 simplify_bools_lia_one_kernel. - do 2 simplify_bools_moddy_lia_one_kernel. - rewrite Cmult_if_if_1_l. - apply f_equal_if; [|easy..]. - symmetry. - rewrite (eqb_iff_div_mod_eqb m). - rewrite mod_add_l, Nat.div_add_l by lia. - rewrite (Nat.mod_small l m Hl), (Nat.div_small l m Hl). - now rewrite Nat.add_0_r, andb_comm. -Qed. - -#[export] Hint Extern 100 (_ < _) => - show_moddy_lt : perm_bounded_db. - -Lemma perm_mat_of_tensor_perms n0 n1 f g : - perm_bounded n1 g -> - perm_mat (n0 * n1) (tensor_perms n0 n1 f g) = - perm_mat n0 f ⊗ perm_mat n1 g. -Proof. - intros Hg. - apply mat_equiv_eq; auto with wf_db. - apply mat_equiv_of_equiv_on_ei. - intros k Hk. - rewrite perm_mat_permutes_ei_r by easy. - symmetry. - rewrite ei_kron_split. - restore_dims. - rewrite kron_mixed_product. - unfold tensor_perms. - simplify_bools_lia_one_kernel. - rewrite 2!perm_mat_permutes_ei_r by show_moddy_lt. - now rewrite ei_kron_join by cleanup_perm. -Qed. - -Lemma perm_mat_inj_mat_equiv n f g - (Hf : perm_bounded n f) (Hg : perm_bounded n g) : - perm_mat n f ≡ perm_mat n g -> - perm_eq n f g. -Proof. - intros Hequiv. - intros i Hi. - generalize (Hequiv (f i) i (Hf i Hi) Hi). - unfold perm_mat. - pose proof (Hf i Hi). - pose proof C1_nonzero. - bdestructΩ'. -Qed. - -Lemma perm_mat_inj n f g - (Hf : perm_bounded n f) (Hg : perm_bounded n g) : - perm_mat n f = perm_mat n g -> - perm_eq n f g. -Proof. - rewrite <- mat_equiv_eq_iff by auto with wf_db. - now apply perm_mat_inj_mat_equiv. -Qed. - -Lemma perm_mat_determinant_sqr n f (Hf : permutation n f) : - (Determinant (perm_mat n f) ^ 2)%C = 1%R. -Proof. - simpl. - Csimpl. - rewrite Determinant_transpose at 1. - rewrite Determinant_multiplicative. - rewrite perm_mat_transpose_linv by easy. - now rewrite Det_I. -Qed. - - - - - - - - -Lemma perm_mat_perm_eq_of_proportional n f g : - (exists c, perm_mat n f = c .* perm_mat n g /\ c <> 0%R) -> - perm_bounded n f -> - perm_eq n f g. -Proof. - intros (c & Heq & Hc) Hf. - rewrite <- mat_equiv_eq_iff in Heq by auto with wf_db. - intros i Hi. - pose proof (Hf i Hi) as Hfi. - generalize (Heq (f i) i Hfi Hi). - unfold perm_mat, scale. - do 3 simplify_bools_lia_one_kernel. - rewrite Cmult_if_1_r. - pose proof C1_nonzero. - bdestructΩ'. -Qed. - -Lemma perm_mat_eq_of_proportional n f g : - (exists c, perm_mat n f = c .* perm_mat n g /\ c <> 0%R) -> - perm_bounded n f -> - perm_mat n f = perm_mat n g. -Proof. - intros H Hf. - apply perm_mat_eq_of_perm_eq. - now apply perm_mat_perm_eq_of_proportional. -Qed. - - - - - - - - - - -Lemma perm_to_matrix_perm_eq n f g : - perm_eq n f g -> - perm_to_matrix n f ≡ perm_to_matrix n g. -Proof. - intros Hfg. - apply perm_mat_equiv_of_perm_eq. - now apply qubit_perm_to_nat_perm_perm_eq. -Qed. - -#[export] Hint Resolve perm_to_matrix_perm_eq : perm_inv_db. - -Lemma perm_to_matrix_eq_of_perm_eq n f g : - perm_eq n f g -> - perm_to_matrix n f = perm_to_matrix n g. -Proof. - intros Hfg. - apply mat_equiv_eq; auto with wf_db. - now apply perm_to_matrix_perm_eq. -Qed. - -#[export] Hint Resolve perm_to_matrix_eq_of_perm_eq : perm_inv_db. - -Lemma perm_to_matrix_transpose {n f} (Hf : permutation n f) : - (perm_to_matrix n f) ⊤ ≡ perm_to_matrix n (perm_inv n f). -Proof. - unfold perm_to_matrix. - rewrite perm_mat_transpose by auto with perm_db. - cleanup_perm_inv. -Qed. - -Lemma perm_to_matrix_transpose_eq {n f} (Hf : permutation n f) : - (perm_to_matrix n f) ⊤ = perm_to_matrix n (perm_inv n f). -Proof. - apply mat_equiv_eq; auto with wf_db. - now apply perm_to_matrix_transpose. -Qed. - -Lemma perm_to_matrix_transpose' {n f} (Hf : permutation n f) : - (perm_to_matrix n f) ⊤ ≡ perm_to_matrix n (perm_inv' n f). -Proof. - rewrite perm_to_matrix_transpose by easy. - apply perm_to_matrix_perm_eq. - cleanup_perm_inv. -Qed. - -Lemma perm_to_matrix_transpose_eq' {n f} (Hf : permutation n f) : - (perm_to_matrix n f) ⊤ = perm_to_matrix n (perm_inv' n f). -Proof. - apply mat_equiv_eq; auto with wf_db. - now apply perm_to_matrix_transpose'. -Qed. - -Lemma perm_to_matrix_permutes_qubits_l n p f - (Hp : permutation n p) : - (f_to_vec n f) ⊤ × perm_to_matrix n p = - (f_to_vec n (fun x => f (perm_inv n p x))) ⊤. -Proof. - rewrite <- (transpose_involutive _ _ (perm_to_matrix _ _)). - rewrite <- Mmult_transpose. - rewrite perm_to_matrix_transpose_eq by easy. - f_equal. - apply perm_to_matrix_permutes_qubits. - now apply perm_inv_permutation. -Qed. - -#[export] Hint Resolve perm_to_matrix_perm_eq - perm_to_matrix_eq_of_perm_eq : perm_inv_db. - -Lemma perm_to_matrix_of_stack_perms n0 n1 f g - (Hf : permutation n0 f) (Hg : permutation n1 g) : - perm_to_matrix (n0 + n1) (stack_perms n0 n1 f g) = - perm_to_matrix n0 f ⊗ perm_to_matrix n1 g. -Proof. - unfold perm_to_matrix. - rewrite <- perm_mat_of_tensor_perms by cleanup_perm. - rewrite <- Nat.pow_add_r. - cleanup_perm. -Qed. - -#[export] Hint Rewrite perm_to_matrix_of_stack_perms : perm_cleanup_db. - -Lemma perm_to_matrix_idn n : - perm_to_matrix n idn = I (2^n). -Proof. - rewrite <- perm_mat_idn. - apply perm_mat_eq_of_perm_eq. - cleanup_perm_inv. -Qed. - -Lemma perm_to_matrix_compose n f g : - permutation n f -> permutation n g -> - perm_to_matrix n (f ∘ g) = - perm_to_matrix n g × perm_to_matrix n f. -Proof. - intros Hf Hg. - unfold perm_to_matrix. - rewrite perm_mat_Mmult by auto with perm_db. - now rewrite qubit_perm_to_nat_perm_compose. -Qed. - -#[export] Hint Rewrite perm_to_matrix_compose : perm_cleanup_db. - -Lemma qubit_perm_to_nat_perm_inj n f g - (Hf : perm_bounded n f) : - perm_eq (2^n) (qubit_perm_to_nat_perm n f) (qubit_perm_to_nat_perm n g) -> - perm_eq n f g. -Proof. - intros H i Hi. - specialize (H (2^(n - S (f i))) ltac:(apply Nat.pow_lt_mono_r; - auto with perm_bounded_db)). - unfold qubit_perm_to_nat_perm in H. - rewrite <- funbool_to_nat_eq_iff in H. - specialize (H i Hi). - revert H. - unfold compose. - rewrite Bits.nat_to_funbool_eq. - pose proof (Hf i Hi). - simplify_bools_lia_one_kernel. - rewrite 2!Nat.pow2_bits_eqb. - bdestructΩ'. -Qed. - -Lemma perm_to_matrix_inj_mat_equiv n f g - (Hf : perm_bounded n f) (Hg : perm_bounded n g) : - perm_to_matrix n f ≡ perm_to_matrix n g -> - perm_eq n f g. -Proof. - intros Hequiv. - apply qubit_perm_to_nat_perm_inj; [easy|]. - apply perm_mat_inj_mat_equiv; [auto with perm_bounded_db..|]. - exact Hequiv. -Qed. - -Lemma perm_to_matrix_inj n f g - (Hf : perm_bounded n f) (Hg : perm_bounded n g) : - perm_to_matrix n f = perm_to_matrix n g -> - perm_eq n f g. -Proof. - rewrite <- mat_equiv_eq_iff by auto with wf_db. - now apply perm_to_matrix_inj_mat_equiv. -Qed. - - -Lemma perm_to_matrix_perm_eq_of_proportional n f g : - (exists c, perm_to_matrix n f = - c .* perm_to_matrix n g /\ c <> 0%R) -> - perm_bounded n f -> - perm_eq n f g. -Proof. - intros H Hf. - pose proof (perm_mat_perm_eq_of_proportional _ _ _ H). - apply qubit_perm_to_nat_perm_inj; auto with perm_bounded_db. -Qed. - -Lemma perm_to_matrix_eq_of_proportional n f g : - (exists c, perm_to_matrix n f = - c .* perm_to_matrix n g /\ c <> 0%R) -> - perm_bounded n f -> - perm_to_matrix n f = perm_to_matrix n g. -Proof. - intros H Hf. - apply perm_to_matrix_eq_of_perm_eq. - now apply perm_to_matrix_perm_eq_of_proportional. -Qed. - -Definition perm_eq_id_mid (padl padm : nat) (f : nat -> nat) : Prop := - forall a, a < padm -> f (padl + a) = padl + a. - -Lemma inv_perm_eq_id_mid {padl padm padr f} - (Hf : permutation (padl + padm + padr) f) - (Hfidn : perm_eq_id_mid padl padm f) : - forall k, k < padl + padm + padr -> - padl <= f k < padl + padm -> f k = k. -Proof. - intros k Hk []. - apply (permutation_is_injective _ _ Hf); [lia..|]. - replace (f k) with (padl + (f k - padl)) by lia. - (* unfold perm_eq_id_mid in Hfidn. *) - apply Hfidn; lia. -Qed. - -Definition expand_perm_id_mid (padl padm padr : nat) - (f : nat -> nat) : nat -> nat := - stack_perms padl (padm + padr) idn (rotr (padm + padr) padm) - ∘ (stack_perms (padl + padr) padm f idn) - ∘ stack_perms padl (padm + padr) idn (rotr (padm + padr) padr). - -Arguments compose_assoc [_ _ _ _]. - -Lemma expand_perm_id_mid_compose (f g : nat -> nat) (padl padm padr : nat) - (Hf : perm_bounded (padl + padr) f) - (Hg : perm_bounded (padl + padr) g) : - expand_perm_id_mid padl padm padr f ∘ expand_perm_id_mid padl padm padr g = - expand_perm_id_mid padl padm padr (f ∘ g). -Proof. - unfold expand_perm_id_mid. - (* cleanup_perm. *) - rewrite (compose_assoc _ (stack_perms _ _ idn (rotr _ padr))), - <- !(compose_assoc _ _ (stack_perms _ _ idn (rotr _ padr))). - cleanup_perm_inv. - cleanup_perm. - rewrite (Nat.add_comm padr padm). - cleanup_perm. - rewrite compose_assoc, <- (compose_assoc _ _ (stack_perms _ _ f _)). - cleanup_perm. -Qed. - -Lemma expand_perm_id_mid_eq_of_perm_eq {padl padr f g} - (Hfg : perm_eq (padl + padr) f g) padm : - expand_perm_id_mid padl padm padr f = expand_perm_id_mid padl padm padr g. -Proof. - unfold expand_perm_id_mid. - do 2 f_equal. - now apply stack_perms_proper_eq. -Qed. - -Lemma expand_perm_id_mid_permutation {padl padr f} - (Hf : permutation (padl + padr) f) padm : - permutation (padl + padm + padr) (expand_perm_id_mid padl padm padr f). -Proof. - unfold expand_perm_id_mid. - rewrite <- Nat.add_assoc. - apply permutation_compose; [|auto with perm_db]. - apply permutation_compose; [auto with perm_db|]. - replace (padl + (padm + padr)) with (padl + padr + padm) by lia. - auto with perm_db. -Qed. - -#[export] Hint Resolve expand_perm_id_mid_permutation : perm_db. - -Definition contract_perm_id_mid (padl padm padr : nat) - (f : nat -> nat) : nat -> nat := - stack_perms padl (padm + padr) idn (rotr (padm + padr) padr) ∘ - f ∘ stack_perms padl (padm + padr) idn (rotr (padm + padr) padm). - -Lemma contract_expand_perm_perm_eq_inv padl padm padr f - (Hf : perm_bounded (padl + padr) f) : - perm_eq (padl + padr) - (contract_perm_id_mid padl padm padr - (expand_perm_id_mid padl padm padr f)) - f. -Proof. - unfold contract_perm_id_mid, expand_perm_id_mid. - rewrite !compose_assoc. - cleanup_perm. - rewrite (Nat.add_comm padr padm). - rewrite <- !compose_assoc. - cleanup_perm. - rewrite (Nat.add_comm padr padm). - cleanup_perm. - intros k Hk. - now rewrite stack_perms_left by easy. -Qed. - -Lemma stack_perms_idn_compose n0 n1 f g - (Hg : perm_bounded n1 g) : - stack_perms n0 n1 idn (f ∘ g) = - stack_perms n0 n1 idn f ∘ stack_perms n0 n1 idn g. -Proof. - cleanup_perm. -Qed. - -Lemma stack_perms_compose_idn n0 n1 f g - (Hg : perm_bounded n0 g) : - stack_perms n0 n1 (f ∘ g) idn = - stack_perms n0 n1 f idn ∘ stack_perms n0 n1 g idn. -Proof. - cleanup_perm. -Qed. - -Lemma contract_perm_id_mid_compose {padl padm padr f} - (Hf : perm_bounded (padl + padm + padr) f) g : - contract_perm_id_mid padl padm padr g ∘ contract_perm_id_mid padl padm padr f = - contract_perm_id_mid padl padm padr (g ∘ f). -Proof. - unfold contract_perm_id_mid. - rewrite (compose_assoc _ (stack_perms _ _ idn (rotr _ padm))), - <- !(compose_assoc _ _ (stack_perms _ _ idn (rotr _ padm))). - cleanup_perm. -Qed. - -Lemma contract_perm_id_mid_permutation_big {padl padm padr f} - (Hf : permutation (padl + padm + padr) f) : - permutation (padl + padm + padr) (contract_perm_id_mid padl padm padr f). -Proof. - unfold contract_perm_id_mid. - rewrite <- Nat.add_assoc in *. - auto with perm_db. -Qed. - -Lemma permutation_of_le_permutation_idn_above n m f : - permutation n f -> m <= n -> (forall k, m <= k < n -> f k = k) -> - permutation m f. -Proof. - intros Hf Hm Hfid. - pose proof Hf as Hf'. - destruct Hf' as [finv Hfinv]. - exists finv. - intros k Hk; repeat split; try (apply Hfinv; lia). - - pose proof (Hfinv k ltac:(lia)) as (?&?&?&?). - bdestructΩ (f k (f (finv k)) in Hfid. - lia. -Qed. - -Lemma contract_perm_id_mid_permutation {padl padm padr f} - (Hf : permutation (padl + padm + padr) f) - (Hfid : perm_eq_id_mid padl padm f) : - permutation (padl + padr) (contract_perm_id_mid padl padm padr f). -Proof. - apply (permutation_of_le_permutation_idn_above _ _ _ - (contract_perm_id_mid_permutation_big Hf)); - [lia|]. - intros k []. - unfold contract_perm_id_mid. - unfold compose at 1. - rewrite stack_perms_right by lia. - rewrite rotr_add_l_eq. - do 2 simplify_bools_lia_one_kernel. - unfold compose. - rewrite (Nat.add_comm _ padl), Hfid by lia. - rewrite stack_perms_right by lia. - rewrite rotr_add_r_eq. - bdestructΩ'. -Qed. - -#[export] Hint Resolve contract_perm_id_mid_permutation_big - contract_perm_id_mid_permutation : perm_db. - - -Lemma expand_contract_perm_perm_eq_idn_inv {padl padm padr f} - (Hf : permutation (padl + padm + padr) f) - (Hfidn : perm_eq_id_mid padl padm f) : - perm_eq (padl + padm + padr) - ((expand_perm_id_mid padl padm padr - (contract_perm_id_mid padl padm padr f))) - f. -Proof. - unfold contract_perm_id_mid, expand_perm_id_mid. - (* rewrite rotr_add_l_eq, rotr_add_r_eq. - rewrite 2!stack_perms_idn_f, stack_perms_f_idn. *) - intros k Hk. - rewrite (stack_perms_idn_f _ _ (rotr _ padr)) at 2. - unfold compose at 1. - - simplify_bools_lia_one_kernel. - replace (if ¬ k fail 1 - | _ => idtac - end - in - match goal with - | |- context [ ?a fail_if_iffy a; fail_if_iffy b; bdestruct (a fail_if_iffy a; fail_if_iffy b; bdestruct (a <=? b) - | |- context [ ?a =? ?b ] => fail_if_iffy a; fail_if_iffy b; bdestruct (a =? b) - | |- context[if ?b then _ else _] - => fail_if_iffy b; destruct b eqn:? - end. - - -Ltac bdestructΩ' := - let tryeasylia := try easy; try lia in - repeat (bdestruct_one; subst; tryeasylia); - tryeasylia. - - -Ltac apply_f H k := - unfold compose in H; - apply (f_equal (fun x => x k)) in H. - -Lemma is_inv_iff_inv_is n f finv : - (forall k, k < n -> finv k < n /\ f k < n /\ f (finv k) = k /\ finv (f k) = k)%nat - <-> (forall k, k < n -> f k < n /\ finv k < n /\ finv (f k) = k /\ f (finv k) = k)%nat. -Proof. - split; intros H k Hk; specialize (H k Hk); easy. -Qed. - - -#[export] Hint Rewrite is_inv_iff_inv_is : perm_inv_db. - -Ltac cleanup_perm_inv := - auto with perm_inv_db perm_db perm_bounded_db WF_Perm_db; - autorewrite with perm_inv_db; - auto with perm_inv_db perm_db perm_bounded_db WF_Perm_db. - -Ltac cleanup_perm := - auto with perm_inv_db perm_cleanup_db perm_db perm_bounded_db WF_Perm_db; - autorewrite with perm_inv_db perm_cleanup_db; - auto with perm_inv_db perm_cleanup_db perm_db perm_bounded_db WF_Perm_db. - -Ltac cleanup_perm_of_zx := - autounfold with zxperm_db; - autorewrite with perm_of_zx_cleanup_db perm_inv_db perm_cleanup_db; - auto with perm_of_zx_cleanup_db perm_inv_db perm_cleanup_db - perm_db perm_bounded_db WF_Perm_db. - -Lemma compose_id_of_compose_idn {f g : nat -> nat} - (H : (f ∘ g)%prg = (fun n => n)) {k : nat} : f (g k) = k. -Proof. - apply (f_equal_inv k) in H. - easy. -Qed. - -Ltac perm_by_inverse finv := - let tryeasylia := try easy; try lia in - exists finv; - intros k Hk; repeat split; - only 3,4 : - (try apply compose_id_of_compose_idn; cleanup_perm; tryeasylia) - || cleanup_perm; tryeasylia; - only 1,2 : auto with perm_bounded_db; tryeasylia. - -Ltac solve_stack_perm n0 n1 := - let tryeasylia := try easy; try lia in - apply functional_extensionality; intros k; - unfold stack_perms; - bdestruct (k nat) (n : nat) - {finv finv' : nat -> nat} (Hf : permutation n f) : - perm_eq n (finv ∘ f)%prg idn -> - perm_eq n (finv' ∘ f)%prg idn -> - perm_eq n finv finv'. -Proof. - apply perm_linv_injective_of_surjective. - auto with perm_db. -Qed. - -Ltac perm_eq_by_inv_inj f n := - let tryeasylia := (try easy); (try lia) in - apply (perm_inv_perm_eq_injective f n); [ - tryeasylia; auto with perm_db | - try solve [cleanup_perm; auto] | - try solve [cleanup_perm; auto]]; - tryeasylia. - -Ltac eq_by_WF_perm_eq n := - apply (eq_of_WF_perm_eq n); - auto with WF_Perm_db. - -Section ComposeLemmas. - -Local Open Scope prg. - -(* Helpers for rewriting with compose and perm_eq *) -Lemma compose_rewrite_l {f g h : nat -> nat} - (H : f ∘ g = h) : forall (i : nat -> nat), - i ∘ f ∘ g = i ∘ h. -Proof. - intros; - now rewrite compose_assoc, H. -Qed. - -Lemma compose_rewrite_l_to_2 {f g h i : nat -> nat} - (H : f ∘ g = h ∘ i) : forall (j : nat -> nat), - j ∘ f ∘ g = j ∘ h ∘ i. -Proof. - intros; - now rewrite !compose_assoc, H. -Qed. - -Lemma compose_rewrite_l_to_Id {f g : nat -> nat} - (H : f ∘ g = idn) : forall (h : nat -> nat), - h ∘ f ∘ g = h. -Proof. - intros; - now rewrite compose_assoc, H, compose_idn_r. -Qed. - -Lemma compose_rewrite_r {f g h : nat -> nat} - (H : f ∘ g = h) : forall (i : nat -> nat), - f ∘ (g ∘ i) = h ∘ i. -Proof. - intros; - now rewrite <- compose_assoc, H. -Qed. - -Lemma compose_rewrite_r_to_2 {f g h i : nat -> nat} - (H : f ∘ g = h ∘ i) : forall (j : nat -> nat), - f ∘ (g ∘ j) = h ∘ (i ∘ j). -Proof. - intros; - now rewrite <- !compose_assoc, H. -Qed. - -Lemma compose_rewrite_r_to_Id {f g : nat -> nat} - (H : f ∘ g = idn) : forall (h : nat -> nat), - f ∘ (g ∘ h) = h. -Proof. - intros; - now rewrite <- compose_assoc, H, compose_idn_l. -Qed. - -End ComposeLemmas. - -Ltac make_compose_assoc_rewrite_l lem := - lazymatch type of lem with - | forall a : ?A, @?f a => - constr:(fun a : A => ltac:( - let r := make_compose_assoc_rewrite_l (lem a) in - exact r)) - | (?F ∘ ?G)%prg = idn => - constr:(compose_rewrite_l_to_Id lem) - | (?F ∘ ?G)%prg = (?F' ∘ ?G')%prg => - constr:(compose_rewrite_l_to_2 lem) - | (?F ∘ ?G)%prg = ?H => - constr:(compose_rewrite_l lem) - end. - -Ltac make_compose_assoc_rewrite_l' lem := - lazymatch type of lem with - | forall a : ?A, @?f a => - constr:(fun a : A => ltac:( - let r := make_compose_assoc_rewrite_l' (lem a) in - exact r)) - | idn = (?F ∘ ?G)%prg => - constr:(compose_rewrite_l_to_Id (eq_sym lem)) - | (?F ∘ ?G)%prg = (?F' ∘ ?G')%prg => - constr:(compose_rewrite_l_to_2 (eq_sym lem)) - | ?H = (?F ∘ ?G)%prg => - constr:(compose_rewrite_l (eq_sym lem)) - end. - -Ltac rewrite_compose_assoc_l lem := - let lem' := make_compose_assoc_rewrite_l lem in - rewrite lem' || rewrite lem. - -Ltac rewrite_compose_assoc_l' lem := - let lem' := make_compose_assoc_rewrite_l' lem in - rewrite lem' || rewrite <- lem. - -Ltac make_compose_assoc_rewrite_r lem := - lazymatch type of lem with - | forall a : ?A, @?f a => - constr:(fun a : A => ltac:( - let r := make_compose_assoc_rewrite_r (lem a) in - exact r)) - | (?F ∘ ?G)%prg = idn => - constr:(compose_rewrite_r_to_Id lem) - | (?F ∘ ?G)%prg = (?F' ∘ ?G')%prg => - constr:(compose_rewrite_r_to_2 lem) - | (?F ∘ ?G)%prg = ?H => - constr:(compose_rewrite_r lem) - end. - -Ltac make_compose_assoc_rewrite_r' lem := - lazymatch type of lem with - | forall a : ?A, @?f a => - constr:(fun a : A => ltac:( - let r := make_compose_assoc_rewrite_r' (lem a) in - exact r)) - | idn = (?F ∘ ?G)%prg => - constr:(compose_rewrite_r_to_Id (eq_sym lem)) - | (?F ∘ ?G)%prg = (?F' ∘ ?G')%prg => - constr:(compose_rewrite_r_to_2 (eq_sym lem)) - | ?H = (?F ∘ ?G)%prg => - constr:(compose_rewrite_r (eq_sym lem)) - end. - -Ltac rewrite_compose_assoc_r lem := - let lem' := make_compose_assoc_rewrite_r lem in - rewrite lem' || rewrite lem. - -Ltac rewrite_compose_assoc_r' lem := - let lem' := make_compose_assoc_rewrite_r' lem in - rewrite lem' || rewrite <- lem. - - -Section PermComposeLemmas. - -Local Open Scope prg. - -Lemma perm_eq_compose_rewrite_l {n} {f g h : nat -> nat} - (H : perm_eq n (f ∘ g) (h)) : forall (i : nat -> nat), - perm_eq n (i ∘ f ∘ g) (i ∘ h). -Proof. - intros i k Hk. - unfold compose in *. - now rewrite H. -Qed. - -Lemma perm_eq_compose_rewrite_l_to_2 {n} {f g h i : nat -> nat} - (H : perm_eq n (f ∘ g) (h ∘ i)) : forall (j : nat -> nat), - perm_eq n (j ∘ f ∘ g) (j ∘ h ∘ i). -Proof. - intros j k Hk. - unfold compose in *. - now rewrite H. -Qed. - -Lemma perm_eq_compose_rewrite_l_to_Id {n} {f g : nat -> nat} - (H : perm_eq n (f ∘ g) idn) : forall (h : nat -> nat), - perm_eq n (h ∘ f ∘ g) h. -Proof. - intros h k Hk. - unfold compose in *. - now rewrite H. -Qed. - -Lemma perm_eq_compose_rewrite_r {n} {f g h : nat -> nat} - (H : perm_eq n (f ∘ g) h) : forall (i : nat -> nat), - perm_bounded n i -> - perm_eq n (f ∘ (g ∘ i)) (h ∘ i). -Proof. - intros i Hi k Hk. - unfold compose in *. - now rewrite H by auto. -Qed. - -Lemma perm_eq_compose_rewrite_r_to_2 {n} {f g h i : nat -> nat} - (H : perm_eq n (f ∘ g) (h ∘ i)) : forall (j : nat -> nat), - perm_bounded n j -> - perm_eq n (f ∘ (g ∘ j)) (h ∘ (i ∘ j)). -Proof. - intros j Hj k Hk. - unfold compose in *. - now rewrite H by auto. -Qed. - -Lemma perm_eq_compose_rewrite_r_to_Id {n} {f g : nat -> nat} - (H : perm_eq n (f ∘ g) idn) : forall (h : nat -> nat), - perm_bounded n h -> - perm_eq n (f ∘ (g ∘ h)) h. -Proof. - intros h Hh k Hk. - unfold compose in *. - now rewrite H by auto. -Qed. - -End PermComposeLemmas. - -Lemma perm_eq_sym {n} {f g : nat -> nat} : - perm_eq n f g -> perm_eq n g f. -Proof. - intros; symmetry; auto. -Qed. - -Lemma perm_eq_trans {n} {f g h : nat -> nat} : - perm_eq n f g -> perm_eq n g h -> perm_eq n f h. -Proof. - intros Hfg Hgh **; - rewrite Hfg; auto. -Qed. - -Ltac make_perm_eq_compose_assoc_rewrite_l lem := - lazymatch type of lem with - | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = idn l => - constr:(perm_eq_compose_rewrite_l_to_Id lem) - | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = (?F' ∘ ?G')%prg l => - constr:(perm_eq_compose_rewrite_l_to_2 lem) - | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = ?H _ => - constr:(perm_eq_compose_rewrite_l lem) - | forall a : ?A, @?f a => - constr:(fun a : A => ltac:( - let r := make_perm_eq_compose_assoc_rewrite_l (lem a) in - exact r)) - end. - -Ltac make_perm_eq_compose_assoc_rewrite_l' lem := - lazymatch type of lem with - | forall l, Nat.lt l ?n -> idn l = (?F ∘ ?G)%prg l => - constr:(perm_eq_compose_rewrite_l_to_Id (perm_eq_sym lem)) - | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = (?F' ∘ ?G')%prg l => - constr:(perm_eq_compose_rewrite_l_to_2 (perm_eq_sym lem)) - | forall l, Nat.lt l ?n -> ?H _ = (?F ∘ ?G)%prg l => - constr:(perm_eq_compose_rewrite_l (perm_eq_sym lem)) - | forall a : ?A, @?f a => - constr:(fun a : A => ltac:( - let r := make_perm_eq_compose_assoc_rewrite_l' (lem a) in - exact r)) - end. - -Ltac rewrite_perm_eq_compose_assoc_l lem := - let lem' := make_perm_eq_compose_assoc_rewrite_l lem in - rewrite lem' || rewrite lem. - -Ltac rewrite_perm_eq_compose_assoc_l' lem := - let lem' := make_perm_eq_compose_assoc_rewrite_l' lem in - rewrite lem' || rewrite <- lem. - -Ltac make_perm_eq_compose_assoc_rewrite_r lem := - lazymatch type of lem with - | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = idn l => - constr:(perm_eq_compose_rewrite_r_to_Id lem) - | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = (?F' ∘ ?G')%prg l => - constr:(perm_eq_compose_rewrite_r_to_2 lem) - | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = ?H _ => - constr:(perm_eq_compose_rewrite_r lem) - | forall a : ?A, @?f a => - constr:(fun a : A => ltac:( - let r := make_perm_eq_compose_assoc_rewrite_r (lem a) in - exact r)) - end. - -Ltac make_perm_eq_compose_assoc_rewrite_r' lem := - lazymatch type of lem with - | forall l, Nat.lt l ?n -> idn l = (?F ∘ ?G)%prg l => - constr:(perm_eq_compose_rewrite_r_to_Id (perm_eq_sym lem)) - | forall l, Nat.lt l ?n -> (?F ∘ ?G)%prg l = (?F' ∘ ?G')%prg l => - constr:(perm_eq_compose_rewrite_r_to_2 (perm_eq_sym lem)) - | forall l, Nat.lt l ?n -> ?H _ = (?F ∘ ?G)%prg l => - constr:(perm_eq_compose_rewrite_r (perm_eq_sym lem)) - | forall a : ?A, @?f a => - constr:(fun a : A => ltac:( - let r := make_perm_eq_compose_assoc_rewrite_r' (lem a) in - exact r)) - end. - -Ltac rewrite_perm_eq_compose_assoc_r lem := - let lem' := make_perm_eq_compose_assoc_rewrite_r lem in - rewrite lem' || rewrite lem. - -Ltac rewrite_perm_eq_compose_assoc_r' lem := - let lem' := make_perm_eq_compose_assoc_rewrite_r' lem in - rewrite lem' || rewrite <- lem. - - - - - - - - - -Lemma mod_add_n_r : forall m n, - (m + n) mod n = m mod n. -Proof. - intros m n. - replace (m + n)%nat with (m + 1 * n)%nat by lia. - destruct n. - - cbn; easy. - - apply Nat.Div0.mod_add. -Qed. - -Lemma mod_eq_sub : forall m n, - m mod n = (m - n * (m / n))%nat. -Proof. - intros m n. - pose proof (Nat.div_mod_eq m n). - lia. -Qed. - -Lemma mod_of_scale : forall m n q, - (n * q <= m < n * S q)%nat -> m mod n = (m - q * n)%nat. -Proof. - intros m n q [Hmq HmSq]. - rewrite mod_eq_sub. - replace (m/n)%nat with q; [lia|]. - apply Nat.le_antisymm. - - apply Nat.div_le_lower_bound; lia. - - pose proof (Nat.Div0.div_lt_upper_bound m n (S q)). - lia. -Qed. - -Lemma mod_n_to_2n : forall m n, - (n <= m < 2 * n)%nat -> m mod n = (m - n)%nat. -Proof. - intros. - pose proof (mod_of_scale m n 1). - lia. -Qed. - -Lemma mod_n_to_n_plus_n : forall m n, - (n <= m < n + n)%nat -> m mod n = (m - n)%nat. -Proof. - intros. - apply mod_n_to_2n; lia. -Qed. - -Ltac simplify_mods_of a b := - first [ - rewrite (Nat.mod_small a b) in * by lia - | rewrite (mod_n_to_2n a b) in * by lia - ]. - -Ltac solve_simple_mod_eqns := - let __fail_if_has_mods a := - match a with - | context[_ mod _] => fail 1 - | _ => idtac - end - in - match goal with - | |- context[if _ then _ else _] => fail 1 "Cannot solve equation with if" - | _ => - repeat first [ - easy - | lia - | match goal with - | |- context[?a mod ?b] => __fail_if_has_mods a; __fail_if_has_mods b; - simplify_mods_of a b - | H: context[?a mod ?b] |- _ => __fail_if_has_mods a; __fail_if_has_mods b; - simplify_mods_of a b - end - | match goal with - | |- context[?a mod ?b] => (* idtac a b; *) bdestruct (a - match type of zx1 with ZX ?n1 ?n1 => - apply (PermStack (n0:=n0) (n1:=n1)) - end end. - -#[export] Hint Extern 0 (ZXperm _ (?zx0 ↕ ?zx1)) => __cleanup_stack_perm zx0 zx1 : zxperm_db. - -(* Making proportional_of_eq_perm usable, mostly through a series of tactics to - deal with the absolute nightmare that is definitional equality casts. *) -Lemma prop_iff_double_cast : forall {n0 m0} n1 m1 (zx0 zx1 : ZX n0 m0) - (prfn: n1 = n0) (prfm : m1 = m0), - Proportional.proportional zx0 zx1 <-> - Proportional.proportional (cast n1 m1 prfn prfm zx0) (cast _ _ prfn prfm zx1). -Proof. - intros. - subst. - reflexivity. -Qed. - -Ltac __cast_prop_sides_to_square := - match goal with - | |- Proportional.proportional ?zx0 ?zx1 => - match type of zx0 with - | ZX ?n ?n => idtac - | ZX ?n ?m => - let Hm0n := fresh "Hm0n" in - assert (Hm0n : n = m) by lia; - rewrite (prop_iff_double_cast n n zx0 zx1 (eq_refl) (Hm0n)) - end - end. - -Lemma cast_compose_eq : forall n0 n1 m o0 o1 (zx0 : ZX n0 m) (zx1 : ZX m o0) Hn0n1 Ho0o1, - cast n1 o1 Hn0n1 Ho0o1 (zx0 ⟷ zx1) = - (cast n1 m Hn0n1 (@eq_refl _ m) zx0) ⟷ (cast m o1 (@eq_refl _ m) Ho0o1 zx1). -Proof. - intros. - subst. - reflexivity. -Qed. - -Lemma cast_cast_eq : forall n0 m0 n1 m1 n2 m2 (zx : ZX n0 m0) Hn0n1 Hm0m1 Hn1n2 Hm1m2, - let Hn0n2 := eq_trans Hn1n2 Hn0n1 in - let Hm0m2 := eq_trans Hm1m2 Hm0m1 in - cast n2 m2 Hn1n2 Hm1m2 (cast n1 m1 Hn0n1 Hm0m1 zx) = - cast n2 m2 Hn0n2 Hm0m2 zx. -Proof. - intros; subst. - reflexivity. -Qed. - -Lemma cast_id_eq : forall n m (prfn : n = n) (prfm : m = m) zx, - cast n m prfn prfm zx = zx. -Proof. - intros; subst. - rewrite (Eqdep_dec.UIP_refl_nat n prfn). (* Replace prfn with (@eq_refl nat n) *) - rewrite (Eqdep_dec.UIP_refl_nat m prfm). (* Replace prfn with (@eq_refl nat m) *) - reflexivity. -Qed. - -Lemma zxperm_iff_cast' : forall n0 n1 zx (H H' : n1 = n0), - ZXperm n1 (cast n1 n1 H H' zx) <-> ZXperm n0 zx. -Proof. - intros. - subst; rewrite cast_id_eq. - reflexivity. -Qed. - -#[export] Hint Resolve <- zxperm_iff_cast' : zxperm_db. - -Ltac simpl_permlike_zx := - let simpl_casts_eq := first [ - rewrite cast_id_eq | - rewrite cast_cast_eq ] - in - repeat (match goal with - | |- context[?zx ⟷ cast ?m' ?o' ?prfm ?prfo (n_wire ?o)] => - rewrite (@CastRules.cast_compose_r _ _ _ _ _ prfm prfo zx _); - rewrite (@ComposeRules.nwire_removal_r o) - | |- context[cast ?n' ?m' ?prfn ?prfm (n_wire ?n) ⟷ ?zx] => - rewrite (@CastRules.cast_compose_l _ _ _ _ _ prfn prfm _ zx); - rewrite (@ComposeRules.nwire_removal_l n) - | |- context[@cast ?n' ?m' ?n ?m ?prfn ?prfm ?zx ⟷ cast ?m' ?o' ?prfom ?prfo (n_wire ?o)] => - rewrite (@CastRules.cast_compose_l n n' m m' o' prfn prfm zx (cast m' o' prfom prfo (n_wire o))); - rewrite (cast_cast_eq _ _ _ _ _ _ (n_wire o)); - try rewrite (cast_id_eq _ _ _ _ (zx ⟷ _)) - | |- context[cast ?n ?m' ?prfn ?prfmn (n_wire ?n') ⟷ @cast ?m' ?o' ?m ?o ?prfm ?prfo ?zx] => - rewrite (@CastRules.cast_compose_r n m m' o o' prfm prfo (cast n m prfn prfmn (n_wire n')) zx); - rewrite (cast_cast_eq _ _ _ _ _ _ (n_wire n')); - try rewrite (cast_id_eq _ _ _ _ (zx ⟷ _)) - | |- context[cast ?n1 ?m _ _ ?zx0 ⟷ cast ?m ?o1 _ _ ?zx1] => - rewrite <- (cast_compose_eq _ n1 m _ o1 zx0 zx1) - | |- context[ @cast ?n1 ?m1 ?n0 ?m0 ?prfn0 ?prfm0 ?zx0 ⟷ cast ?m1 ?o1 ?prfm1 ?prfo1 ?zx1 ] => - rewrite (CastRules.cast_compose_mid m0 (eq_sym prfm0) (eq_sym prfm0) (cast n1 m1 prfn0 prfm0 zx0) (cast m1 o1 prfm1 prfo1 zx1)); - rewrite - (cast_cast_eq _ _ _ _ _ _ zx0), (cast_cast_eq _ _ _ _ _ _ zx1), - (cast_id_eq _ _ _ _ zx0) - end; repeat simpl_casts_eq) - || (repeat simpl_casts_eq). - -#[export] Hint Extern 2 => - (repeat first [rewrite cast_id_eq | rewrite cast_cast_eq]) : zxperm_db. - -Ltac __one_round_cleanup_zxperm_of_cast := - match goal with - | |- ZXperm _ (cast ?n2 ?m2 ?Hn1n2 ?Hm1m2 (@cast ?n1 ?m1 ?n0 ?m0 ?Hn0n1 ?Hm0m1 ?zx)) => (* idtac "clean_cast_cast"; *) - rewrite (cast_cast_eq n0 m0 n1 m1 n2 m2 zx Hn0n1 Hm0m1 Hn1n2 Hm1m2) - | |- ZXperm ?n (@cast ?n ?n ?n ?n _ _ ?zx) => (* idtac "clean_id"; *) - rewrite (cast_id_eq n n _ _ zx) - | |- ZXperm ?n (@cast ?n ?n ?n' ?m' _ _ (?zx0 ⟷ ?zx1)) => (* idtac "clean_comp"; *) - rewrite (cast_compose_eq _ _ _ _ _ zx0 zx1) by lia; - apply PermComp - | |- ZXperm ?n (@cast ?n ?n ?n' ?m' _ _ (?zx0 ↕ ?zx1)) => (* idtac "clean_stack"; *) - match type of zx0 with ZX ?n0 ?n0 => - match type of zx1 with ZX ?n1 ?n1 => - rewrite <- (zxperm_iff_cast' (n) (n0 + n1) (ltac:(lia)) (ltac:(lia))) - end end - end. - -#[export] Hint Extern 3 (ZXperm _ (cast _ _ _ _ _)) => __one_round_cleanup_zxperm_of_cast : zxperm_db. - -Lemma perm_of_cast_compose_each_square : forall n m a b c d - (zx0 : ZX n n) (zx1 : ZX m m) prfa0 prfb0 prfb1 prfc1 prfd1 prfd2, - ZXperm n zx0 -> ZXperm m zx1 -> - ZXperm d (cast d d prfd1 prfd2 - (cast a b prfa0 prfb0 zx0 ⟷ cast b c prfb1 prfc1 zx1)). -Proof. - intros. - subst. - auto with zxperm_db. -Qed. - -#[export] Hint Resolve perm_of_cast_compose_each_square : zxperm_db. - -(* I don't know if these actually ever help: *) -Lemma perm_of_cast_compose_each_square_l : forall n m c d - (zx0 : ZX n n) (zx1 : ZX m m) prfb1 prfc1 prfd1 prfd2, - ZXperm n zx0 -> ZXperm m zx1 -> - ZXperm d (cast d d prfd1 prfd2 - (zx0 ⟷ cast n c prfb1 prfc1 zx1)). -Proof. - intros. - subst. - auto with zxperm_db. -Qed. - -Lemma perm_of_cast_compose_each_square_r : forall n m a d - (zx0 : ZX n n) (zx1 : ZX m m) prfa0 prfm0 prfd1 prfd2, - ZXperm n zx0 -> ZXperm m zx1 -> - ZXperm d (cast d d prfd1 prfd2 - (cast a m prfa0 prfm0 zx0 ⟷ zx1)). -Proof. - intros. - subst. - auto with zxperm_db. -Qed. - - -(* #[export] Hint Resolve perm_of_cast_compose_each_square_l - perm_of_cast_compose_each_square_r : zxperm_db. *) - - -(* This can't be here because proportional_of_eq_perm is defined later, but keeping - for reference. (This is put in ZXpermSemantics, right after proportional_of_eq_perm.) *) - -(* -Ltac prop_perm_eq := - intros; - simpl_casts; - simpl_permlike_zx; - __cast_prop_sides_to_square; - (* Goal: zx0 ∝ zx1 *) - apply proportional_of_eq_perm; [ - (* New goals: *) - (*1: ZXperm _ zx0 *) auto with zxperm_db | - (*2: ZXperm _ zx1*) auto with zxperm_db | - (*3: perm_of_zx zx0 = perm_of_zx zx1*) cleanup_perm_of_zx; try easy; try lia - ]. -*) - - -Ltac simpl_bools := - repeat (simpl; rewrite ?andb_true_r, ?andb_false_r, ?orb_true_r, ?orb_false_r). - -Ltac simplify_bools_lia_one_free := - let act_T b := ((replace_bool_lia b true || replace_bool_lia b false); simpl) in - let act_F b := ((replace_bool_lia b false || replace_bool_lia b true); simpl) in - match goal with - | |- context[?b && _] => act_F b; rewrite ?andb_true_l, ?andb_false_l - | |- context[_ && ?b] => act_F b; rewrite ?andb_true_r, ?andb_false_r - | |- context[?b || _] => act_T b; rewrite ?orb_true_l, ?orb_false_l - | |- context[_ || ?b] => act_T b; rewrite ?orb_true_r, ?orb_false_r - | |- context[negb ?b] => act_T b; simpl negb - | |- context[if ?b then _ else _] => act_T b - end; simpl_bools. - -Ltac simplify_bools_lia_one_kernel := - let fail_if_iffy H := - match H with - | context [ if _ then _ else _ ] => fail 1 - | _ => idtac - end - in - let fail_if_compound H := - fail_if_iffy H; - match H with - | context [ ?a && ?b ] => fail 1 - | context [ ?a || ?b ] => fail 1 - | _ => idtac - end - in - let act_T b := (fail_if_compound b; - (replace_bool_lia b true || replace_bool_lia b false); simpl) in - let act_F b := (fail_if_compound b; - (replace_bool_lia b false || replace_bool_lia b true); simpl) in - match goal with - | |- context[?b && _] => act_F b; rewrite ?andb_true_l, ?andb_false_l - | |- context[_ && ?b] => act_F b; rewrite ?andb_true_r, ?andb_false_r - | |- context[?b || _] => act_T b; rewrite ?orb_true_l, ?orb_false_l - | |- context[_ || ?b] => act_T b; rewrite ?orb_true_r, ?orb_false_r - | |- context[negb ?b] => act_T b; simpl negb - | |- context[if ?b then _ else _] => act_T b - end; simpl_bools. - -Ltac simplify_bools_lia_many_kernel := - let fail_if_iffy H := - match H with - | context [ if _ then _ else _ ] => fail 1 - | _ => idtac - end - in - let fail_if_compound H := - fail_if_iffy H; - match H with - | context [ ?a && ?b ] => fail 1 - | context [ ?a || ?b ] => fail 1 - | _ => idtac - end - in - let act_T b := (fail_if_compound b; - (replace_bool_lia b true || replace_bool_lia b false); simpl) in - let act_F b := (fail_if_compound b; - (replace_bool_lia b false || replace_bool_lia b true); simpl) in - multimatch goal with - | |- context[?b && _] => act_F b; rewrite ?andb_true_l, ?andb_false_l - | |- context[_ && ?b] => act_F b; rewrite ?andb_true_r, ?andb_false_r - | |- context[?b || _] => act_T b; rewrite ?orb_true_l, ?orb_false_l - | |- context[_ || ?b] => act_T b; rewrite ?orb_true_r, ?orb_false_r - | |- context[negb ?b] => act_T b; simpl negb - | |- context[if ?b then _ else _] => act_T b - end; simpl_bools. - -Ltac simplify_bools_lia_one := - simplify_bools_lia_one_kernel || simplify_bools_lia_one_free. - -Ltac simplify_bools_lia := - repeat simplify_bools_lia_one. - -Ltac bdestruct_one_old := - let fail_if_iffy H := - match H with - | context [ if _ then _ else _ ] => fail 1 - | _ => idtac - end - in - match goal with - | |- context [ ?a - fail_if_iffy a; fail_if_iffy b; bdestruct (a - fail_if_iffy a; fail_if_iffy b; bdestruct (a <=? b) - | |- context [ ?a =? ?b ] => - fail_if_iffy a; fail_if_iffy b; bdestruct (a =? b) - | |- context [ if ?b then _ else _ ] => fail_if_iffy b; destruct b eqn:? - end. - -Ltac bdestruct_one_new := - let fail_if_iffy H := - match H with - | context [ if _ then _ else _ ] => fail 1 - | _ => idtac - end - in - let fail_if_booley H := - fail_if_iffy H; - match H with - | context [ ?a fail 1 - | context [ ?a <=? ?b ] => fail 1 - | context [ ?a =? ?b ] => fail 1 - | context [ ?a && ?b ] => fail 1 - | context [ ?a || ?b ] => fail 1 - | context [ negb ?a ] => fail 1 - | context [ xorb ?a ?b ] => fail 1 - | _ => idtac - end - in - let rec destruct_kernel H := - match H with - | context [ if ?b then _ else _ ] => destruct_kernel b - | context [ ?a - tryif fail_if_booley a then - (tryif fail_if_booley b then bdestruct (a - tryif fail_if_booley a then - (tryif fail_if_booley b then bdestruct (a <=? b) - else destruct_kernel b) else (destruct_kernel a) - | context [ ?a =? ?b ] => - tryif fail_if_booley a then - (tryif fail_if_booley b then bdestruct (a =? b); try subst - else destruct_kernel b) else (destruct_kernel a) - | context [ ?a && ?b ] => - destruct_kernel a || destruct_kernel b - | context [ ?a || ?b ] => - destruct_kernel a || destruct_kernel b - | context [ xorb ?a ?b ] => - destruct_kernel a || destruct_kernel b - | context [ negb ?a ] => - destruct_kernel a - | _ => idtac - end - in - simpl_bools; - match goal with - | |- context [ ?a =? ?b ] => - fail_if_iffy a; fail_if_iffy b; bdestruct (a =? b); try subst - | |- context [ ?a - fail_if_iffy a; fail_if_iffy b; bdestruct (a - fail_if_iffy a; fail_if_iffy b; bdestruct (a <=? b) - | |- context [ if ?b then _ else _ ] => fail_if_iffy b; destruct b eqn:? - end; - simpl_bools. - -Ltac bdestruct_one' := bdestruct_one_new || bdestruct_one_old. - -Ltac bdestructΩ'simp := - let tryeasylia := try easy; try lca; try lia in - tryeasylia; - repeat (bdestruct_one'; subst; simpl_bools; simpl; tryeasylia); tryeasylia. - -Local Open Scope nat. - - - -Lemma pow2_nonzero n : 2 ^ n <> 0. -Proof. - apply Nat.pow_nonzero; lia. -Qed. - -Ltac show_term_nonzero term := - match term with - | 2 ^ ?a => exact (pow2_nonzero a) - | ?a ^ ?b => exact (Nat.pow_nonzero a b ltac:(show_term_nonzero a)) - | ?a * ?b => - (assert (a <> 0) by (show_term_nonzero a); - assert (b <> 0) by (show_term_nonzero b); - lia) - | ?a + ?b => - ((assert (a <> 0) by (show_term_nonzero a) || - assert (b <> 0) by (show_term_nonzero b)); - lia) - | _ => lia - | _ => nia - end. - -Ltac show_nonzero := - match goal with - | |- ?t <> 0 => show_term_nonzero t - | |- 0 <> ?t => symmetry; show_term_nonzero t - | |- 0 < ?t => assert (t <> 0) by (show_term_nonzero t); lia - | |- ?t > 0 => assert (t <> 0) by (show_term_nonzero t); lia - | _ => lia - end. - -Ltac get_div_by_pow_2 t pwr := - match t with - | 2 ^ pwr => constr:(1) - | 2 ^ pwr * ?a => constr:(a) - | ?a * 2 ^ pwr => constr:(a) - | ?a * ?b => let ra := get_div_by_pow_2 a pwr in constr:(ra * b) - | ?a * ?b => let rb := get_div_by_pow_2 b pwr in constr:(a * rb) - | 2 ^ (?a + ?b) => - let val := constr:(2 ^ a * 2 ^ b) in - get_div_by_pow_2 val pwr - | ?a + ?b => - let ra := get_div_by_pow_2 a pwr in - let rb := get_div_by_pow_2 b pwr in - constr:(ra + rb) - | ?a - 1 => - let ra := get_div_by_pow_2 a pwr in - constr:(ra - 1) - end. - -Lemma div_mul_l a b : a <> 0 -> - (a * b) / a = b. -Proof. - rewrite Nat.mul_comm; - apply Nat.div_mul. -Qed. - - -Ltac show_div_by_pow2_ge t pwr := - (* Shows t / 2 ^ pwr <= get_div_by_pwr t pwr *) - match t with - | 2 ^ pwr => (* constr:(1) *) - rewrite (Nat.div_same (2^pwr) (pow2_nonzero pwr)); - apply Nat.le_refl - | 2 ^ pwr * ?a => (* constr:(a) *) - rewrite (div_mul_l (2^pwr) a (pow2_nonzero pwr)); - apply Nat.le_refl - | ?a * 2 ^ pwr => (* constr:(a) *) - rewrite (Nat.div_mul a (2^pwr) (pow2_nonzero pwr)); - apply Nat.le_refl - | ?a * (?b * ?c) => - let rval := constr:(a * b * c) in - show_div_by_pow2_ge rval pwr - | ?a * ?b => (* b is not right, so... *) - let rval := constr:(b * a) in - show_div_by_pow2_ge rval pwr - | ?a + ?b => - let ra := get_div_by_pow_2 a pwr in - let rb := get_div_by_pow_2 b pwr in - constr:(ra + rb) - | ?a - 1 => - fail 1 "Case not supported" - | 2 ^ (?a + ?b) => - let val := constr:(2 ^ a * 2 ^ b) in - rewrite (Nat.pow_add_r 2 a b); - show_div_by_pow2_ge val pwr - - end. - - -Ltac get_div_by t val := - match t with - | val => constr:(1) - | val * ?a => constr:(a) - | ?a * val => constr:(a) - | ?a * ?b => let ra := get_div_by a val in constr:(ra * b) - | ?a * ?b => let rb := get_div_by b val in constr:(a * rb) - | 2 ^ (?a + ?b) => - let val' := constr:(2 ^ a * 2 ^ b) in - get_div_by val' val - | ?a + ?b => - let ra := get_div_by a val in - let rb := get_div_by b val in - constr:(ra + rb) - | ?a - 1 => - let ra := get_div_by a val in - constr:(ra - 1) - end. - -Ltac show_div_by_ge t val := - (* Shows t / val <= get_div_by t val *) - match t with - | val => (* constr:(1) *) - rewrite (Nat.div_same val ltac:(show_term_nonzero val)); - apply Nat.le_refl - | val * ?a => (* constr:(a) *) - rewrite (div_mul_l val a ltac:(show_term_nonzero val)); - apply Nat.le_refl - | ?a * val => (* constr:(a) *) - rewrite (Nat.div_mul a val ltac:(show_term_nonzero val)); - apply Nat.le_refl - | ?a * (?b * ?c) => - let rval := constr:(a * b * c) in - show_div_by_ge rval val - | ?a * ?b => (* b is not right, so... *) - let rval := constr:(b * a) in - show_div_by_ge rval val - | ?a + ?b => - let ra := get_div_by a val in - let rb := get_div_by b val in - constr:(ra + rb) - | ?a - 1 => - nia || - fail 1 "Case not supported" - end. - -Ltac get_strict_upper_bound term := - match term with - | ?k mod 0 => let r := get_strict_upper_bound k in constr:(r) - | ?k mod (2 ^ ?a) => constr:(Nat.pow 2 a) - | ?k mod (?a ^ ?b) => constr:(Nat.pow a b) - | ?k mod ?a => - let _ := match goal with |- _ => assert (H: a <> 0) by show_nonzero end in - constr:(a) - | ?k mod ?a => - let _ := match goal with |- _ => assert (H: a = 0) by lia end in - constr:(k + 1) - - | 2 ^ ?a * ?t => let r := get_strict_upper_bound t in - constr:(Nat.mul (Nat.pow 2 a) r) - | ?t * 2 ^ ?a => let r := get_strict_upper_bound t in - constr:(Nat.mul r (Nat.pow 2 a)) - | ?a ^ ?b => constr:(Nat.pow a b + 1) - - | ?a + ?b => - let ra := get_strict_upper_bound a in - let rb := get_strict_upper_bound b in - constr:(ra + rb + 1) - | ?a * ?b => - let ra := get_strict_upper_bound a in - let rb := get_strict_upper_bound b in - constr:(ra * rb + 1) - | ?a / (?b * (?c * ?d)) => let rval := constr:(a / (b * c * d)) in - let r := get_strict_upper_bound rval in constr:(r) - | ?a / (?b * ?c) => let rval := constr:(a / b / c) in - let r := get_strict_upper_bound rval in constr:(r) - | ?a / (2 ^ ?b) => - let ra := get_strict_upper_bound a in - let rr := get_div_by_pow_2 ra b in constr:(rr) - - | ?t => match goal with - | H : t < ?a |- _ => constr:(a) - | H : t <= ?a |- _ => constr:(a + 1) - | _ => constr:(t + 1) - end - end. - -Ltac get_upper_bound term := - match term with - | ?k mod 0 => let r := get_upper_bound k in constr:(r) - | ?k mod (2 ^ ?a) => constr:(Nat.sub (Nat.pow 2 a) 1) - | ?k mod (?a ^ ?b) => constr:(Nat.sub (Nat.pow a b) 1) - | ?k mod ?a => - let H := fresh in - let _ := match goal with |- _ => - assert (H: a <> 0) by show_nonzero; clear H end in - constr:(a - 1) - | ?k mod ?a => - let H := fresh in - let _ := match goal with |- _ => - assert (H: a = 0) by lia; clear H end in - let rk := get_upper_bound k in - constr:(rk) - - | 2 ^ ?a * ?t => let r := get_upper_bound t in - constr:(Nat.mul (Nat.pow 2 a) r) - | ?t * 2 ^ ?a => let r := get_upper_bound t in - constr:(Nat.mul r (Nat.pow 2 a)) - | ?a ^ ?b => constr:(Nat.pow a b) - - | ?a + ?b => - let ra := get_upper_bound a in - let rb := get_upper_bound b in - constr:(ra + rb) - | ?a * ?b => - let ra := get_upper_bound a in - let rb := get_upper_bound b in - constr:(ra * rb) - | ?a / (?b * (?c * ?d)) => let rval := constr:(a / (b * c * d)) in - let r := get_upper_bound rval in constr:(r) - | ?a / (?b * ?c) => let rval := constr:(a / b / c) in - let r := get_upper_bound rval in constr:(r) - | ?a / (2 ^ ?b) => - let ra := get_strict_upper_bound a in - let rr := get_div_by_pow_2 ra b in constr:(rr - 1) - - | ?a / ?b => - let ra := get_strict_upper_bound a in - let rr := get_div_by ra b in constr:(rr - 1) - - | ?t => match goal with - | H : t < ?a |- _ => constr:(a - 1) - | H : t <= ?a |- _ => constr:(a) - | _ => t - end - end. - -Lemma mul_ge_l_of_nonzero p q : q <> 0 -> - p <= p * q. -Proof. - nia. -Qed. - -Lemma mul_ge_r_of_nonzero p q : p <> 0 -> - q <= p * q. -Proof. - nia. -Qed. - -Ltac show_pow2_le := - rewrite ?Nat.pow_add_r, - ?Nat.mul_add_distr_r, ?Nat.mul_add_distr_l, - ?Nat.mul_sub_distr_r, ?Nat.mul_sub_distr_l, - ?Nat.mul_1_r, ?Nat.mul_1_l; - repeat match goal with - |- context [2 ^ ?a] => - tryif assert (2 ^ a <> 0) by assumption - then fail - else pose proof (pow2_nonzero a) - end; - nia || ( - repeat match goal with - | |- context [?p * ?q] => - tryif assert (p <> 0) by assumption - then - (tryif assert (q <> 0) by assumption - then fail - else assert (q <> 0) by nia) - else assert (p <> 0) by nia; - (tryif assert (q <> 0) by assumption - then idtac else assert (q <> 0) by nia) - end; - repeat match goal with - | |- context [?p * ?q] => - tryif assert (p <= p * q) by assumption - then - (tryif assert (q <= p * q) by assumption - then fail - else pose proof (mul_ge_r_of_nonzero p q ltac:(assumption))) - else pose proof (mul_ge_l_of_nonzero p q ltac:(assumption)); - (tryif assert (q <= p * q) by assumption - then idtac - else pose proof (mul_ge_r_of_nonzero p q ltac:(assumption))) - end; - nia). - - -Lemma lt_of_le_sub_1 a b : - b <> 0 -> a <= b - 1 -> a < b. -Proof. lia. Qed. - -Lemma le_sub_1_of_lt a b : - a < b -> a <= b - 1. -Proof. lia. Qed. - - -Ltac show_le_upper_bound term := - lazymatch term with - | ?k mod 0 => - rewrite (Nat.mod_0_r k); - show_le_upper_bound k - | ?k mod (2 ^ ?a) => - exact (le_sub_1_of_lt (k mod (2^a)) (2^a) - (Nat.mod_upper_bound k (2^a) (pow2_nonzero a))) - | ?k mod (?a ^ ?b) => - exact (le_sub_1_of_lt (k mod (2^a)) (a^b) - (Nat.mod_upper_bound k (a^b) - (Nat.pow_nonzero a b ltac:(show_term_nonzero a)))) - | ?k mod ?a => - let H := fresh in - let _ := match goal with |- _ => - assert (H: a <> 0) by show_nonzero end in - exact (le_sub_1_of_lt _ _ (Nat.mod_upper_bound k a H)) - | ?k mod ?a => - let H := fresh in - let _ := match goal with |- _ => - assert (H: a = 0) by lia end in - rewrite H; - show_le_upper_bound k - - | 2 ^ ?a * ?t => let r := get_upper_bound t in - apply (Nat.mul_le_mono_l t _ (2^a)); - show_le_upper_bound t - | ?t * 2 ^ ?a => let r := get_upper_bound t in - apply (Nat.mul_le_mono_r t _ (2^a)); - show_le_upper_bound t - | ?a ^ ?b => - apply Nat.le_refl - - | ?a + ?b => - apply Nat.add_le_mono; - [ - (* match goal with |- ?G => idtac G "should be about" a end; *) - show_le_upper_bound a | - show_le_upper_bound b] - | ?a * ?b => - apply Nat.mul_le_mono; - [ - (* match goal with |- ?G => idtac G "should be about" a end; *) - show_le_upper_bound a | - show_le_upper_bound b] - | ?a / (?b * (?c * ?d)) => - let H := fresh in - pose proof (f_equal (fun x => a / x) (Nat.mul_assoc b c d) : - a / (b * (c * d)) = a / (b * c * d)) as H; - rewrite H; - clear H; - let rval := constr:(a / (b * c * d)) in - show_le_upper_bound rval - | ?a / (?b * ?c) => - let H := fresh in - pose proof (eq_sym (Nat.Div0.div_div a b c) : - a / (b * c) = a / b / c) as H; - rewrite H; - clear H; - let rval := constr:(a / b / c) in - show_le_upper_bound rval - | ?a / (2 ^ ?b) => - let ra := get_upper_bound a in - apply (Nat.le_trans (a / (2^b)) (ra / (2^b)) _); - [apply Nat.Div0.div_le_mono; - show_le_upper_bound a | - tryif show_div_by_pow2_ge ra b then idtac - else - match goal with - | |- (?val - 1) / 2 ^ ?pwr <= ?rhs - 1 => - apply le_sub_1_of_lt, Nat.Div0.div_lt_upper_bound; - tryif nia || show_pow2_le then idtac - else fail 20 "nia failed" "on (" val "- 1) / 2 ^" pwr "<=" rhs "- 1" - | |- ?G => - tryif nia then idtac else - fail 40 "show div failed for" a "/ (2^" b "), ra =" ra - "; full goal:" G - end] - | ?a / ?b => - let ra := get_upper_bound a in - apply (Nat.le_trans (a / b) (ra / b) _); - [apply Nat.Div0.div_le_mono; - show_le_upper_bound a | - tryif show_div_by_ge ra b then idtac - else - match goal with - | |- (?val - 1) / ?den <= ?rhs - 1 => - apply le_sub_1_of_lt, Nat.Div0.div_lt_upper_bound; - tryif nia || show_pow2_le then idtac - else fail 20 "nia failed" "on (" val "- 1) / " den "<=" rhs "- 1" - | |- ?G => - tryif nia then idtac else - fail 40 "show div failed for" a "/ (" b "), ra =" ra - "; full goal:" G - end] - | ?t => match goal with - | _ => nia - end - end. - -Ltac show_moddy_lt := - lazymatch goal with - | |- Bits.funbool_to_nat ?n ?f < ?b => - apply (Nat.lt_le_trans (Bits.funbool_to_nat n f) (2^n) b); - [apply (Bits.funbool_to_nat_bound n f) | show_pow2_le] - | |- Nat.b2n ?b < ?a => - apply (Nat.le_lt_trans (Nat.b2n b) (2^1) a); - [destruct b; simpl; lia | show_pow2_le] - | |- ?a < ?b => - let r := get_upper_bound a in - apply (Nat.le_lt_trans a r b); - [show_le_upper_bound a | show_pow2_le] - | |- ?a <= ?b => (* Likely not to work *) - let r := get_upper_bound a in - apply (Nat.le_trans a r b); - [show_le_upper_bound a | show_pow2_le] - | |- ?a > ?b => - change (b < a); show_moddy_lt - | |- ?a >= ?b => - change (b <= a); show_moddy_lt - | |- (?a - apply (proj2 (Nat.ltb_lt a b)); - show_moddy_lt - | |- true = (?a - symmetry; - apply (proj2 (Nat.ltb_lt a b)); - show_moddy_lt - | |- (?a <=? ?b) = false => - apply (proj2 (Nat.leb_gt a b)); - show_moddy_lt - | |- false = (?a <=? ?b) => - symmetry; - apply (proj2 (Nat.leb_gt a b)); - show_moddy_lt - end. - -Ltac try_show_moddy_lt := - lazymatch goal with - | |- Bits.funbool_to_nat ?n ?f < ?b => - apply (Nat.le_lt_trans (Bits.funbool_to_nat n f) (2^n) b); - [apply (Bits.funbool_to_nat_bound n f) | try show_pow2_le] - | |- Nat.b2n ?b < ?a => - apply (Nat.le_lt_trans (Nat.b2n b) (2^1) a); - [destruct b; simpl; lia | try show_pow2_le] - | |- ?a < ?b => - let r := get_upper_bound a in - apply (Nat.le_lt_trans a r b); - [try show_le_upper_bound a | try show_pow2_le] - | |- ?a <= ?b => (* Likely not to work *) - let r := get_upper_bound a in - apply (Nat.le_trans a r b); - [try show_le_upper_bound a | try show_pow2_le] - | |- ?a > ?b => - change (b < a); try_show_moddy_lt - | |- ?a >= ?b => - change (b <= a); try_show_moddy_lt - | |- (?a - apply (proj2 (Nat.ltb_lt a b)); - try_show_moddy_lt - | |- true = (?a - symmetry; - apply (proj2 (Nat.ltb_lt a b)); - try_show_moddy_lt - | |- (?a <=? ?b) = false => - apply (proj2 (Nat.leb_gt a b)); - try_show_moddy_lt - | |- false = (?a <=? ?b) => - symmetry; - apply (proj2 (Nat.leb_gt a b)); - try_show_moddy_lt - end. - -Ltac replace_bool_moddy_lia b0 b1 := - first - [ replace b0 with b1 - by (show_moddy_lt || bdestruct b0; show_moddy_lt + lia - || (destruct b1 eqn:?; lia)) - | replace b0 with b1 - by (bdestruct b1; lia || (destruct b0 eqn:?; lia)) - | replace b0 with b1 - by (bdestruct b0; bdestruct b1; lia) ]. - -Ltac simpl_bools_nosimpl := - repeat (rewrite ?andb_true_r, ?andb_false_r, ?orb_true_r, ?orb_false_r). - -Ltac simplify_bools_moddy_lia_one_kernel := - let fail_if_iffy H := - match H with - | context [ if _ then _ else _ ] => fail 1 - | _ => idtac - end - in - let fail_if_compound H := - fail_if_iffy H; - match H with - | context [ ?a && ?b ] => fail 1 - | context [ ?a || ?b ] => fail 1 - | _ => idtac - end - in - let act_T b := (fail_if_compound b; - (replace_bool_moddy_lia b true - || replace_bool_moddy_lia b false); simpl) in - let act_F b := (fail_if_compound b; - (replace_bool_moddy_lia b false - || replace_bool_moddy_lia b true); simpl) in - match goal with - | |- context[?b && _] => act_F b; rewrite ?andb_true_l, ?andb_false_l - | |- context[_ && ?b] => act_F b; rewrite ?andb_true_r, ?andb_false_r - | |- context[?b || _] => act_T b; rewrite ?orb_true_l, ?orb_false_l - | |- context[_ || ?b] => act_T b; rewrite ?orb_true_r, ?orb_false_r - | |- context[negb ?b] => act_T b; cbn [negb] - | |- context[if ?b then _ else _] => act_T b - end; simpl_bools_nosimpl. - -(* For VyZX lemmas which create a ton of shelved goals, this solves - them immediately (and ensures they *are* solvable, seemingly - unlike auto_cast_eqns) *) -Tactic Notation "clean_eqns" tactic(tac) := - unshelve (tac); [reflexivity + lia..|]. - - - -(* The following originate from ExamplesAutomation from the ViCAR examples*) -Require Import String. - -Ltac print_hyps := - try (match reverse goal with | H : ?p |- _ => idtac H ":" p; fail end). - -Ltac print_goal := - match reverse goal with |- ?P => idtac P; idtac "" end. - -Ltac print_state := - print_hyps; - idtac "---------------------------------------------------------"; - print_goal. - -Ltac is_C0 x := assert (x = C0) by (cbv; lca). - -Ltac is_C1 x := assert (x = C1) by (cbv; lca). - -Tactic Notation "print_C" constr(x) := (tryif is_C0 x then constr:("0"%string) else - tryif is_C1 x then constr:("1"%string) else constr:("X"%string)). - -Ltac print_LHS_matU := - intros; - (let i := fresh "i" in - let j := fresh "j" in - let Hi := fresh "Hi" in - let Hj := fresh "Hj" in - intros i j Hi Hj; try solve_end; - repeat (* Enumerate rows and columns; see `by_cell` *) - (destruct i as [| i]; [ | apply <- Nat.succ_lt_mono in Hi ]; - try solve_end); clear Hi; - repeat - (destruct j as [| j]; [ | apply <- Nat.succ_lt_mono in Hj ]; - try solve_end); clear Hj - ); - match goal with |- ?x = ?y ?i ?j => autounfold with U_db; simpl; - match goal with - | |- ?x = _ => - tryif is_C0 x then idtac "A[" i "," j "] = 0" else - tryif is_C1 x then idtac "A[" i "," j "] = 1" else - idtac "A[" i "," j "] = X" - end -end. - -Ltac simplify_mods_one := - let __fail_if_has_mods a := - match a with - | context [ _ mod _ ] => fail 1 - | _ => idtac - end - in - match goal with - | |- context [ ?a mod ?b ] => - __fail_if_has_mods a; __fail_if_has_mods b; - simplify_mods_of a b - | H:context [ ?a mod ?b ] |- _ => - __fail_if_has_mods a; __fail_if_has_mods b; - simplify_mods_of a b - end. - -Ltac case_mods_one := - match goal with - | |- context [ ?a mod ?b ] => - bdestruct (a ( - match type of A with Matrix ?m' ?n' => - match type of B with Matrix ?n'' ?o'' => - let Hm' := fresh "Hm'" in let Hn' := fresh "Hn'" in - let Hn'' := fresh "Hn''" in let Ho'' := fresh "Hoo'" in - assert (Hm' : m = m') by lia; - assert (Hn' : n = n') by lia; - assert (Hn'' : n = n'') by lia; - assert (Ho' : o = o'') by lia; - replace (@Mmult m n o A B) with (@Mmult m' n' o A B) - by (first [try (rewrite Hm' at 1); try (rewrite Hn' at 1); reflexivity | f_equal; lia]); - apply WF_mult; [ - auto with wf_db | - apply WF_Matrix_dim_change; - auto with wf_db - ] - end end) : wf_db. - -#[export] Hint Extern 100 (_ < _) => - show_moddy_lt || show_pow2_le : perm_bounded_db. \ No newline at end of file diff --git a/src/Permutations/PermutationAuxiliary.v b/src/Permutations/PermutationAuxiliary.v deleted file mode 100644 index 5a646b5..0000000 --- a/src/Permutations/PermutationAuxiliary.v +++ /dev/null @@ -1,1514 +0,0 @@ -Require Import PermutationAutomation. - -Section AuxiliaryLemmas. - -Import Bits Bool. - -Section nat_lemmas. - -Import Nat. - -Local Open Scope nat. - -Lemma add_sub' n m : m + n - m = n. -Proof. - lia. -Qed. - -Lemma add_leb_mono_l n m d : - (n + m <=? n + d) = (m <=? d). -Proof. - bdestructΩ'. -Qed. - -Lemma add_ltb_mono_l n m d : - (n + m m <= d. -Proof. lia. Qed. - -Lemma add_lt_cancel_l_iff n m d : - n + m < n + d <-> m < d. -Proof. lia. Qed. - -Lemma add_ge_cancel_l_iff n m d : - n + m >= n + d <-> m >= d. -Proof. lia. Qed. - -Lemma add_gt_cancel_l_iff n m d : - n + m > n + d <-> m > d. -Proof. lia. Qed. - -Lemma sub_lt_iff n m p (Hp : 0 <> p) : - n - m < p <-> n < m + p. -Proof. - split; lia. -Qed. - -Lemma add_assoc_four {a b c d} : a + b + c + d = a + (b + c + d). -Proof. - now rewrite 2!Nat.add_assoc. -Qed. - -Lemma add_assoc_three {a b c} : a + (b + c) = a + b + c. -Proof. - now rewrite Nat.add_assoc. -Qed. - -Lemma sub_eq_iff {a b m} : b <= a -> - a - b = m <-> a = b + m. -Proof. - lia. -Qed. - -Lemma pow_pos (n m : nat) : n <> 0 -> 0 < n ^ m. -Proof. - induction m; simpl; lia. -Qed. - -Lemma n_le_pow_2_n (n : nat) : n <= 2 ^ n. -Proof. - induction n; simpl; [lia|]. - pose proof (pow_pos 2 n). - lia. -Qed. - -Lemma add_sub_four (n m o : nat) : - n + m - o - n = m - o. -Proof. lia. Qed. - -Lemma div_mul_not_exact a b : b <> 0 -> - (a / b) * b = a - (a mod b). -Proof. - intros Hb. - rewrite (Nat.div_mod a b Hb) at 1 2. - rewrite Nat.add_sub. - rewrite (Nat.mul_comm b (a/b)), Nat.add_comm, Nat.div_add by easy. - rewrite Nat.div_small by (apply Nat.mod_upper_bound; easy). - easy. -Qed. - -Lemma mod_div a b : a mod b / b = 0. -Proof. - destruct b; [easy|]. - apply Nat.div_small, Nat.mod_upper_bound; easy. -Qed. - -Lemma mod_add_l a b c : (a * b + c) mod b = c mod b. -Proof. - rewrite Nat.add_comm. - apply Nat.Div0.mod_add. -Qed. - -Lemma min_ltb n m : min n m = if n ; easy|]. - intros. - rewrite (Nat.div_mod_eq i a), (Nat.div_mod_eq j a). - lia. -Qed. - -Lemma eqb_div_mod_pow_2_iff a i j k l : - i mod 2 ^ a + 2 ^ a * j =? k mod 2 ^ a + 2 ^ a * l = - ((i mod 2 ^ a =? k mod 2 ^ a) && - (j =? l)). -Proof. - apply eq_iff_eq_true. - rewrite andb_true_iff, !Nat.eqb_eq. - split; try lia. - rewrite 2!(Nat.mul_comm (2^a)). - intros H. - generalize (f_equal (fun x => x mod 2^a) H). - rewrite 2!Nat.Div0.mod_add, !Nat.Div0.mod_mod. - intros; split; [easy|]. - generalize (f_equal (fun x => x / 2^a) H). - now rewrite 2!Nat.div_add, !Nat.div_small by - (show_nonzero + show_moddy_lt). -Qed. - -Lemma succ_even_lt_even a b : Nat.even a = true -> - Nat.even b = true -> - a < b -> S a < b. -Proof. - intros Ha Hb Hab. - enough (S a <> b) by lia. - intros Hf. - apply (f_equal Nat.even) in Hf. - rewrite Nat.even_succ in Hf. - rewrite <- Nat.negb_even in Hf. - rewrite Ha, Hb in Hf. - easy. -Qed. - -Lemma succ_odd_lt_odd a b : Nat.odd a = true -> - Nat.odd b = true -> - a < b -> S a < b. -Proof. - intros Ha Hb Hab. - enough (S a <> b) by lia. - intros Hf. - apply (f_equal Nat.even) in Hf. - rewrite Nat.even_succ in Hf. - rewrite <- Nat.negb_odd in Hf. - rewrite Ha, Hb in Hf. - easy. -Qed. - -Lemma even_add_same n : Nat.even (n + n) = true. -Proof. - now rewrite Nat.even_add, eqb_reflx. -Qed. - -Lemma even_succ_false n : - Nat.even (S n) = false <-> Nat.even n = true. -Proof. - rewrite Nat.even_succ, <- Nat.negb_even. - now destruct (Nat.even n). -Qed. - -Lemma even_succ_add_same n : Nat.even (S (n + n)) = false. -Proof. - now rewrite even_succ_false, even_add_same. -Qed. - -Lemma odd_succ_false n : - Nat.odd (S n) = false <-> Nat.odd n = true. -Proof. - rewrite Nat.odd_succ, <- Nat.negb_odd. - now destruct (Nat.odd n). -Qed. - -Lemma double_add n m : n + m + (n + m) = n + n + (m + m). -Proof. - lia. -Qed. - -Lemma sub_leb_eq n m p : - n - m <=? p = (n <=? m + p). -Proof. - bdestructΩ'. -Qed. - -Lemma sub_ltb_eq_nonzero n m p : p <> 0 -> - n - m - n - m l < n -> k <> l -> - 2^k + 2^l < 2 ^ n. -Proof. - intros. - bdestruct (2^k + 2^l - n - S (n - S k) = k. -Proof. - lia. -Qed. - -Section testbit_lemmas. - -Lemma testbit_add_pow2_small (i j s n : nat) (Hs : s < n) : - Nat.testbit (i + 2^n * j) s = Nat.testbit i s. -Proof. - rewrite 2!Nat.testbit_eqb. - replace n with (s + (n - s)) by lia. - rewrite Nat.pow_add_r, <- Nat.mul_assoc, Nat.mul_comm, Nat.div_add by - (apply Nat.pow_nonzero; lia). - destruct (n - s) eqn:e; [lia|]. - cbn [Nat.pow]. - rewrite <- Nat.mul_assoc, Nat.mul_comm, Nat.Div0.mod_add by lia. - easy. -Qed. - -Lemma testbit_add_pow2_large (i j s n : nat) (Hs : n <= s) (Hi : i < 2^n) : - Nat.testbit (i + 2^n * j) s = Nat.testbit j (s - n). -Proof. - replace s with (s-n + n) at 1 by lia. - generalize (s - n) as d. - intros d. - rewrite 2!Nat.testbit_eqb. - do 2 f_equal. - rewrite Nat.pow_add_r, (Nat.mul_comm _ (2^_)), Nat.mul_comm, - <- Nat.Div0.div_div, Nat.div_add by - (apply Nat.pow_nonzero; lia). - rewrite (Nat.div_small i) by easy. - easy. -Qed. - -Lemma testbit_add_pow2_split i j n (Hi : i < 2^n) : - forall s, - Nat.testbit (j * 2 ^ n + i) s = - if s - i mod 2^m = j mod 2^m -> i mod 2^n = j mod 2^n. -Proof. - intros Hnm Heq. - replace m with (n + (m - n)) in * by lia. - generalize dependent (m - n). - intros k _. - rewrite Nat.pow_add_r, 2!Nat.Div0.mod_mul_r. - intros H. - apply (f_equal (fun k => k mod 2^n)) in H. - revert H. - rewrite 2!(Nat.mul_comm (2^n)). - rewrite 2!Nat.Div0.mod_add, 2!Nat.Div0.mod_mod. - easy. -Qed. - -Lemma bits_inj_upto i j n : - (forall s, s < n -> Nat.testbit i s = Nat.testbit j s) <-> - i mod 2^n = j mod 2^n. -Proof. - split. - - intros Heq. - induction n; - [now rewrite 2!Nat.mod_1_r|]. - rewrite 2!mod_2_pow_S. - f_equal; [|apply IHn; intros k Hk; apply Heq; lia]. - rewrite Heq by lia. - easy. - - intros Heq s Hs. - rewrite 2!Nat.testbit_eqb. - rewrite (Nat.div_mod i (2^(S s)) ltac:(apply Nat.pow_nonzero; lia)). - rewrite (Nat.div_mod j (2^(S s)) ltac:(apply Nat.pow_nonzero; lia)). - rewrite (mod_pow2_eq_closed_down i j (S s) n ltac:(lia) Heq). - rewrite 2!(Nat.mul_comm (2^ S s)), 2!(Nat.add_comm (_*_)). - rewrite Nat.pow_succ_r by lia. - rewrite 2!Nat.mul_assoc. - rewrite 2!Nat.div_add by (apply Nat.pow_nonzero; lia). - rewrite 2!Nat.Div0.mod_add. - easy. -Qed. - -Lemma lt_pow2_S_log2 i : i < 2 ^ S (Nat.log2 i). -Proof. - destruct i; [cbn; lia|]. - apply Nat.log2_spec; lia. -Qed. - -Lemma bits_inj_upto_small i j n (Hi : i < 2^n) (Hj : j < 2^n) : - (forall s, s < n -> Nat.testbit i s = Nat.testbit j s) <-> - i = j. -Proof. - split; [|intros ->; easy]. - intros H; apply bits_inj_upto in H. - assert (H2n : 2^n <> 0) by (apply Nat.pow_nonzero; lia). - rewrite (Nat.div_mod i (2^n) H2n), (Nat.div_mod j (2^n) H2n). - rewrite 2!Nat.div_small, Nat.mul_0_r by lia. - easy. -Qed. - -Lemma bits_inj i j : - (forall s, Nat.testbit i s = Nat.testbit j s) <-> i = j. -Proof. - split; [|intros ->; easy]. - set (ub := 2^ max (S (Nat.log2 i)) (S (Nat.log2 j))). - assert (Hi : i < ub) by - (enough (i < 2 ^ (S (Nat.log2 i))) by - (pose proof (Nat.pow_le_mono_r 2 (S (Nat.log2 i)) _ - ltac:(easy) (Nat.le_max_l _ (S (Nat.log2 j)))); lia); - apply lt_pow2_S_log2). - assert (Hj : j < ub) by - (enough (j < 2 ^ (S (Nat.log2 j))) by - (pose proof (Nat.pow_le_mono_r 2 (S (Nat.log2 j)) _ - ltac:(easy) (Nat.le_max_r (S (Nat.log2 i)) _)); lia); - apply lt_pow2_S_log2). - intros s. - apply (bits_inj_upto_small i j _ Hi Hj). - intros; easy. -Qed. - -Lemma testbit_make_gap i m k s : - Nat.testbit (i mod 2^m + (i/2^m) * 2^k * (2^m)) s = - if s Prop) n - (H : forall f, P (funbool_to_nat n f)) : - forall i, i < 2 ^ n -> P i. -Proof. - intros i Hi. - rewrite <- (nat_to_funbool_inverse n i Hi). - apply H. -Qed. - -Lemma div_add' n m p : - (n + m) / p = - n / p + m / p + (n mod p + m mod p) / p. -Proof. - rewrite (Nat.div_mod_eq n p) at 1. - rewrite (Nat.div_mod_eq m p) at 1. - bdestruct (p =? 0); [now subst|]. - symmetry. - rewrite Nat.add_comm. - rewrite <- Nat.div_add by easy. - f_equal. - lia. -Qed. - -Lemma sum_eq_lxor_of_bits_disj_l n m : - (forall k, Nat.testbit n k = true -> Nat.testbit m k = false) -> - n + m = Nat.lxor n m. -Proof. - intros Hnm. - apply bits_inj. - intros s. - rewrite lxor_spec. - revert n m Hnm. - induction s; - intros n m Hnm; - [apply Nat.odd_add|]. - simpl. - rewrite !div2_div. - rewrite div_add'. - rewrite <- !bit0_mod. - rewrite (div_small (_ + _)), Nat.add_0_r by - (generalize (Hnm 0); - destruct (testbit n 0), (testbit m 0); - simpl; lia). - apply IHs. - intros k. - rewrite 2!div2_bits; auto. -Qed. - -Lemma testbit_add_disjoint_pow2_l k n : - Nat.testbit n k = false -> - forall i, - Nat.testbit (2^k + n) i = (i =? k) || testbit n i. -Proof. - intros Hn i. - rewrite sum_eq_lxor_of_bits_disj_l, lxor_spec, pow2_bits_eqb, eqb_sym. - - bdestructΩ'. - now rewrite Hn. - - intros s. - rewrite pow2_bits_eqb. - bdestructΩ'. -Qed. - -Lemma testbit_sum_pows_2_ne k l : k <> l -> forall i, - Nat.testbit (2 ^ k + 2 ^ l) i = (i =? k) || (i =? l). -Proof. - intros Hkl i. - rewrite testbit_add_disjoint_pow2_l; - rewrite pow2_bits_eqb; bdestructΩ'. -Qed. - -Lemma testbit_add_disjoint m n : - (forall k, Nat.testbit n k = true -> Nat.testbit m k = false) -> - forall i, - Nat.testbit (n + m) i = testbit n i || testbit m i. -Proof. - intros Hn i. - rewrite sum_eq_lxor_of_bits_disj_l, lxor_spec by easy. - generalize (Hn i). - destruct (testbit n i), (testbit m i); lia + auto. -Qed. - -Lemma testbit_b2n b k : - testbit (b2n b) k = b && (k =? 0). -Proof. - destruct b, k; easy + apply Nat.bits_0. -Qed. - -Lemma testbit_decomp n k : - n = (n / 2 ^ (S k)) * 2 ^ (S k) + - b2n (testbit n k) * 2 ^ k + (n mod 2^k). -Proof. - apply bits_inj. - intros s. - rewrite Nat.pow_succ_r, Nat.mul_assoc, <- Nat.mul_add_distr_r by lia. - rewrite testbit_add_pow2_split by show_moddy_lt. - change 2 with (2^1) at 4. - rewrite testbit_add_pow2_split by (destruct (testbit n k); simpl; lia). - rewrite testbit_b2n. - rewrite <- Nat.pow_succ_r by lia. - rewrite testbit_div_pow2, testbit_mod_pow2. - bdestructΩ'; rewrite ?andb_true_r; f_equal; lia. -Qed. - -End testbit_lemmas. - -End nat_lemmas. - -Import Setoid. - -Section bool_lemmas. - -Lemma eqb_true_l b : eqb true b = b. -Proof. now destruct b. Qed. - -Lemma eqb_true_r b : eqb b true = b. -Proof. now destruct b. Qed. - -Lemma neq_iff_neq_true b c : - b <> c <-> (b = true <-> ~ (c = true)). -Proof. - destruct b, c; split; easy + intros []; auto. - discriminate H0. - easy. -Qed. - -Lemma neq_iff_impls b c : - b <> c <-> - ((b = true -> ~ (c = true)) /\ - (c = true -> ~ (b = true)) /\ - (b = false -> ~ (c = false))). -Proof. - destruct b, c; split; easy + intros (? & ? & ?); auto. -Qed. - -End bool_lemmas. - -Section Assorted_lemmas. - -Lemma if_true {A} b (u v : A) : - b = true -> - (if b then u else v) = u. -Proof. - bdestructΩ'. -Qed. - -Lemma if_false {A} b (u v : A) : - b = false -> - (if b then u else v) = v. -Proof. - bdestructΩ'. -Qed. - -Lemma if_dist' {A B} (f : A -> B) (b : bool) (x y : A) : - f (if b then x else y) = if b then f x else f y. -Proof. - now destruct b. -Qed. - -Lemma orb_if {A} b c (v v' : A) : - (if (b || c) then v else v') = - if b then v else if c then v else v'. -Proof. - bdestructΩ'. -Qed. - -Lemma f_equal_if {A} (b c : bool) (u v x y : A) : - b = c -> u = v -> x = y -> - (if b then u else x) = (if c then v else y). -Proof. - intros; subst; easy. -Qed. - -Lemma f_equal_if_precedent {A} b c (v1 v2 u1 u2 : A) : - b = c -> - (b = true -> c = true -> v1 = v2) -> - (b = false -> c = false -> u1 = u2) -> - (if b then v1 else u1) = (if c then v2 else u2). -Proof. - intros ->. - destruct c; auto. -Qed. - -Lemma f_equal_if_precedent_same {A} b (v1 v2 u1 u2 : A) : - (b = true -> v1 = v2) -> - (b = false -> u1 = u2) -> - (if b then v1 else u1) = (if b then v2 else u2). -Proof. - intros. - apply f_equal_if_precedent; auto. -Qed. - -Lemma and_same (P : Prop) : P /\ P <-> P. -Proof. split; try intros []; auto. Qed. - -Local Open Scope nat_scope. - -Lemma and_andb {P P'} {b b'} : - reflect P b -> reflect P' b' -> - reflect (P /\ P') (b && b'). -Proof. - intros H H'; apply reflect_iff in H, H'. - apply iff_reflect. - rewrite andb_true_iff. - now rewrite H, H'. -Qed. - -Lemma forall_iff {A} (f g : A -> Prop) : - (forall a, (f a <-> g a)) -> - ((forall a, f a) <-> (forall a, g a)). -Proof. - intros ?; split; intros; apply H; auto. -Qed. - -Lemma impl_iff (P Q Q' : Prop) : - ((P -> Q) <-> (P -> Q')) <-> - (P -> (Q <-> Q')). -Proof. - split; - intros ?; split; intros; apply H; auto. -Qed. - -Import Setoid. - -Lemma Forall_forallb {A} (f : A -> bool) (P : A -> Prop) - (Hf : forall a, P a <-> f a = true) : - forall l, Forall P l <-> forallb f l = true. -Proof. - intros l. - induction l; [repeat constructor|]. - simpl. - rewrite andb_true_iff. - rewrite Forall_cons_iff. - apply Morphisms_Prop.and_iff_morphism; easy. -Qed. - -Lemma eq_eqb_iff (b c : bool) : - b = c <-> eqb b c = true. -Proof. - destruct b, c ; easy. -Qed. - -Lemma Forall_seq {start len : nat} f : - Forall f (seq start len) <-> forall k, k < len -> f (start + k). -Proof. - revert start; - induction len; intros start; - [split; constructor + lia|]. - simpl. - rewrite Forall_cons_iff. - split. - - intros [Hfk H]. - rewrite IHlen in H. - intros k Hk. - destruct k. - + rewrite Nat.add_0_r; easy. - + specialize (H k). - rewrite Nat.add_succ_r. - apply H. - lia. - - intros H. - rewrite IHlen; split. - + specialize (H 0). - rewrite Nat.add_0_r in H. - apply H; lia. - + intros k Hk; specialize (H (S k)). - rewrite Nat.add_succ_r in H. - apply H. - lia. -Qed. - -Lemma Forall_seq0 {len : nat} f : - Forall f (seq 0 len) <-> forall k, k < len -> f k. -Proof. - apply (@Forall_seq 0 len f). -Qed. - -Lemma forallb_seq (f : nat -> bool) n m : - forallb f (seq m n) = true <-> - (forall s, s < n -> f (s + m) = true). -Proof. - revert m; - induction n; intros m; [easy|]. - simpl. - rewrite andb_true_iff, IHn. - split. - - intros [Hm Hlt]. - intros s. - destruct s; [easy|]. - setoid_rewrite Nat.add_succ_r in Hlt. - intros. - apply Hlt; lia. - - intros Hlt; split. - + apply (Hlt 0 ltac:(lia)). - + intros s Hs. - rewrite Nat.add_succ_r. - apply (Hlt (S s)). - lia. -Qed. - -Lemma forallb_seq0 (f : nat -> bool) n : - forallb f (seq 0 n) = true <-> - (forall s, s < n -> f s = true). -Proof. - rewrite forallb_seq. - now setoid_rewrite Nat.add_0_r. -Qed. - -Lemma forall_lt_sum_split n m (P : nat -> Prop) : - (forall k, k < n + m -> P k) <-> - (forall k, k < n -> P k) /\ (forall k, k < m -> P (n + k)). -Proof. - split; [intros H; split; intros; apply H; lia|]. - intros [Hlow Hhigh]. - intros. - bdestruct (k G) n : - - big_sum f n = big_sum (fun k => - f k) n. -Proof. - induction n; simpl. - - apply Gopp0. - - rewrite Gopp_plus_distr. - now rewrite Gplus_comm, IHn. -Qed. - -Lemma big_sum_if_or - (ifl ifr : nat -> bool) - (f : nat -> G) (n : nat) : - big_sum (fun k => if ifl k || ifr k then f k else 0) n = - big_sum (fun k => if ifl k then f k else 0) n + - big_sum (fun k => if ifr k then f k else 0) n - - big_sum (fun k => if ifl k && ifr k then f k else 0) n. -Proof. - unfold Gminus. - rewrite big_sum_opp. - rewrite <- 2!big_sum_plus. - apply big_sum_eq_bounded. - intros. - bdestructΩ'; rewrite <- Gplus_assoc, ?Gopp_r, - ?Gopp0, ?Gplus_0_r, ?Gplus_0_l; easy. -Qed. - -Lemma big_sum_if_eq (f : nat -> G) n k : - big_sum (fun x => if x =? k then f x else 0) n = - if k G) n k : - big_sum (fun x => if k =? x then f x else 0) n = - if k G) n k l : k <> l -> - big_sum (fun x => if (x =? k) || (x =? l) then f x else 0) n = - (if k G) (Hi : (i < n)) : - big_sum v n = (big_sum v i) + v i + (big_sum (shift v (i + 1)) (n - 1 - i)). -Proof. - intros. - induction n; [lia|]. - bdestruct (i =? n). - - subst. - replace (S n - 1 - n)%nat with O by lia. - rewrite <- big_sum_extend_r. - simpl. - solve_monoid. - - specialize (IHn ltac:(lia)). - replace (S n - 1 - i)%nat with (S (n - 1 - i))%nat by lia. - rewrite <- !big_sum_extend_r. - rewrite IHn. - unfold shift; simpl. - replace (n - 1 - i + (i + 1))%nat with n by lia. - now rewrite Gplus_assoc. -Qed. - -Lemma big_sum_eq_up_to_fswap n (v : nat -> G) f x y (Hx : x < n) (Hy : y < n) : - big_sum (fun i => v (f i)) n = - big_sum (fun i => v (fswap f x y i)) n. -Proof. - bdestruct (x =? y); - [apply big_sum_eq_bounded; unfold fswap; intros; - bdestructΩ'|]. - bdestruct (x G) f (Hf : permutation n f) : - big_sum v n = big_sum (fun i => v (f i)) n. -Proof. - intros. - generalize dependent f. - induction n. - reflexivity. - intros f [g Hg]. - destruct (Hg n) as [_ [H1' [_ H2']]]; try lia. - symmetry. - rewrite (big_sum_eq_up_to_fswap _ v _ (g n) n) by auto. - repeat rewrite <- big_sum_extend_r. - rewrite fswap_simpl2. - rewrite H2'. - specialize (IHn (fswap f (g n) n)). - rewrite <- IHn; [easy|]. - apply fswap_at_boundary_permutation; auto. - exists g. auto. -Qed. - -Lemma big_sum_product_div_mod_split n m (f : nat -> G) : - big_sum f (n * m) = - big_sum (fun i => big_sum (fun j => f (j + i * n)%nat) n) m. -Proof. - rewrite big_sum_double_sum. - apply big_sum_eq_bounded. - intros k Hk. - f_equal. - rewrite (Nat.div_mod_eq k n) at 1. - lia. -Qed. - -End BigSumLemmas. - - -Section C_lemmas. - - -Local Open Scope C_scope. - -Lemma big_sum_if_eq_C (f : nat -> C) n k : - Σ (fun x => if x =? k then f x else 0%R) n = - (if k C) n k : - Σ (fun x => if k =? x then f x else 0%R) n = - (if k c = false) -> (c = true -> b = false) -> - ((if b then v else 0%R) + (if c then v else 0%R) = - if b || c then v else 0%R)%C. -Proof. - destruct b, c; simpl; intros; lca. -Qed. - -Lemma Cmult_if_l (b : bool) (c d : C) : - (if b then c else 0%R) * d = - if b then c * d else 0%R. -Proof. - destruct b; now Csimpl. -Qed. - -Lemma Cmult_if_r (b : bool) (c d : C) : - d * (if b then c else 0%R) = - if b then d * c else 0%R. -Proof. - destruct b; now Csimpl. -Qed. - -Lemma Cmult_if_andb (b c : bool) (x y : C) : - (if b then x else 0%R) * (if c then y else 0%R) = - if b && c then x * y else 0%R. -Proof. - destruct b,c; now Csimpl. -Qed. - -Lemma Cmult_if_1_l (b : bool) (d : C) : - (if b then C1 else 0%R) * d = - if b then d else 0%R. -Proof. - destruct b; now Csimpl. -Qed. - -Lemma Cmult_if_1_r (b : bool) (d : C) : - d * (if b then C1 else 0%R) = - if b then d else 0%R. -Proof. - destruct b; now Csimpl. -Qed. - -Lemma Cmult_if_if_1_l (b c : bool) (x : C) : - (if b then C1 else 0%R) * (if c then x else 0%R) = - if b && c then x else 0%R. -Proof. - destruct b; now Csimpl. -Qed. - -Lemma Cmult_if_if_1_r (b c : bool) (x : C) : - (if b then x else 0%R) * (if c then C1 else 0%R) = - if b && c then x else 0%R. -Proof. - destruct b,c; now Csimpl. -Qed. - -Lemma Cdiv_mult_r (c d : C) : d <> 0%R -> - c / d * d = c. -Proof. - intros. - C_field_simplify; trivial. -Qed. - -Lemma Cdiv_mult_l (c d : C) : d <> 0%R -> - d * c / d = c. -Proof. - intros. - C_field_simplify; trivial. -Qed. - -Lemma Cdiv_mult_l' (c d : C) : d <> 0%R -> - d * (c / d) = c. -Proof. - intros. - C_field_simplify; trivial. -Qed. - -Lemma Cdiv_nonzero (c d : C) : c <> 0%R -> d <> 0%R -> - c / d <> 0%R. -Proof. - intros Hc Hd Hf; apply Hc. - apply (f_equal (Cmult d)) in Hf. - rewrite Cdiv_mult_l' in Hf; [|easy]. - revert Hf. - now Csimpl. -Qed. - -Lemma C1_nonzero : C1 <> 0%R. -Proof. - unfold C1. - intros H; inversion H. - lra. -Qed. - -Lemma C2_nonzero : C2 <> 0%R. -Proof. - unfold C2. - intros H; inversion H. - lra. -Qed. - -End C_lemmas. - -Local Notation "A ⩧ B" := (mat_equiv A B) (at level 70) : matrix_scope. - -Section matrix_lemmas. - -#[global] Add Parametric Relation {n m} : (Matrix n m) (@mat_equiv n m) - reflexivity proved by ltac:(easy) - symmetry proved by ltac:(intros A B H i j Hi Hj; - symmetry; apply H; easy) - transitivity proved by ltac:(intros A B C H H' i j Hi Hj; - transitivity (B i j); [apply H | apply H']; easy) - as mat_equiv_setoid. - -#[global] Add Parametric Morphism {n m} : (@scale n m) - with signature - eq ==> (@mat_equiv n m) ==> mat_equiv - as scale_mat_equiv_proper. -Proof. - unfold scale. - intros x A B H i j Hi Hj. - rewrite (H i j Hi Hj). - easy. -Qed. - -#[global] Add Parametric Morphism {n m o} : (@Mmult m n o) - with signature - @mat_equiv m n ==> @mat_equiv n o ==> @mat_equiv m o - as Mmult_proper. -Proof. - intros A A' HA B B' HB. - unfold Mmult. - intros i j Hi Hj. - apply big_sum_eq_bounded. - intros k Hk. - now rewrite HA, HB. -Qed. - -#[global] Add Parametric Morphism {n m o p} : (@kron m n o p) - with signature - @mat_equiv m n ==> @mat_equiv o p ==> - @mat_equiv (m*o) (n*p) - as kron_proper. -Proof. - intros A A' HA B B' HB. - unfold kron. - intros i j Hi Hj. - rewrite HA, HB; - [easy|..]; - apply Nat.mod_upper_bound + apply Nat.Div0.div_lt_upper_bound; lia. -Qed. - -#[global] Add Parametric Morphism n m : (@Matrix.transpose n m) - with signature - @mat_equiv n m ==> @mat_equiv m n - as transpose_proper. -Proof. - unfold mat_equiv. - intros A B H i j Hi Hj. - now apply H. -Qed. - -Local Open Scope nat. -Local Open Scope matrix_scope. - - -Lemma transpose_proper_inv {n m} (A B : Matrix n m) : - A ⊤ ⩧ B ⊤ -> A ⩧ B. -Proof. - intros H i j Hi Hj; - now apply H. -Qed. - -Lemma mat_equiv_prop_symm {n m} (A B : Matrix n m) : - (exists c : C, mat_equiv A (c .* B) /\ c <> 0%R) - <-> exists c : C, mat_equiv B (c .* A) /\ c <> 0%R. -Proof. - split; - intros (c & Heq & Hc); - Proportional.prop_exists_nonzero (/ c); auto; - now rewrite Heq, Mscale_assoc, Cmult_comm, Cinv_r, Mscale_1_l. -Qed. - -Lemma kron_I_r {n m p} (A : Matrix n m) : - mat_equiv (A ⊗ I p) - (fun i j => if i mod p =? j mod p then A (i / p) (j / p) else C0). -Proof. - intros i j Hi Hj. - unfold kron, I. - pose proof (Nat.mod_upper_bound i p ltac:(lia)). - bdestructΩ'; lca. -Qed. - -Lemma kron_I_l {n m p} (A : Matrix n m) : - mat_equiv (I p ⊗ A) - (fun i j => if i / n =? j / m then A (i mod n) (j mod m) else C0). -Proof. - intros i j Hi Hj. - unfold kron, I. - rewrite Nat.mul_comm in Hi. - pose proof (Nat.Div0.div_lt_upper_bound _ _ _ Hi). - bdestructΩ'; lca. -Qed. - -Lemma kron_transpose' [m n o p] (A : Matrix m n) (B : Matrix o p) : - forall mo' mp', - @Matrix.transpose mo' mp' (A ⊗ B) = - (@Matrix.transpose m n A) ⊗ (@Matrix.transpose o p B). -Proof. - intros. - apply kron_transpose. -Qed. - -Lemma kron_1_l_mat_equiv {m n} (A : Matrix m n) : - I 1 ⊗ A ⩧ A. -Proof. - intros i j Hi Hj. - unfold kron. - rewrite !Nat.div_small, !Nat.mod_small by lia. - apply Cmult_1_l. -Qed. - -Lemma matrix_times_basis_eq_lt {m n : nat} (A : Matrix m n) (i j : nat) : - j < n -> (A × basis_vector n j) i 0 = A i j. -Proof. - intros Hj. - unfold Mmult. - rewrite (big_sum_eq_bounded _ (fun k => if k =? j then A i j else 0%R)%C). - 2: { - intros k Hk. - unfold basis_vector. - bdestructΩ'; lca. - } - rewrite big_sum_if_eq_C. - bdestructΩ'. -Qed. - -Lemma matrix_times_basis_mat_equiv {m n : nat} (A : Matrix m n) (j : nat) : - j < n -> mat_equiv (A × basis_vector n j) - (get_vec j A). -Proof. - intros Hj i z Hi Hz. - replace z with 0 by lia. - rewrite matrix_times_basis_eq_lt by easy. - unfold get_vec. - bdestructΩ'. -Qed. - -Lemma matrix_conj_basis_eq_lt {m n : nat} (A : Matrix m n) (i j : nat) : - i < m -> j < n -> ((basis_vector m i)⊤ × A × basis_vector n j) 0 0 = A i j. -Proof. - intros Hi Hj. - rewrite matrix_times_basis_mat_equiv by lia. - unfold get_vec. - bdestructΩ'. - unfold Mmult, Matrix.transpose. - rewrite (big_sum_eq_bounded _ (fun k => if k =? i then A i j else 0%R)%C). - 2: { - intros k Hk. - unfold basis_vector. - bdestructΩ'; lca. - } - rewrite big_sum_if_eq_C. - bdestructΩ'. -Qed. - -Lemma mat_equiv_of_all_basis_conj {m n : nat} (A B : Matrix m n) - (H : forall (i j : nat), i < m -> j < n -> - ((basis_vector m i) ⊤ × A × basis_vector n j) 0 0 = - ((basis_vector m i) ⊤ × B × basis_vector n j) 0 0) : - mat_equiv A B. -Proof. - intros i j Hi Hj. - specialize (H i j Hi Hj). - now rewrite 2!matrix_conj_basis_eq_lt in H by easy. -Qed. - -Lemma basis_trans_basis {n} i j : - ((basis_vector n i) ⊤ × basis_vector n j) 0 0 = - if (i =? j) && (i f (m + k)) (* : Matrix _ 1) *))). -Proof. - rewrite <- kron_mixed_product. - rewrite f_to_vec_merge. - Morphisms.f_equiv. - apply f_to_vec_eq. - intros; bdestructΩ'; f_equal; lia. -Qed. - -Lemma f_to_vec_split' n m f : - mat_equiv (f_to_vec (n + m) f) - (f_to_vec n f ⊗ f_to_vec m (fun k => f (n + k))). -Proof. - intros i j Hi Hj. - rewrite f_to_vec_merge. - erewrite f_to_vec_eq; [reflexivity|]. - intros; simpl; bdestructΩ'; f_equal; lia. -Qed. - -Lemma f_to_vec_split'_eq n m f : - (f_to_vec (n + m) f) = - (f_to_vec n f ⊗ f_to_vec m (fun k => f (n + k))). -Proof. - apply mat_equiv_eq; [..|apply f_to_vec_split']; auto with wf_db. -Qed. - -Lemma f_to_vec_1_eq f : - f_to_vec 1 f = if f 0 then ∣1⟩ else ∣0⟩. -Proof. - cbn. - unfold ket. - rewrite kron_1_l by (destruct (f 0); auto with wf_db). - now destruct (f 0). -Qed. - -Lemma f_to_vec_1_mult_r f (A : Matrix (2^1) (2^1)) : - A × f_to_vec 1 f = (fun x j => if j =? 0 then A x (Nat.b2n (f 0)) else 0%R). -Proof. - cbn. - rewrite kron_1_l by auto with wf_db. - apply functional_extensionality; intros i. - apply functional_extensionality; intros j. - unfold Mmult. - simpl. - destruct (f 0); - unfold ket; - simpl; - now destruct j; simpl; Csimpl. -Qed. - -Lemma f_to_vec_1_mult_r_decomp f (A : Matrix (2^1) (2^1)) : - A × f_to_vec 1 f ⩧ - A 0 (Nat.b2n (f 0)) .* ∣0⟩ .+ - A 1 (Nat.b2n (f 0)) .* ∣1⟩. -Proof. - rewrite f_to_vec_1_mult_r. - intros i j Hi Hj. - replace j with 0 by lia. - simpl. - autounfold with U_db. - do 2 (try destruct i); [..| simpl in *; lia]; - now Csimpl. -Qed. - -Lemma f_to_vec_1_mult_r_decomp_eq f (A : Matrix (2^1) (2^1)) : - WF_Matrix A -> - A × f_to_vec 1 f = - A 0 (Nat.b2n (f 0)) .* ∣0⟩ .+ - A 1 (Nat.b2n (f 0)) .* ∣1⟩. -Proof. - intros. - apply mat_equiv_eq; auto with wf_db. - apply f_to_vec_1_mult_r_decomp. -Qed. - -Lemma qubit0_f_to_vec : ∣0⟩ = f_to_vec 1 (fun x => false). -Proof. now rewrite f_to_vec_1_eq. Qed. - -Lemma qubit1_f_to_vec : ∣1⟩ = f_to_vec 1 (fun x => x =? 0). -Proof. now rewrite f_to_vec_1_eq. Qed. - -Lemma ket_f_to_vec b : ∣ Nat.b2n b ⟩ = f_to_vec 1 (fun x => b). -Proof. - destruct b; [apply qubit1_f_to_vec | apply qubit0_f_to_vec]. -Qed. - -Lemma f_to_vec_1_mult_r_decomp_eq' f (A : Matrix (2^1) (2^1)) : - WF_Matrix A -> - A × f_to_vec 1 f = - A 0 (Nat.b2n (f 0)) .* f_to_vec 1 (fun x => false) .+ - A 1 (Nat.b2n (f 0)) .* f_to_vec 1 (fun x => x=?0). -Proof. - intros. - apply mat_equiv_eq; auto with wf_db. - rewrite f_to_vec_1_mult_r_decomp. - rewrite 2!f_to_vec_1_eq. - easy. -Qed. - -Lemma f_to_vec_1_mult_l_decomp f (A : Matrix (2^1) (2^1)) : - (f_to_vec 1 f) ⊤ × A ⩧ - A (Nat.b2n (f 0)) 0 .* (∣0⟩ ⊤) .+ - A (Nat.b2n (f 0)) 1 .* (∣1⟩ ⊤). -Proof. - rewrite <- (transpose_involutive _ _ A). - rewrite <- Mmult_transpose, <- Mscale_trans. - intros i j Hi Hj. - apply (f_to_vec_1_mult_r_decomp f (A ⊤)); easy. -Qed. - -Lemma f_to_vec_1_mult_l_decomp_eq f (A : Matrix (2^1) (2^1)) : - WF_Matrix A -> - (f_to_vec 1 f) ⊤ × A = - A (Nat.b2n (f 0)) 0 .* (∣0⟩ ⊤) .+ - A (Nat.b2n (f 0)) 1 .* (∣1⟩ ⊤). -Proof. - intros. - apply mat_equiv_eq; auto with wf_db. - apply f_to_vec_1_mult_l_decomp. -Qed. - -Lemma f_to_vec_1_mult_l_decomp_eq' f (A : Matrix (2^1) (2^1)) : - WF_Matrix A -> - (f_to_vec 1 f) ⊤ × A = - A (Nat.b2n (f 0)) 0 .* ((f_to_vec 1 (fun x => false)) ⊤) .+ - A (Nat.b2n (f 0)) 1 .* ((f_to_vec 1 (fun x => x =? 0)) ⊤). -Proof. - intros. - apply mat_equiv_eq; auto with wf_db. - rewrite f_to_vec_1_mult_l_decomp_eq by easy. - now rewrite qubit0_f_to_vec, qubit1_f_to_vec. -Qed. - -Lemma funbool_to_nat_add_pow2_join n f g m : - funbool_to_nat n f * 2 ^ m + funbool_to_nat m g = - funbool_to_nat (n + m) (fun k => if k f (n + k - (min n m))). -Proof. - apply bits_inj. - intros s. - rewrite testbit_mod_pow2, 2!testbit_funbool_to_nat. - rewrite min_ltb. - bdestructΩ'; f_equal; lia. -Qed. - -Lemma funbool_to_nat_eq_iff n f g : - (forall k, k < n -> f k = g k) <-> funbool_to_nat n f = funbool_to_nat n g. -Proof. - split; - [apply funbool_to_nat_eq|]. - intros H k Hk. - apply (f_equal (fun f => Nat.testbit f (n - S k))) in H. - revert H. - rewrite 2!testbit_funbool_to_nat. - simplify_bools_lia. - now replace (n - S (n - S k)) with k by lia. -Qed. - -(* For setoid_rewrite *) -Lemma nat_to_funbool_eq' n j k : - nat_to_funbool n j k = - if k <=? n - 1 then Nat.testbit j (n - S k) else false. -Proof. - now rewrite nat_to_funbool_eq. -Qed. - -End QuantumLib_lemmas. - -End matrix_lemmas. - -End AuxiliaryLemmas. diff --git a/src/Permutations/PermutationDefinitions.v b/src/Permutations/PermutationDefinitions.v deleted file mode 100644 index 4a50b61..0000000 --- a/src/Permutations/PermutationDefinitions.v +++ /dev/null @@ -1,91 +0,0 @@ -Require Export QuantumLib.Permutations. -Require Import CoreData.ZXCore. - -Declare Scope perm_scope. -Delimit Scope perm_scope with perm. - -Section PermutationDefinitions. - -Local Open Scope nat_scope. - -Definition stack_perms (n0 n1 : nat) (f g : nat -> nat) : nat -> nat := - fun n => - if (n nat) : nat -> nat := - fun n => if (n0 * n1 <=? n) then n else - (f (n / n1) * n1 + g (n mod n1)). - -Definition swap_perm a b n := - fun k => if n <=? k then k else - if k =? a then b else - if k =? b then a else k. - - -(* TODO: Implement things for this *) -Fixpoint insertion_sort_list n f := - match n with - | 0 => [] - | S n' => let k := (perm_inv (S n') f n') in - k :: insertion_sort_list n' (Bits.fswap f k n') - end. - -Fixpoint swap_list_spec l : bool := - match l with - | [] => true - | k :: ks => (k idn - | k :: ks => let n := length ks in - (swap_perm k n (S n) ∘ (perm_of_swap_list ks))%prg - end. - -Fixpoint invperm_of_swap_list l := - match l with - | [] => idn - | k :: ks => let n := length ks in - ((invperm_of_swap_list ks) ∘ swap_perm k n (S n))%prg - end. - -Definition perm_inv' n f := - fun k => if n <=? k then k else perm_inv n f k. - -Definition contract_perm f a := - fun k => - if k nat := - swap_perm 0 1 2. - -Definition rotr n m : nat -> nat := - fun k => if n <=? k then k else (k + m) mod n. - -Definition rotl n m : nat -> nat := - fun k => if n <=? k then k else (k + (n - (m mod n))) mod n. - -Definition swap_block_perm padl padm a := - fun k => - if k - if n <=? k then k else n - S k. - -End PermutationDefinitions. - -(* Notation "f '=[' n ']' g" := (perm_eq_upto n f g) - (at level 70, no associativity): perm_scope. - -Notation "'perm_bdd' n f" := (forall k, (k < n%nat)%nat -> (f k < n%nat)%nat) - (at level 10, n at level 9, f at level 9) : perm_scope. *) diff --git a/src/Permutations/PermutationFacts.v b/src/Permutations/PermutationFacts.v deleted file mode 100644 index 0f2d820..0000000 --- a/src/Permutations/PermutationFacts.v +++ /dev/null @@ -1,1829 +0,0 @@ -Require Import StrongInduction. -Require Import List. -Require Import QuantumLib.Bits. -Require Export PermutationDefinitions. -Require Import PermutationAutomation. -Require (* Import *) PermutationAuxiliary. - - -Open Scope nat. -Open Scope prg. -Open Scope perm_scope. - -Lemma permutation_change_dims n m (H : n = m) f : - permutation n f <-> permutation m f. -Proof. - now subst. -Qed. - -Lemma permutation_eqb_iff {n f} a b : permutation n f -> - a < n -> b < n -> - f a =? f b = (a =? b). -Proof. - intros Hperm Hk Hfk. - bdestruct_one. - apply (permutation_is_injective n f Hperm) in H; [bdestruct_one| |]; lia. - bdestruct_one; subst; easy. -Qed. - -Lemma permutation_eq_iff {n f} a b : permutation n f -> - a < n -> b < n -> - f a = f b <-> a = b. -Proof. - intros Hperm Hk Hfk. - generalize (permutation_eqb_iff _ _ Hperm Hk Hfk). - bdestructΩ'. -Qed. - -(* TODO: Move somewhere else *) -Lemma perm_eq_iff_forall n (f g : nat -> nat) : - perm_eq n f g <-> forallb (fun k => f k =? g k) (seq 0 n) = true. -Proof. - rewrite PermutationAuxiliary.forallb_seq0. - now setoid_rewrite Nat.eqb_eq. -Qed. - -Lemma perm_eq_dec n (f g : nat -> nat) : - {perm_eq n f g} + {~ perm_eq n f g}. -Proof. - generalize (perm_eq_iff_forall n f g). - destruct (forallb (fun k => f k =? g k) (seq 0 n)); intros H; - [left | right]; rewrite H; easy. -Qed. - -Lemma not_forallb_seq_exists f start len : - forallb f (seq start len) = false -> - exists n, n < len /\ f (n + start) = false. -Proof. - revert start; induction len; [easy|]. - intros start. - simpl. - rewrite andb_false_iff. - intros [H | H]. - - exists 0. split; [lia | easy]. - - destruct (IHlen (S start) H) as (n & Hn & Hfn). - exists (S n); split; rewrite <- ?Hfn; f_equal; lia. -Qed. - -Lemma not_forallb_seq0_exists f n : - forallb f (seq 0 n) = false -> - exists k, k < n /\ f k = false. -Proof. - intros H. - apply not_forallb_seq_exists in H. - setoid_rewrite Nat.add_0_r in H. - exact H. -Qed. - -Lemma not_perm_eq_not_eq_at n (f g : nat -> nat) : - ~ (perm_eq n f g) -> exists k, k < n /\ f k <> g k. -Proof. - rewrite perm_eq_iff_forall. - rewrite not_true_iff_false. - intros H. - apply not_forallb_seq0_exists in H. - setoid_rewrite Nat.eqb_neq in H. - exact H. -Qed. - -(* Add Parametric Relation n : (nat -> nat) (fun f g => perm_eq n f g) - reflexivity proved by ltac:(easy) - symmetry proved by ltac:(intros; intros k Hk; symmetry; auto) - transitivity proved by ltac:(intros f g h Hfg Hgh k Hk; - transitivity (g k); auto) - as perm_eq_setoid. *) - -Lemma perm_bounded_of_eq {n f g} : - perm_eq n g f -> perm_bounded n f -> - perm_bounded n g. -Proof. - intros Hfg Hf k Hk. - rewrite Hfg; auto. -Qed. - - -(* Section on perm_inv *) -Lemma perm_inv'_eq n f : - perm_eq n (perm_inv' n f) (perm_inv n f). -Proof. - intros k Hk. - unfold perm_inv'. - bdestructΩ'. -Qed. - -#[export] Hint Extern 0 - (perm_eq ?n (perm_inv' ?n ?f) ?g) => - apply (perm_eq_trans (perm_inv'_eq n _)) : perm_inv_db. - -#[export] Hint Extern 0 - (perm_eq ?n ?g (perm_inv' ?n ?f)) => - apply (fun H => perm_eq_trans - H (perm_eq_sym (perm_inv'_eq n _))) : perm_inv_db. - -Lemma perm_inv'_bounded n f : - perm_bounded n (perm_inv' n f). -Proof. - apply (perm_bounded_of_eq (perm_inv'_eq n f)). - auto with perm_bounded_db. -Qed. - -Lemma perm_inv'_WF n f : - WF_Perm n (perm_inv' n f). -Proof. - intros k Hk; - unfold perm_inv'; - bdestructΩ'. -Qed. - -#[export] Hint Resolve perm_inv'_bounded : perm_bounded_db. -#[export] Hint Resolve perm_inv'_WF : WF_Perm_db. - -Lemma permutation_of_le_permutation_WF f m n : (m <= n)%nat -> permutation m f -> - WF_Perm m f -> permutation n f. -Proof. - intros Hmn [finv_m Hfinv_m] HWF. - exists (fun k => if m <=? k then k else finv_m k). - intros k Hk. - bdestruct (m <=? k). - - rewrite !HWF; bdestructΩ'. - - specialize (Hfinv_m _ H). - bdestructΩ'. -Qed. - - -#[export] Hint Rewrite @compose_idn_r @compose_idn_l : perm_cleanup_db. -#[global] Hint Resolve perm_inv'_bounded : perm_bounded_db. -#[export] Hint Resolve perm_inv_permutation : perm_db. - - -Lemma perm_inv_is_linv_of_permutation_compose (n : nat) (f : nat -> nat) : - permutation n f -> - perm_eq n (perm_inv n f ∘ f) idn. -Proof. - apply perm_inv_is_linv_of_permutation. -Qed. - -#[export] Hint Resolve - perm_inv_is_linv_of_permutation - perm_inv_is_linv_of_permutation_compose : perm_inv_db. - -Lemma perm_inv_is_rinv_of_permutation_compose (n : nat) (f : nat -> nat) : - permutation n f -> - perm_eq n (f ∘ perm_inv n f) idn. -Proof. - apply perm_inv_is_rinv_of_permutation. -Qed. - -#[export] Hint Resolve - perm_inv_is_rinv_of_permutation - perm_inv_is_rinv_of_permutation_compose : perm_inv_db. - -Lemma perm_eq_compose_proper n (f f' g g' : nat -> nat) : - perm_bounded n g -> perm_eq n f f' -> perm_eq n g g' -> - perm_eq n (f ∘ g) (f' ∘ g'). -Proof. - intros Hg Hf' Hg' k Hk. - unfold compose. - now rewrite Hf', Hg' by auto. -Qed. - -#[export] Hint Resolve perm_eq_compose_proper : perm_inv_db. - -Lemma perm_inv'_is_linv_of_permutation_compose (n : nat) (f : nat -> nat) : - permutation n f -> - perm_eq n (perm_inv' n f ∘ f) idn. -Proof. - intros Hf k Hk. - unfold compose. - rewrite perm_inv'_eq by auto with perm_db. - auto with perm_inv_db. -Qed. - -#[export] Hint Resolve perm_inv'_is_linv_of_permutation_compose : perm_inv_db. - -Lemma perm_inv'_is_rinv_of_permutation_compose (n : nat) (f : nat -> nat) : - permutation n f -> - perm_eq n (f ∘ perm_inv' n f) idn. -Proof. - intros Hf k Hk. - unfold compose. - rewrite perm_inv'_eq by auto with perm_db. - auto with perm_inv_db. -Qed. - -#[export] Hint Resolve perm_inv'_is_rinv_of_permutation_compose : perm_inv_db. - -Lemma idn_WF_Perm n : WF_Perm n idn. -Proof. easy. Qed. - -#[export] Hint Resolve idn_WF_Perm : WF_Perm_db. -#[export] Hint Resolve compose_WF_Perm : WF_Perm_db. - - -Lemma perm_inv'_linv_of_permutation_WF n f : - permutation n f -> WF_Perm n f -> - perm_inv' n f ∘ f = idn. -Proof. - intros. - eq_by_WF_perm_eq n. - cleanup_perm_inv. -Qed. - -Lemma perm_inv'_rinv_of_permutation_WF n f : - permutation n f -> WF_Perm n f -> - f ∘ perm_inv' n f = idn. -Proof. - intros. - eq_by_WF_perm_eq n. - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite perm_inv'_linv_of_permutation_WF - perm_inv'_rinv_of_permutation_WF - using (solve [auto with perm_db WF_Perm_db]) : perm_inv_db. - -Lemma perm_eq_linv_injective n f finv finv' : permutation n f -> - is_perm_linv n f finv -> is_perm_linv n f finv' -> - perm_eq n finv finv'. -Proof. - intros Hperm Hfinv Hfinv'. - perm_eq_by_inv_inj f n. -Qed. - -Lemma perm_inv_eq_inv n f finv : - (forall x : nat, x < n -> f x < n /\ finv x < n - /\ finv (f x) = x /\ f (finv x) = x) - -> perm_eq n (perm_inv n f) finv. -Proof. - intros Hfinv. - assert (Hperm: permutation n f) by (exists finv; easy). - perm_eq_by_inv_inj f n. - intros; now apply Hfinv. -Qed. - -Lemma perm_inv_is_inv n f : permutation n f -> - forall k : nat, k < n -> perm_inv n f k < n /\ f k < n - /\ f (perm_inv n f k) = k /\ perm_inv n f (f k) = k. -Proof. - intros Hperm k Hk. - repeat split. - - apply perm_inv_bounded, Hk. - - destruct Hperm as [? H]; apply H, Hk. - - rewrite perm_inv_is_rinv_of_permutation; easy. - - rewrite perm_inv_is_linv_of_permutation; easy. -Qed. - -Lemma perm_inv_perm_inv n f : permutation n f -> - perm_eq n (perm_inv n (perm_inv n f)) f. -Proof. - intros Hf. - perm_eq_by_inv_inj (perm_inv n f) n. -Qed. - -#[export] Hint Resolve perm_inv_perm_inv : perm_inv_db. - -Lemma perm_inv_eq_of_perm_eq' n m f g : perm_eq n f g -> m <= n -> - perm_eq n (perm_inv m f) (perm_inv m g). -Proof. - intros Heq Hm. - induction m; [trivial|]. - intros k Hk. - simpl. - rewrite Heq by lia. - rewrite IHm by lia. - easy. -Qed. - -Lemma perm_inv_eq_of_perm_eq n f g : perm_eq n f g -> - perm_eq n (perm_inv n f) (perm_inv n g). -Proof. - intros Heq. - apply perm_inv_eq_of_perm_eq'; easy. -Qed. - -#[export] Hint Resolve perm_inv_eq_of_perm_eq : perm_inv_db. - -Lemma perm_inv'_eq_of_perm_eq n f g : perm_eq n f g -> - perm_inv' n f = perm_inv' n g. -Proof. - intros Heq. - eq_by_WF_perm_eq n. - cleanup_perm_inv. -Qed. - -#[export] Hint Resolve perm_inv_eq_of_perm_eq' : perm_inv_db. - -#[export] Hint Extern 20 - (?f = ?g) => - eapply eq_of_WF_perm_eq; - auto with WF_Perm_db : perm_inv_db. - -Lemma perm_inv'_perm_inv n f : permutation n f -> - perm_eq n (perm_inv' n (perm_inv n f)) f. -Proof. - cleanup_perm_inv. -Qed. - -Lemma perm_inv_perm_inv' n f : permutation n f -> - perm_eq n (perm_inv n (perm_inv' n f)) f. -Proof. - intros Hf k Hk. - rewrite (perm_inv_eq_of_perm_eq _ _ _ (perm_inv'_eq _ _)) by easy. - cleanup_perm_inv. -Qed. - -Lemma perm_inv'_perm_inv_eq n f : - permutation n f -> WF_Perm n f -> - perm_inv' n (perm_inv n f) = f. -Proof. - cleanup_perm_inv. -Qed. - -Lemma perm_inv'_perm_inv' n f : permutation n f -> - perm_eq n (perm_inv' n (perm_inv' n f)) f. -Proof. - intros Hf. - rewrite (perm_inv'_eq_of_perm_eq _ _ _ (perm_inv'_eq n f)). - cleanup_perm_inv. -Qed. - -Lemma perm_inv'_perm_inv'_eq n f : - permutation n f -> WF_Perm n f -> - perm_inv' n (perm_inv' n f) = f. -Proof. - rewrite (perm_inv'_eq_of_perm_eq _ _ _ (perm_inv'_eq n f)). - cleanup_perm_inv. -Qed. - -#[export] Hint Resolve perm_inv'_perm_inv - perm_inv'_perm_inv' perm_inv_perm_inv' : perm_inv_db. -#[export] Hint Rewrite perm_inv'_perm_inv_eq - perm_inv'_perm_inv'_eq - using - solve [auto with perm_db WF_Perm_db] : perm_inv_db. - -Lemma permutation_compose' n f g : - permutation n f -> permutation n g -> - permutation n (fun x => f (g x)). -Proof. - apply permutation_compose. -Qed. - -#[export] Hint Resolve permutation_compose permutation_compose' : perm_db. - -#[export] Hint Rewrite perm_inv_is_linv_of_permutation - perm_inv_is_rinv_of_permutation : perm_inv_db. - -Lemma perm_inv_eq_iff {n g} (Hg : permutation n g) - {k m} (Hk : k < n) (Hm : m < n) : - perm_inv n g k = m <-> k = g m. -Proof. - split; - [intros <- | intros ->]; - rewrite ?(perm_inv_is_rinv_of_permutation _ g Hg), - ?(perm_inv_is_linv_of_permutation _ g Hg); - easy. -Qed. - -Lemma perm_inv_eqb_iff {n g} (Hg : permutation n g) - {k m} (Hk : k < n) (Hm : m < n) : - (perm_inv n g k =? m) = (k =? g m). -Proof. - apply Bool.eq_iff_eq_true; - rewrite 2!Nat.eqb_eq; - now apply perm_inv_eq_iff. -Qed. - -Lemma perm_inv_ge n g k : - n <= perm_inv n g k -> n <= k. -Proof. - intros H. - bdestruct (n <=? k); [lia|]. - specialize (perm_inv_bounded n g k); lia. -Qed. - -Lemma compose_perm_inv_l n f g h - (Hf : permutation n f) (Hg : perm_bounded n g) - (Hh : perm_bounded n h) : - perm_eq n (perm_inv n f ∘ g) h <-> - perm_eq n g (f ∘ h). -Proof. - split; unfold compose. - - intros H k Hk. - rewrite <- H; cleanup_perm_inv. - - intros H k Hk. - rewrite H; cleanup_perm_inv. -Qed. - -Lemma compose_perm_inv_r n f g h - (Hf : permutation n f) (Hg : perm_bounded n g) - (Hh : perm_bounded n h) : - perm_eq n (g ∘ perm_inv n f) h <-> - perm_eq n g (h ∘ f). -Proof. - split; unfold compose. - - intros H k Hk. - rewrite <- H; cleanup_perm_inv. - - intros H k Hk. - rewrite H; cleanup_perm_inv. -Qed. - -Lemma compose_perm_inv_l' n f g h - (Hf : permutation n f) (Hg : perm_bounded n g) - (Hh : perm_bounded n h) : - perm_eq n h (perm_inv n f ∘ g) <-> - perm_eq n (f ∘ h) g. -Proof. - split; intros H; - apply perm_eq_sym, - compose_perm_inv_l, perm_eq_sym; - assumption. -Qed. - -Lemma compose_perm_inv_r' n f g h - (Hf : permutation n f) (Hg : perm_bounded n g) - (Hh : perm_bounded n h) : - perm_eq n h (g ∘ perm_inv n f) <-> - perm_eq n (h ∘ f) g. -Proof. - split; intros H; - apply perm_eq_sym, - compose_perm_inv_r, perm_eq_sym; - assumption. -Qed. - -Lemma compose_perm_inv'_l n (f g h : nat -> nat) - (Hf : permutation n f) (HWFf : WF_Perm n f) : - perm_inv' n f ∘ g = h <-> g = f ∘ h. -Proof. - split; [intros <- | intros ->]; - rewrite <- compose_assoc; - cleanup_perm_inv. -Qed. - -Lemma compose_perm_inv'_r n (f g h : nat -> nat) - (Hf : permutation n f) (HWFf : WF_Perm n f) : - g ∘ perm_inv' n f = h <-> g = h ∘ f. -Proof. - split; [intros <- | intros ->]; - rewrite compose_assoc; - cleanup_perm_inv. -Qed. - -Lemma compose_perm_inv'_l' n (f g h : nat -> nat) - (Hf : permutation n f) (HWFf : WF_Perm n f) : - h = perm_inv' n f ∘ g <-> f ∘ h = g. -Proof. - split; [intros -> | intros <-]; - rewrite <- compose_assoc; - cleanup_perm_inv. -Qed. - -Lemma compose_perm_inv'_r' n (f g h : nat -> nat) - (Hf : permutation n f) (HWFf : WF_Perm n f) : - h = g ∘ perm_inv' n f <-> h ∘ f = g. -Proof. - split; [intros -> | intros <-]; - rewrite compose_assoc; - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite perm_inv_perm_inv : perm_inv_db. - -Lemma perm_inv_perm_eq_iff n f g - (Hf : permutation n f) (Hg : permutation n g) : - perm_eq n (perm_inv n g) f <-> perm_eq n g (perm_inv n f). -Proof. - rewrite <- (compose_idn_r (perm_inv n g)). - rewrite <- (compose_idn_l (perm_inv n f)). - rewrite compose_perm_inv_l, compose_perm_inv_r' by cleanup_perm. - split; apply perm_eq_sym. -Qed. - -Lemma perm_inv_compose {n f g} (Hf : permutation n f) (Hg : permutation n g) : - perm_eq n - (perm_inv n (f ∘ g)) - (perm_inv n g ∘ perm_inv n f). -Proof. - apply perm_eq_sym. - perm_eq_by_inv_inj (f ∘ g) n. - apply compose_perm_inv_l; auto with perm_db. - apply compose_perm_inv_l; auto with perm_db. -Qed. - -#[export] Hint Resolve perm_inv_compose : perm_inv_db. - -Lemma perm_inv'_compose {n f g} - (Hf : permutation n f) (Hg : permutation n g) : - perm_inv' n (f ∘ g) = - perm_inv' n g ∘ perm_inv' n f. -Proof. - eq_by_WF_perm_eq n. - apply (perm_eq_trans (perm_inv'_eq _ _)). - apply (perm_eq_trans (perm_inv_compose Hf Hg)). - apply perm_eq_compose_proper; - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite @perm_inv'_compose - using auto with perm_db : perm_inv_db. - - - -Lemma idn_inv n : - perm_eq n (perm_inv n idn) idn. -Proof. - perm_eq_by_inv_inj (fun k:nat => k) n. -Qed. - -#[export] Hint Resolve idn_inv : perm_inv_db. - -Lemma idn_inv' n : - perm_inv' n idn = idn. -Proof. - permutation_eq_by_WF_inv_inj (fun k:nat=>k) n. -Qed. - -#[export] Hint Rewrite idn_inv' : perm_inv_db. - - -Lemma swap_perm_same a n : - swap_perm a a n = idn. -Proof. - unfold swap_perm. - apply functional_extensionality; intros k. - bdestructΩ'. -Qed. - -Lemma swap_perm_comm a b n : - swap_perm a b n = swap_perm b a n. -Proof. - apply functional_extensionality; intros k. - unfold swap_perm. - bdestructΩ'. -Qed. - -Lemma swap_perm_WF a b n : - WF_Perm n (swap_perm a b n). -Proof. - intros k Hk. - unfold swap_perm. - bdestructΩ'. -Qed. - -Lemma swap_perm_bounded a b n : a < n -> b < n -> - perm_bounded n (swap_perm a b n). -Proof. - intros Ha Hb k Hk. - unfold swap_perm. - bdestructΩ'. -Qed. - -Lemma swap_perm_invol a b n : a < n -> b < n -> - (swap_perm a b n) ∘ (swap_perm a b n) = idn. -Proof. - intros Ha Hb. - unfold compose. - apply functional_extensionality; intros k. - unfold swap_perm. - bdestructΩ'. -Qed. - -#[export] Hint Rewrite swap_perm_same : perm_cleanup_db. -#[export] Hint Resolve swap_perm_WF : WF_Perm_db. -#[export] Hint Resolve swap_perm_bounded : perm_bounded_db. -#[export] Hint Rewrite swap_perm_invol : perm_inv_db. - -Lemma swap_perm_permutation a b n : a < n -> b < n -> - permutation n (swap_perm a b n). -Proof. - intros Ha Hb. - perm_by_inverse (swap_perm a b n). -Qed. - -Lemma swap_perm_S_permutation a n (Ha : S a < n) : - permutation n (swap_perm a (S a) n). -Proof. - apply swap_perm_permutation; lia. -Qed. - -#[export] Hint Resolve swap_perm_permutation : perm_db. -#[export] Hint Resolve swap_perm_S_permutation : perm_db. - - -Lemma swap_perm_inv a b n : a < n -> b < n -> - perm_eq n (perm_inv n (swap_perm a b n)) - (swap_perm a b n). -Proof. - intros Ha Hb. - perm_eq_by_inv_inj (swap_perm a b n) n. -Qed. - -#[export] Hint Resolve swap_perm_inv : perm_inv_db. - -Lemma swap_perm_inv' a b n : a < n -> b < n -> - perm_inv' n (swap_perm a b n) = - swap_perm a b n. -Proof. - intros. - eq_by_WF_perm_eq n; cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite swap_perm_inv' : perm_inv_db. - -Lemma compose_swap_perm a b c n : a < n -> b < n -> c < n -> - b <> c -> a <> c -> - (swap_perm a b n ∘ swap_perm b c n ∘ swap_perm a b n) = swap_perm a c n. -Proof. - intros Ha Hb Hc Hbc Hac. - eq_by_WF_perm_eq n. - unfold compose, swap_perm. - intros k Hk. - bdestructΩ'. -Qed. - -#[export] Hint Rewrite compose_swap_perm : perm_cleanup_db. - - - - - -(* Section on insertion_sort_list *) - -Lemma fswap_eq_compose_swap_perm {A} (f : nat -> A) n m o : n < o -> m < o -> - fswap f n m = f ∘ swap_perm n m o. -Proof. - intros Hn Hm. - apply functional_extensionality; intros k. - unfold compose, fswap, swap_perm. - bdestruct_all; easy. -Qed. - -Lemma fswap_perm_invol_n_permutation f n : permutation (S n) f -> - permutation n (fswap f (perm_inv (S n) f n) n). -Proof. - intros Hperm. - apply fswap_at_boundary_permutation. - - apply Hperm. - - apply perm_inv_bounded_S. - - apply perm_inv_is_rinv_of_permutation; auto. -Qed. - - -Lemma perm_of_swap_list_WF l : swap_list_spec l = true -> - WF_Perm (length l) (perm_of_swap_list l). -Proof. - induction l. - - easy. - - simpl. - rewrite andb_true_iff. - intros [Ha Hl]. - intros k Hk. - unfold compose. - rewrite IHl; [|easy|lia]. - rewrite swap_perm_WF; easy. -Qed. - -Lemma invperm_of_swap_list_WF l : swap_list_spec l = true -> - WF_Perm (length l) (invperm_of_swap_list l). -Proof. - induction l. - - easy. - - simpl. - rewrite andb_true_iff. - intros [Ha Hl]. - intros k Hk. - unfold compose. - rewrite swap_perm_WF; [|easy]. - rewrite IHl; [easy|easy|lia]. -Qed. - -#[export] Hint Resolve perm_of_swap_list_WF invperm_of_swap_list_WF : WF_Perm_db. - -Lemma perm_of_swap_list_bounded l : swap_list_spec l = true -> - perm_bounded (length l) (perm_of_swap_list l). -Proof. - induction l; [easy|]. - simpl. - rewrite andb_true_iff. - intros [Ha Hl]. - intros k Hk. - unfold compose. - rewrite Nat.ltb_lt in Ha. - apply swap_perm_bounded; try lia. - bdestruct (k =? length l). - - subst; rewrite perm_of_swap_list_WF; try easy; lia. - - transitivity (length l); [|lia]. - apply IHl; [easy | lia]. -Qed. - -Lemma invperm_of_swap_list_bounded l : swap_list_spec l = true -> - perm_bounded (length l) (invperm_of_swap_list l). -Proof. - induction l; [easy|]. - simpl. - rewrite andb_true_iff. - intros [Ha Hl]. - rewrite Nat.ltb_lt in Ha. - intros k Hk. - unfold compose. - bdestruct (swap_perm a (length l) (S (length l)) k =? length l). - - rewrite H, invperm_of_swap_list_WF; [lia|easy|easy]. - - transitivity (length l); [|lia]. - apply IHl; [easy|]. - pose proof (swap_perm_bounded a (length l) (S (length l)) Ha (ltac:(lia)) k Hk). - lia. -Qed. - -#[export] Hint Resolve perm_of_swap_list_bounded - invperm_of_swap_list_bounded : perm_bounded_db. - - -Lemma invperm_linv_perm_of_swap_list l : swap_list_spec l = true -> - invperm_of_swap_list l ∘ perm_of_swap_list l = idn. -Proof. - induction l. - - easy. - - simpl. - rewrite andb_true_iff. - intros [Ha Hl]. - rewrite Combinators.compose_assoc, - <- (Combinators.compose_assoc _ _ _ _ (perm_of_swap_list _)). - rewrite swap_perm_invol, compose_idn_l. - + apply (IHl Hl). - + bdestructΩ (a - perm_of_swap_list l ∘ invperm_of_swap_list l = idn. -Proof. - induction l. - - easy. - - simpl. - rewrite andb_true_iff. - intros [Ha Hl]. - rewrite <- Combinators.compose_assoc, - (Combinators.compose_assoc _ _ _ _ (invperm_of_swap_list _)). - rewrite (IHl Hl). - rewrite compose_idn_r. - rewrite swap_perm_invol; [easy| |lia]. - bdestructΩ (a [] - | S n' => let k := (perm_inv (S n') f n') in - k :: insertion_sort_list n' (fswap f k n') - end. *) - -Lemma length_insertion_sort_list n f : - length (insertion_sort_list n f) = n. -Proof. - revert f; - induction n; - intros f. - - easy. - - simpl. - rewrite IHn; easy. -Qed. - -Local Opaque perm_inv. -Lemma insertion_sort_list_is_swap_list n f : - swap_list_spec (insertion_sort_list n f) = true. -Proof. - revert f; - induction n; - intros f. - - easy. - - simpl. - rewrite length_insertion_sort_list, IHn. - pose proof (perm_inv_bounded_S n f n). - bdestructΩ (perm_inv (S n) f n - perm_eq n (invperm_of_swap_list (insertion_sort_list n f) - ∘ perm_of_swap_list (insertion_sort_list n f)) idn. -Proof. - cleanup_perm_inv. -Qed. - -Lemma invperm_rinv_perm_of_insertion_sort_list n f : permutation n f -> - perm_eq n (perm_of_swap_list (insertion_sort_list n f) - ∘ invperm_of_swap_list (insertion_sort_list n f)) idn. -Proof. - cleanup_perm_inv. -Qed. - -#[export] Hint Resolve invperm_linv_perm_of_insertion_sort_list - invperm_rinv_perm_of_insertion_sort_list : perm_inv_db. - - -Lemma perm_of_insertion_sort_list_is_rinv n f : permutation n f -> - perm_eq n (f ∘ perm_of_swap_list (insertion_sort_list n f)) idn. -Proof. - revert f; - induction n; - intros f. - - intros; exfalso; easy. - - intros Hperm k Hk. - simpl. - rewrite length_insertion_sort_list. - bdestruct (k =? n). - + unfold compose. - rewrite perm_of_swap_list_WF; [ | - apply insertion_sort_list_is_swap_list | - rewrite length_insertion_sort_list; lia - ]. - unfold swap_perm. - bdestructΩ (S n <=? k). - bdestructΩ (k =? n). - subst. - bdestruct (n =? perm_inv (S n) f n). - 1: rewrite H at 1. - all: cleanup_perm_inv. - + rewrite <- Combinators.compose_assoc. - rewrite <- fswap_eq_compose_swap_perm; [|apply perm_inv_bounded_S|lia]. - rewrite IHn; [easy| |lia]. - apply fswap_perm_invol_n_permutation, Hperm. -Qed. -Local Transparent perm_inv. - -#[export] Hint Resolve perm_of_insertion_sort_list_is_rinv : perm_inv_db. -#[export] Hint Rewrite perm_of_insertion_sort_list_is_rinv : perm_inv_db. - -Lemma perm_of_insertion_sort_list_WF n f : - WF_Perm n (perm_of_swap_list (insertion_sort_list n f)). -Proof. - intros k. - rewrite <- (length_insertion_sort_list n f) at 1. - revert k. - apply perm_of_swap_list_WF. - apply insertion_sort_list_is_swap_list. -Qed. - -Lemma invperm_of_insertion_sort_list_WF n f : - WF_Perm n (invperm_of_swap_list (insertion_sort_list n f)). -Proof. - intros k. - rewrite <- (length_insertion_sort_list n f) at 1. - revert k. - apply invperm_of_swap_list_WF. - apply insertion_sort_list_is_swap_list. -Qed. - -#[export] Hint Resolve perm_of_insertion_sort_list_WF - invperm_of_swap_list_WF : WF_Perm_db. - - -Lemma perm_of_insertion_sort_list_perm_eq_perm_inv n f : permutation n f -> - perm_eq n (perm_of_swap_list (insertion_sort_list n f)) (perm_inv n f). -Proof. - intros Hperm. - apply (perm_bounded_rinv_injective_of_injective n f). - - apply permutation_is_injective, Hperm. - - pose proof (perm_of_swap_list_bounded (insertion_sort_list n f) - (insertion_sort_list_is_swap_list n f)) as H. - rewrite (length_insertion_sort_list n f) in H. - exact H. - - auto with perm_bounded_db. - - apply perm_of_insertion_sort_list_is_rinv, Hperm. - - apply perm_inv_is_rinv_of_permutation, Hperm. -Qed. - -#[export] Hint Resolve - perm_of_insertion_sort_list_perm_eq_perm_inv : perm_inv_db. - -Lemma perm_of_insertion_sort_list_eq_perm_inv' n f : permutation n f -> - perm_of_swap_list (insertion_sort_list n f) = - perm_inv' n f. -Proof. - intros Hf. - eq_by_WF_perm_eq n. - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite - perm_of_insertion_sort_list_eq_perm_inv' - using auto with perm_db : perm_inv_db. - - -Lemma perm_inv_of_insertion_sort_list_perm_eq n f : permutation n f -> - perm_eq n (perm_inv n (perm_of_swap_list (insertion_sort_list n f))) f. -Proof. - intros Hf. - cleanup_perm_inv. -Qed. - -#[export] Hint Resolve perm_inv_of_insertion_sort_list_perm_eq : perm_inv_db. - -Lemma perm_inv'_of_insertion_sort_list_eq n f : - permutation n f -> WF_Perm n f -> - perm_inv' n (perm_of_swap_list (insertion_sort_list n f)) = f. -Proof. - intros. - eq_by_WF_perm_eq n. - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite perm_inv'_of_insertion_sort_list_eq - using solve [auto with perm_db WF_Perm_db] : perm_inv_db. - -#[export] Hint Extern 100 (perm_eq ?n ?f ?g) => - (apply (@perm_eq_sym n g f)) : perm_inv_db. - -Lemma perm_eq_perm_of_insertion_sort_list_of_perm_inv n f : permutation n f -> - perm_eq n f (perm_of_swap_list (insertion_sort_list n (perm_inv n f))). -Proof. - intros Hf. - cleanup_perm_inv. -Qed. - -Lemma insertion_sort_list_S n f : - insertion_sort_list (S n) f = - (perm_inv (S n) f n) :: (insertion_sort_list n (fswap f (perm_inv (S n) f n) n)). -Proof. easy. Qed. - -Lemma perm_of_swap_list_cons a l : - perm_of_swap_list (a :: l) = swap_perm a (length l) (S (length l)) ∘ perm_of_swap_list l. -Proof. easy. Qed. - -Lemma invperm_of_swap_list_cons a l : - invperm_of_swap_list (a :: l) = invperm_of_swap_list l ∘ swap_perm a (length l) (S (length l)). -Proof. easy. Qed. - -Lemma perm_of_insertion_sort_list_S n f : - perm_of_swap_list (insertion_sort_list (S n) f) = - swap_perm (perm_inv (S n) f n) n (S n) ∘ - perm_of_swap_list (insertion_sort_list n (fswap f (perm_inv (S n) f n) n)). -Proof. - rewrite insertion_sort_list_S, perm_of_swap_list_cons. - rewrite length_insertion_sort_list. - easy. -Qed. - -Lemma invperm_of_insertion_sort_list_S n f : - invperm_of_swap_list (insertion_sort_list (S n) f) = - invperm_of_swap_list (insertion_sort_list n (fswap f (perm_inv (S n) f n) n)) - ∘ swap_perm (perm_inv (S n) f n) n (S n). -Proof. - rewrite insertion_sort_list_S, invperm_of_swap_list_cons. - rewrite length_insertion_sort_list. - easy. -Qed. - -Lemma perm_of_swap_list_permutation l : swap_list_spec l = true -> - permutation (length l) (perm_of_swap_list l). -Proof. - intros Hsw. - induction l; - [ simpl; exists idn; easy |]. - simpl. - apply permutation_compose. - - apply swap_perm_permutation; [|lia]. - simpl in Hsw. - bdestruct (a - permutation (length l) (invperm_of_swap_list l). -Proof. - intros Hsw. - induction l; - [ simpl; exists idn; easy |]. - simpl. - apply permutation_compose. - - eapply permutation_of_le_permutation_WF. - 2: apply IHl. - 1: lia. - 2: apply invperm_of_swap_list_WF. - all: simpl in Hsw; - rewrite andb_true_iff in Hsw; easy. - - apply swap_perm_permutation; [|lia]. - simpl in Hsw. - bdestruct (a - perm_eq n f (invperm_of_swap_list (insertion_sort_list n f)). -Proof. - intros Hperm. - perm_eq_by_inv_inj (perm_of_swap_list (insertion_sort_list n f)) n. -Qed. - - -Lemma permutation_grow_l' n f : permutation (S n) f -> - perm_eq (S n) f (swap_perm (f n) n (S n) ∘ - perm_of_swap_list (insertion_sort_list n (fswap (perm_inv (S n) f) (f n) n))). -Proof. - intros Hperm k Hk. - rewrite (perm_eq_perm_of_insertion_sort_list_of_perm_inv _ _ Hperm) - at 1 by auto. - cbn -[perm_inv]. - rewrite length_insertion_sort_list, perm_inv_perm_inv by auto. - easy. -Qed. - -Lemma permutation_grow_r' n f : permutation (S n) f -> - perm_eq (S n) f ( - invperm_of_swap_list (insertion_sort_list n (fswap f (perm_inv (S n) f n) n)) - ∘ swap_perm (perm_inv (S n) f n) n (S n)). -Proof. - intros Hperm k Hk. - rewrite (perm_eq_invperm_of_insertion_sort_list _ _ Hperm) at 1 by auto. - cbn -[perm_inv]. - rewrite length_insertion_sort_list by auto. - easy. -Qed. - -Lemma permutation_grow_l n f : permutation (S n) f -> - exists g k, k < S n /\ perm_eq (S n) f (swap_perm k n (S n) ∘ g) /\ permutation n g. -Proof. - intros Hperm. - eexists. - exists (f n). - split; [apply permutation_is_bounded; [easy | lia] | split]. - pose proof (perm_eq_perm_of_insertion_sort_list_of_perm_inv _ _ Hperm) as H. - rewrite perm_of_insertion_sort_list_S in H. - rewrite perm_inv_perm_inv in H by (easy || lia). - exact H. - auto with perm_db. -Qed. - -Lemma permutation_grow_r n f : permutation (S n) f -> - exists g k, k < S n /\ perm_eq (S n) f (g ∘ swap_perm k n (S n)) /\ permutation n g. -Proof. - intros Hperm. - eexists. - exists (perm_inv (S n) f n). - split; [apply permutation_is_bounded; [auto with perm_db | lia] | split]. - pose proof (perm_eq_invperm_of_insertion_sort_list _ _ Hperm) as H. - rewrite invperm_of_insertion_sort_list_S in H. - exact H. - auto with perm_db. -Qed. - - - -Local Transparent perm_inv. - - -(* Section on stack_perms *) -Lemma stack_perms_left {n0 n1} {f g} {k} : - k < n0 -> stack_perms n0 n1 f g k = f k. -Proof. - intros Hk. - unfold stack_perms. - replace_bool_lia (k stack_perms n0 n1 f g k = g (k - n0) + n0. -Proof. - intros Hk. - unfold stack_perms. - replace_bool_lia (k stack_perms n0 n1 f g (k + n0) = g k + n0. -Proof. - intros Hk. - rewrite stack_perms_right; [|lia]. - replace (k + n0 - n0) with k by lia. - easy. -Qed. - -Lemma stack_perms_add_right {n0 n1} {f g} {k} : - k < n1 -> stack_perms n0 n1 f g (n0 + k) = g k + n0. -Proof. - rewrite Nat.add_comm. - exact stack_perms_right_add. -Qed. - -Lemma stack_perms_high {n0 n1} {f g} {k} : - n0 + n1 <= k -> (stack_perms n0 n1 f g) k = k. -Proof. - intros H. - unfold stack_perms. - replace_bool_lia (k if k if (¬ k f k = k) (Hg : forall k, k < n1 -> g k = k) : - stack_perms n0 n1 f g = idn. -Proof. - solve_modular_permutation_equalities. - - apply Hf; easy. - - rewrite Hg; lia. -Qed. - -#[export] Hint Resolve stack_perms_idn_of_left_right_idn - stack_perms_compose : perm_inv_db. - - - -Lemma contract_perm_bounded {n f} (Hf : perm_bounded n f) a : - a < n -> - perm_bounded (n - 1) (contract_perm f a). -Proof. - intros Ha k Hk. - pose proof (Hf a Ha). - pose proof (Hf k ltac:(lia)). - pose proof (Hf (k+1) ltac:(lia)). - unfold contract_perm. - bdestructΩ'. -Qed. - -#[export] Hint Resolve contract_perm_bounded : perm_bounded_db. - -Lemma contract_perm_permutation {n f} (Hf : permutation n f) a : - a < n -> - permutation (n - 1) (contract_perm f a). -Proof. - intros Ha. - pose proof (fun x y => permutation_eq_iff x y Hf) as Hfinj. - destruct Hf as (finv & Hfinv). - pose proof (fun k Hk => proj1 (Hfinv k Hk)) as Hfbdd. - pose proof (fun k Hk => proj1 (proj2 (Hfinv k Hk))) as Hfinvbdd. - pose proof (fun k Hk => proj1 (proj2 (proj2(Hfinv k Hk)))) as Hlinv. - pose proof (fun k Hk => proj2 (proj2 (proj2(Hfinv k Hk)))) as Hrinv. - exists (contract_perm finv (f a)). - intros k Hk. - repeat split; auto with perm_bounded_db. - - unfold contract_perm. - rewrite !(if_dist _ _ _ finv). - rewrite !Hlinv by lia. - rewrite !(if_dist _ _ _ (fun x=>x+1)). - rewrite !(if_dist _ _ _ finv). - pose proof (Hfinj a k). - pose proof (Hfinj a (k + 1)). - bdestructΩ'; rewrite ?Nat.sub_add, ?Hlinv in *; lia. - - unfold contract_perm. - rewrite !(if_dist _ _ _ f). - rewrite !Hrinv, !Hlinv by lia. - rewrite !(if_dist _ _ _ (fun x=>x+1)). - rewrite !(if_dist _ _ _ f). - assert (Hfeqiff : forall a b, a < n -> b < n -> - f a = b <-> finv b = a) by - (intros; split; intros <-; now rewrite ?Hlinv, ?Hrinv by lia). - pose proof (Hfeqiff a k). - pose proof (Hfeqiff a (k+1)). - bdestructΩ'; rewrite ?Nat.sub_add, ?Hrinv in * by lia; lia. -Qed. - -#[export] Hint Resolve contract_perm_permutation : perm_db. - -Lemma contract_perm_WF n f a : WF_Perm n f -> a < n -> f a < n -> - WF_Perm (n - 1) (contract_perm f a). -Proof. - intros Hf Ha Hfa. - intros k Hk. - unfold contract_perm. - bdestruct (a =? f a); [ - replace <- (f a) in *; - bdestructΩ'; - rewrite ?Hf in * by lia; try lia| - ]. - bdestructΩ'; - rewrite ?Hf in * by lia; lia. -Qed. - -#[export] Hint Extern 0 (WF_Perm _ (contract_perm _ _)) => - apply contract_perm_WF; - [| auto using permutation_is_bounded - with perm_bounded_db..] : WF_Perm_db. - -Lemma contract_perm_inv n f (Hf : permutation n f) a : - a < n -> - forall k, k < n - 1 -> - perm_inv (n - 1) (contract_perm f a) k = - contract_perm (perm_inv n f) (f a) k. -Proof. - intros Ha k Hk. - pose proof (permutation_is_bounded _ _ Hf) as Hfbdd. - pose proof (perm_inv_bounded n f) as Hfinvbdd. - pose proof (Hfbdd a Ha). - pose proof (perm_inv_is_linv_of_permutation n f Hf) as Hlinv. - pose proof (perm_inv_is_rinv_of_permutation n f Hf) as Hrinv. - rewrite perm_inv_eq_iff; auto with perm_db perm_bounded_db. - unfold contract_perm. - rewrite !(if_dist _ _ _ f). - rewrite !Hrinv, !Hlinv by lia. - rewrite !(if_dist _ _ _ (fun x=>x+1)). - rewrite !(if_dist _ _ _ f). - assert (Hfeqiff : forall a b, a < n -> b < n -> - f a = b <-> perm_inv n f b = a) by - (intros; split; intros <-; now rewrite ?Hlinv, ?Hrinv by lia). - pose proof (Hfeqiff a k). - pose proof (Hfeqiff a (k+1)). - bdestructΩ'; rewrite ?Nat.sub_add, ?Hrinv in * by lia; lia. -Qed. - -#[export] Hint Resolve contract_perm_inv : perm_inv_db. - -Lemma contract_perm_perm_eq_of_perm_eq n f g a : - a < n -> perm_eq n f g -> - perm_eq (n - 1) (contract_perm f a) (contract_perm g a). -Proof. - intros Ha Hfg. - intros k Hk. - unfold contract_perm. - now rewrite !Hfg by lia. -Qed. - -#[export] Hint Resolve contract_perm_perm_eq_of_perm_eq : perm_inv_db. - -Lemma contract_perm_inv' {n f} (Hf : permutation n f) a : - WF_Perm n f -> - a < n -> - perm_inv' (n - 1) (contract_perm f a) = - contract_perm (perm_inv' n f) (f a). -Proof. - intros Hfwf Ha. - eq_by_WF_perm_eq (n-1). - auto with perm_inv_db. - apply (perm_eq_trans - (perm_inv'_eq _ _)). - apply (perm_eq_trans - (contract_perm_inv n f Hf a Ha)). - eauto with perm_db perm_inv_db. -Qed. - -#[export] Hint Rewrite @contract_perm_inv' - using (match goal with - | |- WF_Perm _ _ => solve [auto with WF_Perm_db perm_db perm_inv_db] - | |- _ => auto with perm_db - end) : perm_inv_db. - -(* Section on rotr / rotl *) -Lemma rotr_WF {n m} : - WF_Perm n (rotr n m). -Proof. intros k Hk. unfold rotr. bdestruct_one; lia. Qed. - -Lemma rotl_WF {n m} : - WF_Perm n (rotl n m). -Proof. intros k Hk. unfold rotl. bdestruct_one; lia. Qed. - -#[export] Hint Resolve rotr_WF rotl_WF : WF_Perm_db. - -Lemma rotr_bdd {n m} : - forall k, k < n -> (rotr n m) k < n. -Proof. - intros. unfold rotr. bdestruct_one; [lia|]. - apply Nat.mod_upper_bound; lia. -Qed. - -Lemma rotl_bdd {n m} : - forall k, k < n -> (rotl n m) k < n. -Proof. - intros. unfold rotl. bdestruct_one; [lia|]. - apply Nat.mod_upper_bound; lia. -Qed. - -#[export] Hint Resolve rotr_bdd rotl_bdd : perm_bounded_db. - -Lemma rotr_rotl_inv n m : - ((rotr n m) ∘ (rotl n m) = idn)%prg. -Proof. - apply functional_extensionality; intros k. - unfold compose, rotl, rotr. - bdestruct (n <=? k); [bdestructΩ'|]. - assert (Hn0 : n <> 0) by lia. - bdestruct_one. - - pose proof (Nat.mod_upper_bound (k + (n - m mod n)) n Hn0) as Hbad. - lia. (* contradict Hbad *) - - rewrite Nat.Div0.add_mod_idemp_l. - rewrite <- Nat.add_assoc. - replace (n - m mod n + m) with - (n - m mod n + (n * (m / n) + m mod n)) by - (rewrite <- (Nat.div_mod m n Hn0); easy). - pose proof (Nat.mod_upper_bound m n Hn0). - replace (n - m mod n + (n * (m / n) + m mod n)) with - (n * (1 + m / n)) by lia. - rewrite Nat.mul_comm, Nat.Div0.mod_add. - apply Nat.mod_small, H. -Qed. - -Lemma rotl_rotr_inv n m : - ((rotl n m) ∘ (rotr n m) = idn)%prg. -Proof. - apply functional_extensionality; intros k. - unfold compose, rotl, rotr. - bdestruct (n <=? k); [bdestructΩ'|]. - assert (Hn0 : n <> 0) by lia. - bdestruct_one. - - pose proof (Nat.mod_upper_bound (k + m) n Hn0) as Hbad. - lia. (* contradict Hbad *) - - rewrite Nat.Div0.add_mod_idemp_l. - rewrite <- Nat.add_assoc. - rewrite (Nat.div_mod_eq m n) at 1. - pose proof (Nat.mod_upper_bound m n Hn0). - replace ((n * (m / n) + m mod n) + (n - m mod n)) with - (n * (1 + m / n)) by lia. - rewrite Nat.mul_comm, Nat.Div0.mod_add. - apply Nat.mod_small, H. -Qed. - -#[export] Hint Rewrite rotr_rotl_inv rotl_rotr_inv : perm_inv_db. - -Lemma rotr_perm {n m} : permutation n (rotr n m). -Proof. - perm_by_inverse (rotl n m). -Qed. - -Lemma rotl_perm {n m} : permutation n (rotl n m). -Proof. - perm_by_inverse (rotr n m). -Qed. - -#[export] Hint Resolve rotr_perm rotl_perm : perm_db. - - -(* This is the start of the actual section *) -Lemma rotr_0_r n : rotr n 0 = idn. -Proof. - apply functional_extensionality; intros k. - unfold rotr. - bdestructΩ'. - rewrite Nat.mod_small; lia. -Qed. - -Lemma rotl_0_r n : rotl n 0 = idn. -Proof. - apply functional_extensionality; intros k. - unfold rotl. - bdestructΩ'. - rewrite Nat.Div0.mod_0_l, Nat.sub_0_r. - replace (k + n) with (k + 1 * n) by lia. - rewrite Nat.Div0.mod_add, Nat.mod_small; lia. -Qed. - -Lemma rotr_0_l k : rotr 0 k = idn. -Proof. - apply functional_extensionality; intros a. - unfold rotr. - bdestructΩ'. -Qed. - -Lemma rotl_0_l k : rotl 0 k = idn. -Proof. - apply functional_extensionality; intros a. - unfold rotl. - bdestructΩ'. -Qed. - -#[export] Hint Rewrite rotr_0_r rotl_0_r rotr_0_l rotl_0_l : perm_cleanup_db. - -Lemma rotr_rotr n k l : - ((rotr n k) ∘ (rotr n l) = rotr n (k + l))%prg. -Proof. - apply functional_extensionality; intros a. - unfold compose, rotr. - symmetry. - bdestructΩ'. - - pose proof (Nat.mod_upper_bound (a + l) n); lia. - - rewrite Nat.Div0.add_mod_idemp_l. - f_equal; lia. -Qed. - -Lemma rotl_rotl n k l : - ((rotl n k) ∘ (rotl n l) = rotl n (k + l))%prg. -Proof. - - permutation_eq_by_WF_inv_inj (rotr n (k + l)) n. - rewrite Nat.add_comm, <- rotr_rotr, <- compose_assoc, - (compose_assoc _ _ _ _ (rotr n l)). - cleanup_perm. -Qed. - -#[export] Hint Rewrite rotr_rotr rotl_rotl : perm_cleanup_db. - -Lemma rotr_n n : rotr n n = idn. -Proof. - apply functional_extensionality; intros a. - unfold rotr. - bdestructΩ'. - replace (a + n) with (a + 1 * n) by lia. - destruct n; [lia|]. - rewrite Nat.Div0.mod_add. - rewrite Nat.mod_small; easy. -Qed. - -#[export] Hint Rewrite rotr_n : perm_cleanup_db. - -Lemma rotr_eq_rotr_mod n k : rotr n k = rotr n (k mod n). -Proof. - strong induction k. - bdestruct (k 0) by easy. - pose proof (Nat.mod_upper_bound k _ H'). - rewrite <- (rotl_n (S n)). - f_equal. - lia. -Qed. - -Lemma rotl_eq_rotr_sub n k : - rotl n k = rotr n (n - k mod n). -Proof. - permutation_eq_by_WF_inv_inj (rotr n k) n. - destruct n; [cbn; rewrite 2!rotr_0_l, compose_idn_l; easy|]. - rewrite (rotr_eq_rotr_mod _ k), rotr_rotr, <- (rotr_n (S n)). - f_equal. - assert (H' : S n <> 0) by easy. - pose proof (Nat.mod_upper_bound k (S n) H'). - lia. -Qed. - -Lemma rotr_add_n_l n k : - rotr n (n + k) = rotr n k. -Proof. - rewrite rotr_eq_rotr_mod. - rewrite Nat.add_comm, mod_add_n_r. - now rewrite <- rotr_eq_rotr_mod. -Qed. - -Lemma rotr_add_n_r n k : - rotr n (k + n) = rotr n k. -Proof. - rewrite rotr_eq_rotr_mod. - rewrite mod_add_n_r. - now rewrite <- rotr_eq_rotr_mod. -Qed. - -#[export] Hint Rewrite rotr_add_n_r rotr_add_n_l : perm_cleanup_db. - - - -Lemma reflect_perm_invol n k : - reflect_perm n (reflect_perm n k) = k. -Proof. - unfold reflect_perm; bdestructΩ'. -Qed. - -Lemma reflect_perm_invol_eq n : - reflect_perm n ∘ reflect_perm n = idn. -Proof. - apply functional_extensionality, reflect_perm_invol. -Qed. - -#[export] Hint Rewrite reflect_perm_invol reflect_perm_invol_eq : perm_inv_db. - -Lemma reflect_perm_bounded n : perm_bounded n (reflect_perm n). -Proof. - intros k Hk. - unfold reflect_perm; bdestructΩ'. -Qed. - -#[export] Hint Resolve reflect_perm_bounded : perm_bounded_db. - -Lemma reflect_perm_permutation n : - permutation n (reflect_perm n). -Proof. - perm_by_inverse (reflect_perm n). -Qed. - -#[export] Hint Resolve reflect_perm_permutation : perm_db. - -Lemma reflect_perm_WF n : WF_Perm n (reflect_perm n). -Proof. - intros k Hk; unfold reflect_perm; bdestructΩ'. -Qed. - -#[export] Hint Resolve reflect_perm_WF : WF_Perm_db. - -Lemma reflect_perm_inv n : - perm_eq n (perm_inv n (reflect_perm n)) (reflect_perm n). -Proof. - perm_eq_by_inv_inj (reflect_perm n) n. -Qed. - -#[export] Hint Resolve reflect_perm_inv : perm_inv_db. -#[export] Hint Rewrite reflect_perm_inv : perm_inv_db. - -Lemma reflect_perm_inv' n : - perm_inv' n (reflect_perm n) = reflect_perm n. -Proof. - eq_by_WF_perm_eq n. - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite reflect_perm_inv : perm_inv_db. - - - -Lemma swap_block_perm_sub padl padm m a k : - m <= k -> - swap_block_perm padl padm a (k - m) = - swap_block_perm (m + padl) padm a k - m. -Proof. - intros Hk. - unfold swap_block_perm. - bdestructΩ'. -Qed. - -Lemma swap_block_perm_invol padl padm a k : - swap_block_perm padl padm a (swap_block_perm padl padm a k) = k. -Proof. - unfold swap_block_perm. - bdestructΩ'. -Qed. - -Lemma swap_block_perm_invol_eq padl padm a : - swap_block_perm padl padm a ∘ swap_block_perm padl padm a = idn. -Proof. - apply functional_extensionality, swap_block_perm_invol. -Qed. - -#[export] Hint Rewrite swap_block_perm_invol - swap_block_perm_invol_eq : perm_inv_db. - -Lemma swap_block_perm_bounded padl padm padr a : - perm_bounded (padl + a + padm + a + padr) (swap_block_perm padl padm a). -Proof. - intros k Hk. - unfold swap_block_perm. - bdestructΩ'. -Qed. - -Lemma swap_block_perm_bounded_alt padl padm padr a : - perm_bounded (padr + a + padm + a + padl) (swap_block_perm padl padm a). -Proof. - replace (padr + a + padm + a + padl) - with (padl + a + padm + a + padr) by lia. - apply swap_block_perm_bounded. -Qed. - -#[export] Hint Resolve swap_block_perm_bounded - swap_block_perm_bounded_alt : perm_bounded_db. - -Lemma swap_block_perm_permutation padl padm padr a : - permutation (padl + a + padm + a + padr) (swap_block_perm padl padm a). -Proof. - perm_by_inverse (swap_block_perm padl padm a). -Qed. - -Lemma swap_block_perm_permutation_alt padl padm padr a : - permutation (padr + a + padm + a + padl) (swap_block_perm padl padm a). -Proof. - perm_by_inverse (swap_block_perm padl padm a). -Qed. - -#[export] Hint Resolve swap_block_perm_permutation - swap_block_perm_permutation_alt : perm_db. - -Lemma swap_block_perm_WF padl padm padr a : - WF_Perm (padl + a + padm + a + padr) (swap_block_perm padl padm a). -Proof. - unfold swap_block_perm. - intros k Hk; bdestructΩ'. -Qed. - -Lemma swap_block_perm_WF_alt padl padm padr a : - WF_Perm (padl + a + padm + a + padr) (swap_block_perm padr padm a). -Proof. - unfold swap_block_perm. - intros k Hk; bdestructΩ'. -Qed. - -#[export] Hint Resolve swap_block_perm_WF - swap_block_perm_WF_alt : WF_Perm_db. - -Lemma swap_block_perm_inv padl padm padr a : - perm_eq (padl + a + padm + a + padr) - (perm_inv (padl + a + padm + a + padr) - (swap_block_perm padl padm a)) - (swap_block_perm padl padm a). -Proof. - perm_eq_by_inv_inj (swap_block_perm padl padm a) - (padl + a + padm + a + padr). -Qed. - -Lemma swap_block_perm_inv_alt padl padm padr a : - perm_eq (padl + a + padm + a + padr) - (perm_inv (padl + a + padm + a + padr) - (swap_block_perm padr padm a)) - (swap_block_perm padr padm a). -Proof. - perm_eq_by_inv_inj (swap_block_perm padr padm a) - (padl + a + padm + a + padr). -Qed. - -#[export] Hint Resolve swap_block_perm_inv - swap_block_perm_inv_alt : perm_inv_db. - -Lemma swap_block_perm_inv' padl padm padr a : - perm_inv' (padl + a + padm + a + padr) - (swap_block_perm padl padm a) = - swap_block_perm padl padm a. -Proof. - eq_by_WF_perm_eq (padl + a + padm + a + padr). - cleanup_perm_inv. -Qed. - -Lemma swap_block_perm_inv'_alt padl padm padr a : - perm_inv' (padl + a + padm + a + padr) - (swap_block_perm padr padm a) = - swap_block_perm padr padm a. -Proof. - eq_by_WF_perm_eq (padl + a + padm + a + padr). - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite swap_block_perm_inv' - swap_block_perm_inv'_alt : perm_inv_db. - - -Lemma rotr_decomp n m : - rotr n m = - fun k => - if n <=? k then k else - if k + m mod n nat) - (Heq : perm_eq n f g) : - perm_eq (2^n) - (qubit_perm_to_nat_perm n f) - (qubit_perm_to_nat_perm n g). -Proof. - intros k Hk. - unfold qubit_perm_to_nat_perm. - apply funbool_to_nat_eq. - intros x Hx. - unfold compose. - rewrite Heq; easy. -Qed. - -#[export] Hint Resolve qubit_perm_to_nat_perm_perm_eq : perm_inv_db. - -Lemma qubit_perm_to_nat_perm_idn n : - perm_eq (2^n) (qubit_perm_to_nat_perm n idn) idn. -Proof. - intros k Hk. - unfold qubit_perm_to_nat_perm. - rewrite compose_idn_r. - now apply nat_to_funbool_inverse. -Qed. - -#[export] Hint Resolve qubit_perm_to_nat_perm_idn : perm_inv_db. - -Lemma qubit_perm_to_nat_perm_id n f - (Hf : perm_eq n f idn) : - perm_eq (2^n) (qubit_perm_to_nat_perm n f) idn. -Proof. - eapply (fun H => perm_eq_trans H - (qubit_perm_to_nat_perm_idn n)). - auto with perm_inv_db. -Qed. - -#[export] Hint Resolve qubit_perm_to_nat_perm_id : perm_inv_db. - -Lemma qubit_perm_to_nat_perm_inv n f (Hf : permutation n f) : - perm_eq (2^n) - (perm_inv (2^n) (qubit_perm_to_nat_perm n f)) - (qubit_perm_to_nat_perm n (perm_inv n f)). -Proof. - perm_eq_by_inv_inj (qubit_perm_to_nat_perm n f) (2^n). -Qed. - -#[export] Hint Resolve qubit_perm_to_nat_perm_inv : perm_inv_db. \ No newline at end of file diff --git a/src/Permutations/PermutationInstances.v b/src/Permutations/PermutationInstances.v deleted file mode 100644 index 4bf9c47..0000000 --- a/src/Permutations/PermutationInstances.v +++ /dev/null @@ -1,896 +0,0 @@ -Require Import PermutationAuxiliary. -Require Export PermutationFacts. -Require Import PermutationAutomation. - - -Local Open Scope nat. -Local Open Scope prg. - - - - - -(* Section for swap_2_perm *) -Lemma swap_2_perm_invol : - swap_2_perm ∘ swap_2_perm = idn. -Proof. - apply functional_extensionality; intros k. - repeat first [easy | destruct k]. -Qed. - -#[export] Hint Rewrite swap_2_perm_invol : perm_inv_db. - -Lemma swap_2_perm_bounded k : - k < 2 -> swap_2_perm k < 2. -Proof. - intros Hk. - repeat first [easy | destruct k | cbn; lia]. -Qed. - -#[export] Hint Resolve swap_2_perm_bounded : perm_bounded_db. - -Lemma swap_2_WF k : 1 < k -> swap_2_perm k = k. -Proof. - intros. - repeat first [easy | lia | destruct k]. -Qed. - -Lemma swap_2_WF_Perm : WF_Perm 2 swap_2_perm. -Proof. - intros k. - repeat first [easy | lia | destruct k]. -Qed. - -Global Hint Resolve swap_2_WF_Perm : WF_Perm_db. - -Lemma swap_2_perm_permutation : permutation 2 swap_2_perm. -Proof. - perm_by_inverse swap_2_perm. -Qed. - -Global Hint Resolve swap_2_perm_permutation : perm_db. - -Lemma swap_2_perm_inv : - perm_eq 2 - (perm_inv 2 swap_2_perm) swap_2_perm. -Proof. - perm_eq_by_inv_inj swap_2_perm 2. -Qed. - -Lemma swap_2_perm_inv' : - perm_inv' 2 swap_2_perm = swap_2_perm. -Proof. - permutation_eq_by_WF_inv_inj swap_2_perm 2. -Qed. - -#[export] Hint Resolve swap_2_perm_inv : perm_inv_db. -#[export] Hint Rewrite swap_2_perm_inv' : perm_inv_db. - - - - - - - -(* Section for stack_perms *) -Lemma stack_perms_WF_idn n0 n1 f - (H : WF_Perm n0 f) : - stack_perms n0 n1 f idn = f. -Proof. - solve_modular_permutation_equalities; - rewrite H; lia. -Qed. - -#[export] Hint Rewrite stack_perms_WF_idn - using (solve [auto with WF_Perm_db]) : perm_inv_db. - -Lemma stack_perms_WF n0 n1 f g : - WF_Perm (n0 + n1) (stack_perms n0 n1 f g). -Proof. - intros k Hk. - unfold stack_perms. - bdestructΩ'. -Qed. - -Global Hint Resolve stack_perms_WF : WF_Perm_db. - -Lemma stack_perms_bounded {n0 n1} {f g} : - perm_bounded n0 f -> perm_bounded n1 g -> - perm_bounded (n0 + n1) (stack_perms n0 n1 f g). -Proof. - intros Hf Hg. - intros k Hk. - unfold stack_perms. - bdestruct (k (f k < n0 /\ finv k < n0 /\ finv (f k) = k /\ f (finv k) = k)) - (Hg: forall k, k < n1 -> (g k < n1 /\ ginv k < n1 /\ ginv (g k) = k /\ g (ginv k) = k)) : - stack_perms n0 n1 f g ∘ stack_perms n0 n1 finv ginv = idn. -Proof. - unfold compose. - solve_modular_permutation_equalities. - 1-3: specialize (Hf _ H); lia. - - replace (ginv (k - n0) + n0 - n0) with (ginv (k - n0)) by lia. - assert (Hkn0: k - n0 < n1) by lia. - specialize (Hg _ Hkn0). - lia. - - assert (Hkn0: k - n0 < n1) by lia. - specialize (Hg _ Hkn0). - lia. -Qed. - -Lemma stack_perms_linv {n0 n1} {f g} {finv ginv} - (Hf: forall k, k < n0 -> (f k < n0 /\ finv k < n0 /\ finv (f k) = k /\ f (finv k) = k)) - (Hg: forall k, k < n1 -> (g k < n1 /\ ginv k < n1 /\ ginv (g k) = k /\ g (ginv k) = k)) : - stack_perms n0 n1 finv ginv ∘ stack_perms n0 n1 f g = idn. -Proof. - rewrite stack_perms_rinv. - 2,3: rewrite is_inv_iff_inv_is. - all: easy. -Qed. - -Lemma stack_perms_perm_eq_inv_of_perm_eq_inv {n0 n1} {f g} {finv ginv} - (Hf : perm_eq n0 (f ∘ finv) idn) - (Hg : perm_eq n1 (g ∘ ginv) idn) - (Hfinv : perm_bounded n0 finv) - (Hginv : perm_bounded n1 ginv) : - perm_eq (n0 + n1) - (stack_perms n0 n1 f g ∘ stack_perms n0 n1 finv ginv) - idn. -Proof. - unfold compose in *. - intros k Hk. - unfold stack_perms. - specialize (Hfinv k). - specialize (Hginv (k - n0)). - bdestructΩ'; auto. - rewrite Nat.add_sub. - rewrite Hg; lia. -Qed. - -#[export] Hint Resolve stack_perms_perm_eq_inv_of_perm_eq_inv : perm_inv_db. - -Lemma stack_perms_inv_of_perm_eq_inv {n0 n1} {f g} {finv ginv} - (Hf : perm_eq n0 (f ∘ finv) idn) - (Hg : perm_eq n1 (g ∘ ginv) idn) - (Hfinv : perm_bounded n0 finv) - (Hginv : perm_bounded n1 ginv) : - stack_perms n0 n1 f g ∘ stack_perms n0 n1 finv ginv = idn. -Proof. - eq_by_WF_perm_eq (n0 + n1). - auto with perm_inv_db. -Qed. - -#[export] Hint Resolve stack_perms_inv_of_perm_eq_inv : perm_inv_db. - -#[export] Hint Resolve permutation_is_bounded : perm_bounded_db. - -Lemma stack_perms_permutation {n0 n1 f g} (Hf : permutation n0 f) (Hg: permutation n1 g) : - permutation (n0 + n1) (stack_perms n0 n1 f g). -Proof. - perm_by_inverse (stack_perms n0 n1 (perm_inv n0 f) (perm_inv n1 g)). -Qed. - -#[export] Hint Resolve stack_perms_permutation : perm_db. - -Lemma perm_inv_stack_perms n m f g - (Hf : permutation n f) (Hg : permutation m g) : - perm_eq (n + m) - (perm_inv (n + m) (stack_perms n m f g)) - (stack_perms n m (perm_inv n f) (perm_inv m g)). -Proof. - perm_eq_by_inv_inj (stack_perms n m f g) (n+m). -Qed. - - -Lemma stack_perms_proper {n0 n1} {f f' g g'} - (Hf : perm_eq n0 f f') (Hg : perm_eq n1 g g') : - perm_eq (n0 + n1) - (stack_perms n0 n1 f g) - (stack_perms n0 n1 f' g'). -Proof. - intros k Hk. - unfold stack_perms. - bdestructΩ'; [apply Hf | f_equal; apply Hg]; lia. -Qed. - -#[export] Hint Resolve stack_perms_proper : perm_inv_db. - -Lemma stack_perms_proper_eq {n0 n1} {f f' g g'} - (Hf : perm_eq n0 f f') (Hg : perm_eq n1 g g') : - stack_perms n0 n1 f g = - stack_perms n0 n1 f' g'. -Proof. - eq_by_WF_perm_eq (n0 + n1); cleanup_perm_inv. -Qed. - -#[export] Hint Resolve stack_perms_proper_eq : perm_inv_db. - -Lemma perm_inv'_stack_perms n m f g - (Hf : permutation n f) (Hg : permutation m g) : - perm_inv' (n + m) (stack_perms n m f g) = - stack_perms n m (perm_inv' n f) (perm_inv' m g). -Proof. - permutation_eq_by_WF_inv_inj (stack_perms n m f g) (n+m). -Qed. - -#[export] Hint Rewrite @perm_inv'_stack_perms - using auto with perm_db : perm_inv_db. - -Lemma rotr_inv n m : - perm_eq n (perm_inv n (rotr n m)) (rotl n m). -Proof. - perm_eq_by_inv_inj (rotr n m) n. -Qed. - -Lemma rotr_inv' n m : - perm_inv' n (rotr n m) = rotl n m. -Proof. - permutation_eq_by_WF_inv_inj (rotr n m) n. -Qed. - -Lemma rotl_inv n m : - perm_eq n (perm_inv n (rotl n m)) (rotr n m). -Proof. - perm_eq_by_inv_inj (rotl n m) n. -Qed. - -Lemma rotl_inv' n m : - perm_inv' n (rotl n m) = rotr n m. -Proof. - permutation_eq_by_WF_inv_inj (rotl n m) n. -Qed. - -#[export] Hint Resolve rotr_inv rotl_inv : perm_inv_db. -#[export] Hint Rewrite rotr_inv rotr_inv' rotl_inv rotl_inv' : perm_inv_db. - - - - - - - - - -(* Section on top_to_bottom and bottom_to_top *) -Lemma bottom_to_top_perm_bounded {n} k : - k < n -> bottom_to_top_perm n k < n. -Proof. - intros Hk. - unfold bottom_to_top_perm. - replace_bool_lia (n <=? k) false. - destruct k; lia. -Qed. - -Lemma top_to_bottom_perm_bounded {n} k : - k < n -> top_to_bottom_perm n k < n. -Proof. - intros Hk. - unfold top_to_bottom_perm. - replace_bool_lia (n <=? k) false. - bdestruct (k =? n - 1); lia. -Qed. - -Global Hint Resolve bottom_to_top_perm_bounded top_to_bottom_perm_bounded : perm_bounded_db. - -Lemma bottom_to_top_WF_perm n : - WF_Perm n (bottom_to_top_perm n). -Proof. - intros k Hk. - unfold bottom_to_top_perm. - replace_bool_lia (n <=? k) true. - easy. -Qed. - -Lemma top_to_bottom_WF_perm n : - WF_Perm n (top_to_bottom_perm n). -Proof. - intros k Hk. - unfold top_to_bottom_perm. - replace_bool_lia (n <=? k) true. - easy. -Qed. - -Global Hint Resolve bottom_to_top_WF_perm top_to_bottom_WF_perm : WF_Perm_db. - -Lemma bottom_to_top_to_bottom_inv n : - bottom_to_top_perm n ∘ top_to_bottom_perm n = idn. -Proof. - apply functional_extensionality; intros k. - unfold compose, bottom_to_top_perm, top_to_bottom_perm. - bdestruct (n <=? k). - 1: replace_bool_lia (n <=? k) true; easy. - bdestruct (k =? n - 1). - - destruct n. - + easy. - + replace_bool_lia (S n <=? 0) false. - lia. - - replace_bool_lia (n <=? k + 1) false. - replace (k + 1) with (S k) by lia. - easy. -Qed. - -Lemma top_to_bottom_to_top_inv n : - top_to_bottom_perm n ∘ bottom_to_top_perm n = idn. -Proof. - apply functional_extensionality; intros k. - unfold compose, bottom_to_top_perm, top_to_bottom_perm. - bdestruct (n <=? k). - 1: replace_bool_lia (n <=? k) true; easy. - destruct k. - - destruct n; [easy|]. - replace_bool_lia (S n <=? S n - 1) false. - rewrite Nat.eqb_refl. - easy. - - replace_bool_lia (n <=? k) false. - replace_bool_lia (k =? n - 1) false. - lia. -Qed. - -Lemma bottom_to_top_to_bottom_inv' n k : - bottom_to_top_perm n (top_to_bottom_perm n k) = k. -Proof. - pose proof (bottom_to_top_to_bottom_inv n) as H. - apply (f_equal (fun g => g k)) in H. - unfold compose in H. - easy. -Qed. - -Lemma top_to_bottom_to_top_inv' n k : - top_to_bottom_perm n (bottom_to_top_perm n k) = k. -Proof. - pose proof (top_to_bottom_to_top_inv n) as H. - apply (f_equal (fun g => g k)) in H. - unfold compose in H. - easy. -Qed. - -#[export] Hint Rewrite - bottom_to_top_to_bottom_inv - bottom_to_top_to_bottom_inv' - top_to_bottom_to_top_inv - top_to_bottom_to_top_inv' - : perm_inv_db. - -Lemma top_to_bottom_permutation n : - permutation n (top_to_bottom_perm n). -Proof. - perm_by_inverse (bottom_to_top_perm n). -Qed. - -Lemma bottom_to_top_permutation n : - permutation n (bottom_to_top_perm n). -Proof. - perm_by_inverse (top_to_bottom_perm n). -Qed. - -Global Hint Resolve top_to_bottom_permutation bottom_to_top_permutation : perm_db. - -Lemma top_to_bottom_inv n : - perm_eq n (perm_inv n (top_to_bottom_perm n)) (bottom_to_top_perm n). -Proof. - perm_eq_by_inv_inj (top_to_bottom_perm n) n. -Qed. - -Lemma bottom_to_top_inv n : - perm_eq n (perm_inv n (bottom_to_top_perm n)) (top_to_bottom_perm n). -Proof. - perm_eq_by_inv_inj (bottom_to_top_perm n) n. -Qed. - -Lemma top_to_bottom_inv' n : - perm_inv' n (top_to_bottom_perm n) = bottom_to_top_perm n. -Proof. - permutation_eq_by_WF_inv_inj (top_to_bottom_perm n) n. -Qed. - -Lemma bottom_to_top_inv' n : - perm_inv' n (bottom_to_top_perm n) = top_to_bottom_perm n. -Proof. - permutation_eq_by_WF_inv_inj (bottom_to_top_perm n) n. -Qed. - -#[export] Hint Rewrite top_to_bottom_inv top_to_bottom_inv' - bottom_to_top_inv bottom_to_top_inv' : perm_inv_db. - -Lemma top_to_bottom_perm_eq_rotr n : - top_to_bottom_perm n = rotr n 1. -Proof. - apply functional_extensionality; intros k. - unfold top_to_bottom_perm, rotr. - bdestructΩ'. - - subst. - replace (n - 1 + 1) with n by lia. - rewrite Nat.Div0.mod_same; lia. - - rewrite Nat.mod_small; lia. -Qed. - -#[export] Hint Rewrite top_to_bottom_perm_eq_rotr : perm_cleanup_db. - -Lemma bottom_to_top_perm_eq_rotl n : - bottom_to_top_perm n = rotl n 1. -Proof. - permutation_eq_by_WF_inv_inj (top_to_bottom_perm n) n. -Qed. - -#[export] Hint Rewrite bottom_to_top_perm_eq_rotl : perm_cleanup_db. - - - - -Definition kron_comm_perm p q := - fun k => if p * q <=? k then k else - k mod p * q + k / p. - -Lemma kron_comm_perm_WF p q : - WF_Perm (p * q) (kron_comm_perm p q). -Proof. - intros k Hk; unfold kron_comm_perm; bdestructΩ'. -Qed. - -Lemma kron_comm_perm_WF_alt p q : - WF_Perm (q * p) (kron_comm_perm p q). -Proof. - rewrite Nat.mul_comm; apply kron_comm_perm_WF. -Qed. - -#[export] Hint Resolve kron_comm_perm_WF kron_comm_perm_WF_alt : WF_Perm_db. - -Lemma kron_comm_perm_bounded p q : - perm_bounded (p * q) (kron_comm_perm p q). -Proof. - intros k Hk. - unfold kron_comm_perm. - bdestructΩ'. - show_moddy_lt. -Qed. - -Lemma kron_comm_perm_bounded_alt p q : - perm_bounded (q * p) (kron_comm_perm p q). -Proof. - rewrite Nat.mul_comm. - apply kron_comm_perm_bounded. -Qed. - -#[export] Hint Resolve kron_comm_perm_bounded - kron_comm_perm_bounded_alt : perm_bounded_db. - -Lemma kron_comm_perm_pseudo_invol_perm_eq p q : - perm_eq (p * q) (kron_comm_perm p q ∘ kron_comm_perm q p)%prg idn. -Proof. - intros k Hk. - unfold compose, kron_comm_perm. - simplify_bools_lia_one_kernel. - simplify_bools_moddy_lia_one_kernel. - rewrite (Nat.add_comm _ (k/q)). - rewrite Nat.Div0.mod_add, Nat.div_add by show_nonzero. - rewrite Nat.Div0.div_div, Nat.mod_small by show_moddy_lt. - rewrite (Nat.div_small k (q*p)) by lia. - symmetry. - rewrite (Nat.div_mod_eq k q) at 1; lia. -Qed. - -#[export] Hint Resolve kron_comm_perm_pseudo_invol_perm_eq : perm_inv_db. - -Lemma kron_comm_perm_pseudo_invol_alt_perm_eq p q : - perm_eq (q * p) (kron_comm_perm p q ∘ kron_comm_perm q p)%prg idn. -Proof. - rewrite Nat.mul_comm; cleanup_perm_inv. -Qed. - -#[export] Hint Resolve kron_comm_perm_pseudo_invol_alt_perm_eq : perm_inv_db. - -Lemma kron_comm_perm_pseudo_invol p q : - kron_comm_perm p q ∘ kron_comm_perm q p = idn. -Proof. - eq_by_WF_perm_eq (p*q); cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite kron_comm_perm_pseudo_invol : perm_inv_db. - -Lemma kron_comm_perm_permutation p q : - permutation (p * q) (kron_comm_perm p q). -Proof. - perm_by_inverse (kron_comm_perm q p). -Qed. - -Lemma kron_comm_perm_permutation_alt p q : - permutation (q * p) (kron_comm_perm p q). -Proof. - perm_by_inverse (kron_comm_perm q p). -Qed. - -#[export] Hint Resolve kron_comm_perm_permutation - kron_comm_perm_permutation_alt : perm_db. - -Lemma kron_comm_perm_inv p q : - perm_eq (p * q) - (perm_inv (p * q) (kron_comm_perm p q)) - (kron_comm_perm q p). -Proof. - perm_eq_by_inv_inj (kron_comm_perm p q) (p * q). -Qed. - -Lemma kron_comm_perm_inv_alt p q : - perm_eq (q * p) - (perm_inv (p * q) (kron_comm_perm p q)) - (kron_comm_perm q p). -Proof. - perm_eq_by_inv_inj (kron_comm_perm p q) (q * p). -Qed. - -Lemma kron_comm_perm_swap_inv p q : - perm_eq (p * q) - (perm_inv (p * q) (kron_comm_perm q p)) - (kron_comm_perm p q). -Proof. - perm_eq_by_inv_inj (kron_comm_perm q p) (p * q). -Qed. - -Lemma kron_comm_perm_swap_inv_alt p q : - perm_eq (q * p) - (perm_inv (p * q) (kron_comm_perm q p)) - (kron_comm_perm p q). -Proof. - perm_eq_by_inv_inj (kron_comm_perm q p) (q * p). -Qed. - -#[export] Hint Resolve kron_comm_perm_inv - kron_comm_perm_inv_alt - kron_comm_perm_swap_inv - kron_comm_perm_swap_inv_alt : perm_inv_db. - -Lemma kron_comm_perm_inv' p q : - perm_inv' (p * q) (kron_comm_perm p q) = - kron_comm_perm q p. -Proof. - eq_by_WF_perm_eq (p * q). - cleanup_perm_inv. -Qed. - -Lemma kron_comm_perm_inv'_alt p q : - perm_inv' (q * p) (kron_comm_perm p q) = - kron_comm_perm q p. -Proof. - eq_by_WF_perm_eq (q * p). - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite kron_comm_perm_inv' - kron_comm_perm_inv'_alt : perm_inv_db. - -#[export] Hint Resolve compose_WF_Perm : WF_Perm_db. - -Lemma swap_block_perm_decomp_eq padl padr padm a : - swap_block_perm padl padm a = - stack_perms padl (a + padm + a + padr) idn - (stack_perms (a + padm + a) padr - ((stack_perms (a + padm) a (rotr (a + padm) a) idn) ∘ - rotr (a + padm + a) (a + padm)) idn). -Proof. - rewrite 2!stack_perms_WF_idn by - eauto using monotonic_WF_Perm with WF_Perm_db zarith. - rewrite 2!rotr_decomp. - pose proof (Nat.mod_small (a + padm) (a + padm + a)) as Hsm. - pose proof (Nat.mod_small (a) (a + padm)) as Hsm'. - pose proof (Nat.mod_upper_bound (a + padm) (a + padm + a)) as Hl. - pose proof (Nat.mod_upper_bound (a) (a + padm)) as Hl'. - assert (Hpadm0: padm = 0 -> a mod (a + padm) = 0) by - (intros ->; rewrite Nat.add_0_r, Nat.Div0.mod_same; easy). - rewrite stack_perms_idn_f. - unfold swap_block_perm. - apply functional_extensionality; intros k. - unfold compose. - bdestruct (a =? 0); - [subst; - rewrite ?Nat.add_0_r, ?Nat.add_0_l, ?Nat.Div0.mod_same in *; - bdestructΩ'|]. - rewrite Hsm in * by lia. - bdestruct (padm =? 0); - [subst; - rewrite ?Nat.add_0_r, ?Nat.add_0_l, ?Nat.Div0.mod_same in *; - bdestructΩ'|]. - rewrite Hsm' in * by lia. - bdestructΩ'. -Qed. - - - -Lemma tensor_perms_bounded n0 n1 f g : - perm_bounded n0 f -> perm_bounded n1 g -> - perm_bounded (n0 * n1) (tensor_perms n0 n1 f g). -Proof. - intros Hf Hg k Hk. - unfold tensor_perms. - simplify_bools_lia_one_kernel. - pose proof (Hf (k / n1) ltac:(show_moddy_lt)). - pose proof (Hg (k mod n1) ltac:(show_moddy_lt)). - show_moddy_lt. -Qed. - -#[export] Hint Resolve tensor_perms_bounded : perm_bounded_db. - -Lemma tensor_perms_WF n0 n1 f g : - WF_Perm (n0 * n1) (tensor_perms n0 n1 f g). -Proof. - intros k Hk. - unfold tensor_perms. - bdestructΩ'. -Qed. - -#[export] Hint Resolve tensor_perms_WF : WF_Perm_db. -#[export] Hint Extern 100 (WF_Perm ?n01 (tensor_perms ?n0 ?n1 ?f ?g)) => - replace n01 with (n0 * n1) by nia : WF_Perm_db. - -Lemma tensor_perms_compose n0 n1 f0 f1 g0 g1 : - perm_bounded n0 f1 -> perm_bounded n1 g1 -> - tensor_perms n0 n1 f0 g0 ∘ tensor_perms n0 n1 f1 g1 = - tensor_perms n0 n1 (f0 ∘ f1) (g0 ∘ g1). -Proof. - intros Hf1 Hg1. - eq_by_WF_perm_eq (n0*n1). - intros k Hk. - unfold compose. - generalize (tensor_perms_bounded n0 n1 f1 g1 Hf1 Hg1 k Hk). - unfold tensor_perms. - simplify_bools_lia_one_kernel. - intros ?. - simplify_bools_lia_one_kernel. - rewrite Nat.div_add_l by lia. - pose proof (Hf1 (k / n1) ltac:(show_moddy_lt)). - pose proof (Hg1 (k mod n1) ltac:(show_moddy_lt)). - rewrite (Nat.div_small (g1 _)), mod_add_l, Nat.mod_small by easy. - now rewrite Nat.add_0_r. -Qed. - -#[export] Hint Rewrite tensor_perms_compose : perm_cleanup_db perm_inv_db. - -Lemma tensor_perms_0_l n1 f g : - tensor_perms 0 n1 f g = idn. -Proof. - eq_by_WF_perm_eq (0 * n1). -Qed. - -Lemma tensor_perms_0_r n0 f g : - tensor_perms n0 0 f g = idn. -Proof. - eq_by_WF_perm_eq (n0 * 0). - lia. -Qed. - -#[export] Hint Rewrite tensor_perms_0_l - tensor_perms_0_r : perm_cleanup_db perm_inv_db. - -Lemma tensor_perms_perm_eq_proper n0 n1 f f' g g' : - perm_eq n0 f f' -> perm_eq n1 g g' -> - tensor_perms n0 n1 f g = tensor_perms n0 n1 f' g'. -Proof. - intros Hf' Hg'. - eq_by_WF_perm_eq (n0 * n1). - intros k Hk. - unfold tensor_perms. - simplify_bools_lia_one_kernel. - now rewrite Hf', Hg' by show_moddy_lt. -Qed. - -#[export] Hint Resolve tensor_perms_perm_eq_proper : perm_inv_db. - -Lemma tensor_perms_idn_idn n0 n1 : - tensor_perms n0 n1 idn idn = idn. -Proof. - eq_by_WF_perm_eq (n0 * n1). - unfold tensor_perms. - intros k Hk. - simplify_bools_lia_one_kernel. - pose proof (Nat.div_mod_eq k n1). - lia. -Qed. - -#[export] Hint Rewrite tensor_perms_idn_idn : perm_cleanup_db. - -Lemma tensor_perms_idn_idn' n0 n1 f g : - perm_eq n0 f idn -> perm_eq n1 g idn -> - tensor_perms n0 n1 f g = idn. -Proof. - intros Hf Hg. - rewrite <- (tensor_perms_idn_idn n0 n1). - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite tensor_perms_idn_idn' - using (solve [cleanup_perm_inv]) : perm_inv_db. - -Lemma tensor_perms_permutation n0 n1 f g - (Hf : permutation n0 f) (Hg : permutation n1 g) : - permutation (n0 * n1) (tensor_perms n0 n1 f g). -Proof. - perm_by_inverse (tensor_perms n0 n1 (perm_inv n0 f) (perm_inv n1 g)). -Qed. - -#[export] Hint Resolve tensor_perms_permutation : perm_db. - -Lemma tensor_perms_inv n0 n1 f g - (Hf : permutation n0 f) (Hg : permutation n1 g) : - perm_eq (n0 * n1) - (perm_inv (n0 * n1) (tensor_perms n0 n1 f g)) - (tensor_perms n0 n1 (perm_inv n0 f) (perm_inv n1 g)). -Proof. - perm_eq_by_inv_inj (tensor_perms n0 n1 f g) (n0*n1). -Qed. - -#[export] Hint Resolve tensor_perms_inv : perm_inv_db. - -Lemma tensor_perms_inv' n0 n1 f g - (Hf : permutation n0 f) (Hg : permutation n1 g) : - perm_inv' (n0 * n1) (tensor_perms n0 n1 f g) = - tensor_perms n0 n1 (perm_inv' n0 f) (perm_inv' n1 g). -Proof. - permutation_eq_by_WF_inv_inj (tensor_perms n0 n1 f g) (n0*n1). -Qed. - -#[export] Hint Rewrite tensor_perms_inv' - using auto with perm_db : perm_inv_db. - -#[export] Hint Extern 100 (WF_Perm ?npow2 (qubit_perm_to_nat_perm ?n _)) => - replace npow2 with (2^n) by (show_pow2_le + unify_pows_two; nia) - : WF_Perm_db. - -Section qubit_perm_lemmas. - -Import Bits. - -Lemma qubit_perm_to_nat_perm_stack_perms n0 n1 f g - (Hf : perm_bounded n0 f) (Hg : perm_bounded n1 g) : - perm_eq (2^n0 * 2^n1) - (qubit_perm_to_nat_perm (n0 + n1) (stack_perms n0 n1 f g)) - (tensor_perms (2^n0) (2^n1) - (qubit_perm_to_nat_perm n0 f) - (qubit_perm_to_nat_perm n1 g)). -Proof. - intros k Hk. - unfold tensor_perms. - simplify_bools_lia_one_kernel. - unfold qubit_perm_to_nat_perm. - rewrite funbool_to_nat_add_pow2_join. - apply funbool_to_nat_eq. - intros a Ha. - unfold compose. - bdestruct (a if n + m <=? k then k else - if k if m + n <=? k then k else - if k n1 mod (n0 + n1) = 0) by - (intros ->; apply Nat.Div0.mod_same). - rewrite <- Nat.add_sub_assoc by lia. - rewrite rotr_eq_rotr_mod. - rewrite Nat.Div0.add_mod. - replace ((n1 - n1 mod (n0 + n1)) mod (n0 + n1)) with 0 by - (bdestruct (n0 =? 0); [subst; symmetry; - rewrite Nat.Div0.mod_same, Nat.sub_0_r, Nat.Div0.mod_same| - rewrite (Nat.mod_small n1), Nat.sub_diag, Nat.Div0.mod_0_l]; - lia). - rewrite Nat.add_0_r, <- !rotr_eq_rotr_mod. - now rewrite stack_perms_rotr_natural. -Qed. - - -Lemma tensor_perms_kron_comm_perm_natural n0 n1 f g - (Hf : perm_bounded n0 f) (Hg : perm_bounded n1 g) : - tensor_perms n0 n1 f g ∘ kron_comm_perm n0 n1 = - kron_comm_perm n0 n1 ∘ tensor_perms n1 n0 g f. -Proof. - eq_by_WF_perm_eq (n0 * n1). - intros k Hk. - unfold compose, kron_comm_perm. - assert (tensor_perms n1 n0 g f k < n1 * n0) - by auto with perm_bounded_db zarith. - do 2 simplify_bools_lia_one_kernel. - unfold tensor_perms. - simplify_bools_moddy_lia_one_kernel. - simplify_bools_lia_one_kernel. - rewrite !Nat.div_add_l, !mod_add_l by lia. - pose proof (Hf (k mod n0) ltac:(show_moddy_lt)). - pose proof (Hg (k / n0) ltac:(show_moddy_lt)). - rewrite Nat.Div0.div_div, Nat.div_small, Nat.add_0_r by lia. - rewrite (Nat.mod_small (k / n0)) by (show_moddy_lt). - rewrite (Nat.mod_small (f _)), (Nat.div_small (f _)) by lia. - lia. -Qed. - diff --git a/src/Permutations/PermutationRules.v b/src/Permutations/PermutationRules.v deleted file mode 100644 index 230baa9..0000000 --- a/src/Permutations/PermutationRules.v +++ /dev/null @@ -1,9 +0,0 @@ -Require Export PermutationDefinitions. -Require Export ZXperm. -Require Export ZXpermSemantics. -Require Export PermutationAutomation. -Require Export ZXpermFacts. - -(* Horrible hack to fix scoping issues: *) -Require Export StackComposeRules. - diff --git a/src/Permutations/PermutationSemantics.v b/src/Permutations/PermutationSemantics.v deleted file mode 100644 index 58feb9a..0000000 --- a/src/Permutations/PermutationSemantics.v +++ /dev/null @@ -1,317 +0,0 @@ -Require Import PermutationAuxiliary. -Require Import PermutationAutomation. -Require Import PermutationInstances. -Require Export PermMatrixFacts KronComm. - -Lemma perm_to_matrix_rotr_eq_kron_comm : forall n o, - perm_to_matrix (n + o) (rotr (n + o) n) = kron_comm (2^o) (2^n). -Proof. - intros n o. - now rewrite <- kron_comm_pows2_eq_perm_to_matrix_rotr. -Qed. - -#[export] Hint Rewrite perm_to_matrix_rotr_eq_kron_comm : perm_inv_db. - -Lemma perm_to_matrix_rotr_eq_kron_comm_alt : forall n o, - perm_to_matrix (n + o) (rotr (n + o) o) = kron_comm (2^n) (2^o). -Proof. - intros n o. - rewrite Nat.add_comm. - cleanup_perm_inv. -Qed. - -#[export] Hint Rewrite perm_to_matrix_rotr_eq_kron_comm_alt : perm_inv_db. - -Lemma perm_to_matrix_rotr_eq_kron_comm_mat_equiv : forall n o, - perm_to_matrix (n + o) (rotr (n + o) n) ≡ kron_comm (2^o) (2^n). -Proof. - intros n o. - now rewrite perm_to_matrix_rotr_eq_kron_comm. -Qed. - -#[export] Hint Resolve - perm_to_matrix_rotr_eq_kron_comm_mat_equiv : perm_inv_db. - -Lemma perm_to_matrix_rotl_eq_kron_comm : forall n o, - perm_to_matrix (n + o) (rotl (n + o) n) = kron_comm (2^n) (2^o). -Proof. - intros n o. - rewrite <- (perm_to_matrix_eq_of_perm_eq _ _ _ (rotr_inv (n + o) n)). - rewrite <- perm_to_matrix_transpose_eq by auto with perm_db. - rewrite perm_to_matrix_rotr_eq_kron_comm. - apply kron_comm_transpose. -Qed. - -#[export] Hint Rewrite perm_to_matrix_rotl_eq_kron_comm : perm_inv_db. - -Lemma perm_to_matrix_rotl_eq_kron_comm_mat_equiv : forall n o, - perm_to_matrix (n + o) (rotl (n + o) n) ≡ kron_comm (2^n) (2^o). -Proof. - intros. - now rewrite perm_to_matrix_rotl_eq_kron_comm. -Qed. - -#[export] Hint Resolve - perm_to_matrix_rotl_eq_kron_comm_mat_equiv : perm_inv_db. - -Lemma perm_to_matrix_swap_block_perm_eq padl padm padr a : - perm_to_matrix (padl + a + padm + a + padr) - (swap_block_perm padl padm a) = - I (2^padl) ⊗ - (kron_comm (2^a) (2^padm * 2^a) × - (kron_comm (2^padm) (2^a) ⊗ I (2^a))) ⊗ - I (2^padr). -Proof. - rewrite (swap_block_perm_decomp_eq padl padr padm a). - rewrite <- !(Nat.add_assoc padl). - rewrite 2!perm_to_matrix_of_stack_perms by auto with perm_db. - rewrite perm_to_matrix_compose by auto with perm_db. - rewrite perm_to_matrix_of_stack_perms by auto with perm_db. - rewrite 3!perm_to_matrix_idn. - rewrite kron_assoc by auto with wf_db. - f_equal; [show_pow2_le..|]. - f_equal; [show_pow2_le..|]. - rewrite 2!perm_to_matrix_rotr_eq_kron_comm. - unify_pows_two. - rewrite (Nat.add_comm a padm). - easy. -Qed. - -#[export] Hint Rewrite perm_to_matrix_swap_block_perm_eq : perm_inv_db. - -Lemma perm_to_matrix_rotr_commutes_kron_mat_equiv {n m p q} - (A : Matrix (2^n) (2^m)) (B : Matrix (2^p) (2^q)) : - @Mmult (2^n*2^p) (2^m*2^q) (2^q*2^m) - (A ⊗ B) (perm_to_matrix (q + m) (rotr (q + m) q)) ≡ - @Mmult (2^n*2^p) (2^p*2^n) (2^q*2^m) - (perm_to_matrix (p + n) (rotr (p + n) p)) (B ⊗ A). -Proof. - unify_pows_two. - rewrite 2!perm_to_matrix_rotr_eq_kron_comm. - restore_dims. - pose proof (kron_comm_commutes_r_mat_equiv (2^n) (2^m) - (2^p) (2^q) A B) as H. - rewrite !Nat.pow_add_r. - apply H. -Qed. - -Lemma perm_to_matrix_rotr_commutes_kron {n m p q} - (A : Matrix (2^n) (2^m)) (B : Matrix (2^p) (2^q)) : - WF_Matrix A -> WF_Matrix B -> - @Mmult (2^n*2^p) (2^m*2^q) (2^q*2^m) - (A ⊗ B) (perm_to_matrix (q + m) (rotr (q + m) q)) = - @Mmult (2^n*2^p) (2^p*2^n) (2^q*2^m) - (perm_to_matrix (p + n) (rotr (p + n) p)) (B ⊗ A). -Proof. - unify_pows_two. - rewrite 2!perm_to_matrix_rotr_eq_kron_comm. - restore_dims. - pose proof (kron_comm_commutes_r (2^n) (2^m) - (2^p) (2^q) A B) as H. - rewrite !Nat.pow_add_r. - apply H. -Qed. - - -Lemma perm_to_matrix_swap_block_perm_natural {padl padm padr a} - (A : Matrix (2^a) (2^a)) : - @mat_equiv (2^padl*2^a*2^padm*2^a*2^padr) (2^padl*2^a*2^padm*2^a*2^padr) - (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ - (I (2^padl) ⊗ A ⊗ I (2^padm * 2^a * 2^padr)) - (perm_to_matrix (padl + a + padm + a + padr) - (swap_block_perm padl padm a))) - (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ - (perm_to_matrix (padl + a + padm + a + padr) - (swap_block_perm padl padm a)) - (I (2^padl * 2^a * 2^padm) ⊗ A ⊗ I (2^padr))). -Proof. - apply mat_equiv_of_all_basis_conj. - intros i j Hi Hj. - rewrite !Mmult_assoc. - rewrite <- !Nat.pow_add_r in *. - rewrite !basis_f_to_vec_alt by easy. - rewrite perm_to_matrix_permutes_qubits by - apply swap_block_perm_permutation. - rewrite <- (transpose_involutive _ _ - (perm_to_matrix _ (swap_block_perm _ _ _))). - rewrite <- !Mmult_assoc, <- Mmult_transpose. - rewrite (perm_to_matrix_transpose_eq - (swap_block_perm_permutation padl padm padr a)). - rewrite (perm_to_matrix_eq_of_perm_eq _ _ _ - (swap_block_perm_inv padl padm padr a)). - rewrite perm_to_matrix_permutes_qubits by - apply swap_block_perm_permutation. - replace (padl+a+padm+a+padr) with (padl+a+(padm+a+padr)) in * by lia. - rewrite 2!(f_to_vec_split'_eq (padl+a)), 2!(f_to_vec_split'_eq (padl)). - rewrite !(fun x y => kron_transpose' _ _ x y). - rewrite !(fun x y z => kron_mixed_product' _ _ _ _ _ _ _ x y z) by - (now rewrite ?Nat.pow_add_r; simpl;lia). - rewrite !Mmult_1_r by auto with wf_db. - symmetry. - - replace (padl+a+(padm+a+padr)) with ((padl+a+padm)+a+padr) in * by lia. - rewrite 2!(f_to_vec_split'_eq (padl+a+padm+a)), 2!(f_to_vec_split'_eq (_+_+_)). - rewrite !(fun x y => kron_transpose' _ _ x y). - rewrite !(fun x y z => kron_mixed_product' _ _ _ _ _ _ _ x y z) by - (now rewrite ?Nat.pow_add_r; simpl;lia). - rewrite !Mmult_1_r by auto with wf_db. - unfold kron. - rewrite !Nat.mod_1_r, Nat.Div0.div_0_l. - rewrite !basis_f_to_vec. - rewrite !basis_trans_basis. - rewrite !matrix_conj_basis_eq_lt - by show_moddy_lt. - rewrite !Cmult_if_1_l, !Cmult_if_if_1_r. - apply f_equal_if. - - do 4 simplify_bools_moddy_lia_one_kernel. - apply eq_iff_eq_true. - rewrite !andb_true_iff, !Nat.eqb_eq. - rewrite <- !funbool_to_nat_eq_iff. - split;intros [Hlow Hhigh]; - split. - + intros k Hk. - generalize (Hlow k ltac:(lia)). - unfold swap_block_perm. - now simplify_bools_lia. - + intros k Hk. - unfold swap_block_perm. - simplify_bools_lia. - bdestructΩ'. - * generalize (Hlow (padl+a+k) ltac:(lia)). - unfold swap_block_perm. - now simplify_bools_lia. - * generalize (Hlow (padl + a + k - (a + padm)) ltac:(lia)). - unfold swap_block_perm. - simplify_bools_lia. - intros <-. - f_equal; lia. - * apply_with_obligations - (Hhigh ((padl + a + k) - (padl + a + padm + a)) ltac:(lia)); - f_equal; [lia|]. - unfold swap_block_perm; bdestructΩ'. - + intros k Hk. - unfold swap_block_perm. - simplify_bools_lia. - bdestructΩ'. - * generalize (Hlow (k) ltac:(lia)). - unfold swap_block_perm. - now simplify_bools_lia. - * apply_with_obligations - (Hhigh ((a + padm) + k - (padl + a)) ltac:(lia)); - f_equal; [|lia]. - unfold swap_block_perm; bdestructΩ'. - * apply_with_obligations - (Hhigh (k - (padl + a)) ltac:(lia)); - f_equal; [|lia]. - unfold swap_block_perm; bdestructΩ'. - + intros k Hk. - apply_with_obligations (Hhigh (padm + a + k) ltac:(lia)); - f_equal; - unfold swap_block_perm; - bdestructΩ'. - - f_equal; - apply Bits.funbool_to_nat_eq; - intros; - unfold swap_block_perm; - bdestructΩ'; f_equal; lia. - - easy. -Qed. - -Lemma perm_to_matrix_swap_block_perm_natural_eq {padl padm padr a} - (A : Matrix (2^a) (2^a)) (HA : WF_Matrix A) : - @eq (Matrix (2^padl*2^a*2^padm*2^a*2^padr) (2^padl*2^a*2^padm*2^a*2^padr)) - (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ - (I (2^padl) ⊗ A ⊗ I (2^padm * 2^a * 2^padr)) - (perm_to_matrix (padl + a + padm + a + padr) - (swap_block_perm padl padm a))) - (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ - (perm_to_matrix (padl + a + padm + a + padr) - (swap_block_perm padl padm a)) - (I (2^padl * 2^a * 2^padm) ⊗ A ⊗ I (2^padr))). -Proof. - apply mat_equiv_eq; - auto using WF_Matrix_dim_change with wf_db. - apply perm_to_matrix_swap_block_perm_natural. -Qed. - -Lemma perm_to_matrix_swap_block_perm_natural_eq_alt {padl padm padr a} - (A : Matrix (2^a) (2^a)) (HA : WF_Matrix A) : - @eq (Matrix (2^padl*2^a*2^padm*2^a*2^padr) (2^(padl+a+padm+a+padr))) - (@Mmult _ (2^padl*2^a*2^padm*2^a*2^padr) _ - (I (2^padl) ⊗ A ⊗ I (2^padm * 2^a * 2^padr)) - (perm_to_matrix (padl + a + padm + a + padr) - (swap_block_perm padl padm a))) - (@Mmult (2^padl*2^a*2^padm*2^a*2^padr) (2^padl*2^a*2^padm*2^a*2^padr) _ - (perm_to_matrix (padl + a + padm + a + padr) - (swap_block_perm padl padm a)) - (I (2^padl * 2^a * 2^padm) ⊗ A ⊗ I (2^padr))). -Proof. - generalize (@perm_to_matrix_swap_block_perm_natural_eq - padl padm padr a A HA). - unify_pows_two. - easy. -Qed. - -Lemma perm_to_matrix_pullthrough_middle_eq_idn padl padm padr padm' f - (Hf : permutation (padl + padm + padr) f) - (Hfid : perm_eq_id_mid padl padm f) - (A : Matrix (2^padm') (2^padm)) (HA : WF_Matrix A) : - @Mmult (2^padl*2^padm'*2^padr) (2^padl*2^padm*2^padr) (2^(padl+padm+padr)) - (I (2^padl) ⊗ A ⊗ I (2^padr)) (perm_to_matrix (padl + padm + padr) f) = - @Mmult (2^(padl+padm'+padr)) (2^padl*2^padm'*2^padr) (2^padl*2^padm*2^padr) - (perm_to_matrix (padl + padm' + padr) - (expand_perm_id_mid padl padm' padr - (contract_perm_id_mid padl padm padr f))) - (I (2^padl) ⊗ A ⊗ I (2^padr)). -Proof. - rewrite (perm_to_matrix_eq_of_perm_eq _ _ _ - (perm_eq_sym (expand_contract_perm_perm_eq_idn_inv Hf Hfid))). - unfold expand_perm_id_mid. - rewrite 4!perm_to_matrix_compose by - (erewrite permutation_change_dims; auto with perm_db zarith - || apply permutation_compose; - erewrite permutation_change_dims; auto with perm_db zarith). - replace (padl + padm + padr) with (padl + padr + padm) by lia. - rewrite perm_to_matrix_of_stack_perms by auto with perm_db. - replace (padl + padr + padm) with (padl + (padm + padr)) by lia. - rewrite !perm_to_matrix_of_stack_perms by auto with perm_db. - replace (padl + padm' + padr) with (padl + padr + padm') by lia. - rewrite perm_to_matrix_of_stack_perms by auto with perm_db. - replace (padl + padr + padm') with (padl + (padm' + padr)) by lia. - rewrite !perm_to_matrix_of_stack_perms by auto with perm_db. - rewrite !perm_to_matrix_idn. - rewrite !perm_to_matrix_rotr_eq_kron_comm_alt, - !perm_to_matrix_rotr_eq_kron_comm. - unify_pows_two. - rewrite <- !Mmult_assoc. - rewrite !Nat.pow_add_r. - rewrite kron_assoc, <- 2!Nat.mul_assoc by auto with wf_db. - rewrite kron_mixed_product. - restore_dims. - rewrite (kron_comm_commutes_r _ _ _ _ A (I (2^padr))) by auto with wf_db. - rewrite (Nat.mul_comm (2^padm) (2^padr)). - rewrite <- kron_mixed_product. - rewrite <- kron_assoc by auto with wf_db. - rewrite !Mmult_assoc. - f_equal. - restore_dims. - rewrite !Nat.pow_add_r. - rewrite <- (Mmult_assoc (_ ⊗ _ ⊗ A)). - rewrite kron_mixed_product. - rewrite Mmult_1_r by auto. - rewrite id_kron. - restore_dims. - rewrite Mmult_1_l, <- (Mmult_1_r _ _ (perm_to_matrix _ _)) by auto with wf_db. - rewrite <- (Mmult_1_l _ _ A) by auto. - rewrite <- kron_mixed_product. - rewrite Mmult_1_r, Mmult_1_l by auto with wf_db. - rewrite Mmult_assoc. - f_equal. - rewrite kron_mixed_product, kron_comm_commutes_l by auto with wf_db. - rewrite <- kron_mixed_product. - restore_dims. - rewrite <- kron_assoc by auto with wf_db. - rewrite Nat.pow_add_r, <- id_kron. - now restore_dims. -Qed. - diff --git a/src/Permutations/ZXperm.v b/src/Permutations/ZXperm.v index 037207d..b40e238 100644 --- a/src/Permutations/ZXperm.v +++ b/src/Permutations/ZXperm.v @@ -1,5 +1,5 @@ Require Import CoreData. -Require Import PermutationDefinitions. +Require Import QuantumLib.PermutationsBase. Open Scope ZX_scope. diff --git a/src/Permutations/ZXpermAutomation.v b/src/Permutations/ZXpermAutomation.v new file mode 100644 index 0000000..281d58f --- /dev/null +++ b/src/Permutations/ZXpermAutomation.v @@ -0,0 +1,231 @@ +Require Import ZXCore. +Require CastRules ComposeRules. +Require Export ZXperm. + +Create HintDb perm_of_zx_cleanup_db. +Create HintDb zxperm_db. +#[export] Hint Constructors ZXperm : zxperm_db. + +Ltac cleanup_perm_of_zx := + autounfold with zxperm_db; + autorewrite with perm_of_zx_cleanup_db perm_inv_db perm_cleanup_db; + auto with perm_of_zx_cleanup_db perm_inv_db perm_cleanup_db + perm_db perm_bounded_db WF_Perm_db. + +(* Hack to get auto to apply PermStack where it obviously should + (like to ZXperm (S n) (— ↕ zx), where zx : ZX n n; it doesn't work + here because apply doesn't see that S n = 1 + n, but if we tell it + to look for 1 + n, it will find S n). *) +Ltac __cleanup_stack_perm zx0 zx1 := + match type of zx0 with ZX ?n0 ?n0 => + match type of zx1 with ZX ?n1 ?n1 => + apply (PermStack (n0:=n0) (n1:=n1)) + end end. + +#[export] Hint Extern 0 (ZXperm _ (?zx0 ↕ ?zx1)) => + __cleanup_stack_perm zx0 zx1 : zxperm_db. + +#[export] Hint Extern 0 (ZXperm _ (@Stack ?n _ ?m _ ?zx0 ?zx1)) => + apply (@PermStack n m zx0 zx1) : zxperm_db. + + +(* Making proportional_of_eq_perm usable, mostly through a series of tactics to + deal with the absolute nightmare that is definitional equality casts. *) +Lemma prop_iff_double_cast : forall {n0 m0} n1 m1 (zx0 zx1 : ZX n0 m0) + (prfn: n1 = n0) (prfm : m1 = m0), + Proportional.proportional zx0 zx1 <-> + Proportional.proportional (cast n1 m1 prfn prfm zx0) (cast _ _ prfn prfm zx1). +Proof. + intros. + subst. + reflexivity. +Qed. + +Ltac __cast_prop_sides_to_square := + match goal with + | |- Proportional.proportional ?zx0 ?zx1 => + match type of zx0 with + | ZX ?n ?n => idtac + | ZX ?n ?m => + let Hm0n := fresh "Hm0n" in + assert (Hm0n : n = m) by lia; + rewrite (prop_iff_double_cast n n zx0 zx1 (eq_refl) (Hm0n)) + end + end. + +Lemma cast_compose_eq : forall n0 n1 m o0 o1 (zx0 : ZX n0 m) (zx1 : ZX m o0) Hn0n1 Ho0o1, + cast n1 o1 Hn0n1 Ho0o1 (zx0 ⟷ zx1) = + (cast n1 m Hn0n1 (@eq_refl _ m) zx0) ⟷ (cast m o1 (@eq_refl _ m) Ho0o1 zx1). +Proof. + intros. + subst. + reflexivity. +Qed. + +Lemma cast_cast_eq : forall n0 m0 n1 m1 n2 m2 (zx : ZX n0 m0) Hn0n1 Hm0m1 Hn1n2 Hm1m2, + let Hn0n2 := eq_trans Hn1n2 Hn0n1 in + let Hm0m2 := eq_trans Hm1m2 Hm0m1 in + cast n2 m2 Hn1n2 Hm1m2 (cast n1 m1 Hn0n1 Hm0m1 zx) = + cast n2 m2 Hn0n2 Hm0m2 zx. +Proof. + intros; subst. + reflexivity. +Qed. + +Lemma cast_id_eq : forall n m (prfn : n = n) (prfm : m = m) zx, + cast n m prfn prfm zx = zx. +Proof. + intros; subst. + rewrite (Eqdep_dec.UIP_refl_nat n prfn). (* Replace prfn with (@eq_refl nat n) *) + rewrite (Eqdep_dec.UIP_refl_nat m prfm). (* Replace prfn with (@eq_refl nat m) *) + reflexivity. +Qed. + +Lemma zxperm_iff_cast' : forall n0 n1 zx (H H' : n1 = n0), + ZXperm n1 (cast n1 n1 H H' zx) <-> ZXperm n0 zx. +Proof. + intros. + subst; rewrite cast_id_eq. + reflexivity. +Qed. + +#[export] Hint Resolve <- zxperm_iff_cast' : zxperm_db. + +Ltac simpl_permlike_zx := + let simpl_casts_eq := first [ + rewrite cast_id_eq | + rewrite cast_cast_eq ] + in + repeat (match goal with + | |- context[?zx ⟷ cast ?m' ?o' ?prfm ?prfo (n_wire ?o)] => + rewrite (@CastRules.cast_compose_r _ _ _ _ _ prfm prfo zx _); + rewrite (@ComposeRules.nwire_removal_r o) + | |- context[cast ?n' ?m' ?prfn ?prfm (n_wire ?n) ⟷ ?zx] => + rewrite (@CastRules.cast_compose_l _ _ _ _ _ prfn prfm _ zx); + rewrite (@ComposeRules.nwire_removal_l n) + | |- context[@cast ?n' ?m' ?n ?m ?prfn ?prfm ?zx ⟷ cast ?m' ?o' ?prfom ?prfo (n_wire ?o)] => + rewrite (@CastRules.cast_compose_l n n' m m' o' prfn prfm zx (cast m' o' prfom prfo (n_wire o))); + rewrite (cast_cast_eq _ _ _ _ _ _ (n_wire o)); + try rewrite (cast_id_eq _ _ _ _ (zx ⟷ _)) + | |- context[cast ?n ?m' ?prfn ?prfmn (n_wire ?n') ⟷ @cast ?m' ?o' ?m ?o ?prfm ?prfo ?zx] => + rewrite (@CastRules.cast_compose_r n m m' o o' prfm prfo (cast n m prfn prfmn (n_wire n')) zx); + rewrite (cast_cast_eq _ _ _ _ _ _ (n_wire n')); + try rewrite (cast_id_eq _ _ _ _ (zx ⟷ _)) + | |- context[cast ?n1 ?m _ _ ?zx0 ⟷ cast ?m ?o1 _ _ ?zx1] => + rewrite <- (cast_compose_eq _ n1 m _ o1 zx0 zx1) + | |- context[ @cast ?n1 ?m1 ?n0 ?m0 ?prfn0 ?prfm0 ?zx0 ⟷ cast ?m1 ?o1 ?prfm1 ?prfo1 ?zx1 ] => + rewrite (CastRules.cast_compose_mid m0 (eq_sym prfm0) (eq_sym prfm0) (cast n1 m1 prfn0 prfm0 zx0) (cast m1 o1 prfm1 prfo1 zx1)); + rewrite + (cast_cast_eq _ _ _ _ _ _ zx0), (cast_cast_eq _ _ _ _ _ _ zx1), + (cast_id_eq _ _ _ _ zx0) + end; repeat simpl_casts_eq) + || (repeat simpl_casts_eq). + +#[export] Hint Extern 2 => + (repeat first [rewrite cast_id_eq | rewrite cast_cast_eq]) : zxperm_db. + +Ltac __one_round_cleanup_zxperm_of_cast := + match goal with + | |- ZXperm _ (cast ?n2 ?m2 ?Hn1n2 ?Hm1m2 (@cast ?n1 ?m1 ?n0 ?m0 ?Hn0n1 ?Hm0m1 ?zx)) => (* idtac "clean_cast_cast"; *) + rewrite (cast_cast_eq n0 m0 n1 m1 n2 m2 zx Hn0n1 Hm0m1 Hn1n2 Hm1m2) + | |- ZXperm ?n (@cast ?n ?n ?n ?n _ _ ?zx) => (* idtac "clean_id"; *) + rewrite (cast_id_eq n n _ _ zx) + | |- ZXperm ?n (@cast ?n ?n ?n' ?m' _ _ (?zx0 ⟷ ?zx1)) => (* idtac "clean_comp"; *) + rewrite (cast_compose_eq _ _ _ _ _ zx0 zx1) by lia; + apply PermComp + | |- ZXperm ?n (@cast ?n ?n ?n' ?m' _ _ (?zx0 ↕ ?zx1)) => (* idtac "clean_stack"; *) + match type of zx0 with ZX ?n0 ?n0 => + match type of zx1 with ZX ?n1 ?n1 => + rewrite <- (zxperm_iff_cast' (n) (n0 + n1) (ltac:(lia)) (ltac:(lia))) + end end + end. + +#[export] Hint Extern 3 (ZXperm _ (cast _ _ _ _ _)) => __one_round_cleanup_zxperm_of_cast : zxperm_db. + +Lemma perm_of_cast_compose_each_square : forall n m a b c d + (zx0 : ZX n n) (zx1 : ZX m m) prfa0 prfb0 prfb1 prfc1 prfd1 prfd2, + ZXperm n zx0 -> ZXperm m zx1 -> + ZXperm d (cast d d prfd1 prfd2 + (cast a b prfa0 prfb0 zx0 ⟷ cast b c prfb1 prfc1 zx1)). +Proof. + intros. + subst. + auto with zxperm_db. +Qed. + +#[export] Hint Resolve perm_of_cast_compose_each_square : zxperm_db. + +(* I don't know if these actually ever help: *) +Lemma perm_of_cast_compose_each_square_l : forall n m c d + (zx0 : ZX n n) (zx1 : ZX m m) prfb1 prfc1 prfd1 prfd2, + ZXperm n zx0 -> ZXperm m zx1 -> + ZXperm d (cast d d prfd1 prfd2 + (zx0 ⟷ cast n c prfb1 prfc1 zx1)). +Proof. + intros. + subst. + auto with zxperm_db. +Qed. + +Lemma perm_of_cast_compose_each_square_r : forall n m a d + (zx0 : ZX n n) (zx1 : ZX m m) prfa0 prfm0 prfd1 prfd2, + ZXperm n zx0 -> ZXperm m zx1 -> + ZXperm d (cast d d prfd1 prfd2 + (cast a m prfa0 prfm0 zx0 ⟷ zx1)). +Proof. + intros. + subst. + auto with zxperm_db. +Qed. + + +(* #[export] Hint Resolve perm_of_cast_compose_each_square_l + perm_of_cast_compose_each_square_r : zxperm_db. *) + + +(* This can't be here because proportional_of_eq_perm is defined later, but keeping + for reference. (This is put in ZXpermSemantics, right after proportional_of_eq_perm.) *) + +(* +Ltac prop_perm_eq := + intros; + simpl_casts; + simpl_permlike_zx; + __cast_prop_sides_to_square; + (* Goal: zx0 ∝ zx1 *) + apply proportional_of_eq_perm; [ + (* New goals: *) + (*1: ZXperm _ zx0 *) auto with zxperm_db | + (*2: ZXperm _ zx1*) auto with zxperm_db | + (*3: perm_of_zx zx0 = perm_of_zx zx1*) cleanup_perm_of_zx; try easy; try lia + ]. +*) + + +(* For VyZX lemmas which create a ton of shelved goals, this solves + them immediately (and ensures they *are* solvable, + unlike auto_cast_eqn) *) +Tactic Notation "clean_eqns" tactic(tac) := + unshelve (tac); [reflexivity + lia..|]. + +Ltac print_hyps := + try (match reverse goal with | H : ?p |- _ => idtac H ":" p; fail end). + +Ltac print_goal := + match reverse goal with |- ?P => idtac P; idtac "" end. + +Ltac print_state := + print_hyps; + idtac "---------------------------------------------------------"; + print_goal. + +(* TODO: Move to QuantumLib *) +Ltac by_perm_cell := + let i := fresh "i" in + let Hi := fresh "Hi" in + intros i Hi; try solve_end; + repeat + (destruct i as [| i]; [ | apply <- Nat.succ_lt_mono in Hi ]; + try solve_end). + +Arguments Nat.leb !_ !_ /. \ No newline at end of file diff --git a/src/Permutations/ZXpermFacts.v b/src/Permutations/ZXpermFacts.v index f8e2567..63cff49 100644 --- a/src/Permutations/ZXpermFacts.v +++ b/src/Permutations/ZXpermFacts.v @@ -1,11 +1,10 @@ -Require Import ZXCore. +Require Import ZXCore CoreAutomation. Require Import StackComposeRules. Require Import CastRules. Require Export ZXperm. -Require Import PermutationAutomation. -Require Import PermutationSemantics. -Require Export PermutationInstances. -Require Export PermutationFacts. +Require Export ZXpermAutomation. +Require Import QuantumLib.Permutations QuantumLib.Modulus. +Require Import QuantumLib.Kronecker. Require Export ZXpermSemantics. (* In this file, we develop some tools for showing things are ZXperms and @@ -23,6 +22,7 @@ Definition zx_of_perm n f := Local Open Scope nat. Local Open Scope ZX_scope. +Local Open Scope prg. Lemma zxperm_iff_cast {n0 n1} {zx} (Hn Hn' : n1 = n0) : ZXperm n1 (cast _ _ Hn Hn' zx) <-> ZXperm n0 zx. @@ -93,6 +93,169 @@ Qed. #[export] Hint Resolve n_compose_zxperm : zxperm_db. *) +(* Showing our permutations are permutations *) +(* Section on top_to_bottom and bottom_to_top *) +Lemma bottom_to_top_perm_bounded {n} k : + k < n -> bottom_to_top_perm n k < n. +Proof. + intros Hk. + unfold bottom_to_top_perm. + replace_bool_lia (n <=? k) false. + destruct k; lia. +Qed. + +Lemma top_to_bottom_perm_bounded {n} k : + k < n -> top_to_bottom_perm n k < n. +Proof. + intros Hk. + unfold top_to_bottom_perm. + replace_bool_lia (n <=? k) false. + bdestruct (k =? n - 1); lia. +Qed. + +Global Hint Resolve bottom_to_top_perm_bounded top_to_bottom_perm_bounded : perm_bounded_db. + +Lemma bottom_to_top_WF_perm n : + WF_Perm n (bottom_to_top_perm n). +Proof. + intros k Hk. + unfold bottom_to_top_perm. + replace_bool_lia (n <=? k) true. + easy. +Qed. + +Lemma top_to_bottom_WF_perm n : + WF_Perm n (top_to_bottom_perm n). +Proof. + intros k Hk. + unfold top_to_bottom_perm. + replace_bool_lia (n <=? k) true. + easy. +Qed. + +Global Hint Resolve bottom_to_top_WF_perm top_to_bottom_WF_perm : WF_Perm_db. + +Lemma bottom_to_top_to_bottom_inv n : + bottom_to_top_perm n ∘ top_to_bottom_perm n = idn. +Proof. + apply functional_extensionality; intros k. + unfold compose, bottom_to_top_perm, top_to_bottom_perm. + bdestruct (n <=? k). + 1: replace_bool_lia (n <=? k) true; easy. + bdestruct (k =? n - 1). + - destruct n. + + easy. + + replace_bool_lia (S n <=? 0) false. + lia. + - replace_bool_lia (n <=? k + 1) false. + replace (k + 1) with (S k) by lia. + easy. +Qed. + +Lemma top_to_bottom_to_top_inv n : + top_to_bottom_perm n ∘ bottom_to_top_perm n = idn. +Proof. + apply functional_extensionality; intros k. + unfold compose, bottom_to_top_perm, top_to_bottom_perm. + bdestruct (n <=? k). + 1: replace_bool_lia (n <=? k) true; easy. + destruct k. + - destruct n; [easy|]. + replace_bool_lia (S n <=? S n - 1) false. + rewrite Nat.eqb_refl. + easy. + - replace_bool_lia (n <=? k) false. + replace_bool_lia (k =? n - 1) false. + lia. +Qed. + +Lemma bottom_to_top_to_bottom_inv' n k : + bottom_to_top_perm n (top_to_bottom_perm n k) = k. +Proof. + pose proof (bottom_to_top_to_bottom_inv n) as H. + apply (f_equal (fun g => g k)) in H. + unfold compose in H. + easy. +Qed. + +Lemma top_to_bottom_to_top_inv' n k : + top_to_bottom_perm n (bottom_to_top_perm n k) = k. +Proof. + pose proof (top_to_bottom_to_top_inv n) as H. + apply (f_equal (fun g => g k)) in H. + unfold compose in H. + easy. +Qed. + +#[export] Hint Rewrite + bottom_to_top_to_bottom_inv + bottom_to_top_to_bottom_inv' + top_to_bottom_to_top_inv + top_to_bottom_to_top_inv' + : perm_inv_db. + +Lemma top_to_bottom_permutation n : + permutation n (top_to_bottom_perm n). +Proof. + perm_by_inverse (bottom_to_top_perm n). +Qed. + +Lemma bottom_to_top_permutation n : + permutation n (bottom_to_top_perm n). +Proof. + perm_by_inverse (top_to_bottom_perm n). +Qed. + +Global Hint Resolve top_to_bottom_permutation bottom_to_top_permutation : perm_db. + +Lemma top_to_bottom_inv n : + perm_eq n (perm_inv n (top_to_bottom_perm n)) (bottom_to_top_perm n). +Proof. + perm_eq_by_inv_inj (top_to_bottom_perm n) n. +Qed. + +Lemma bottom_to_top_inv n : + perm_eq n (perm_inv n (bottom_to_top_perm n)) (top_to_bottom_perm n). +Proof. + perm_eq_by_inv_inj (bottom_to_top_perm n) n. +Qed. + +Lemma top_to_bottom_inv' n : + perm_inv' n (top_to_bottom_perm n) = bottom_to_top_perm n. +Proof. + permutation_eq_by_WF_inv_inj (top_to_bottom_perm n) n. +Qed. + +Lemma bottom_to_top_inv' n : + perm_inv' n (bottom_to_top_perm n) = top_to_bottom_perm n. +Proof. + permutation_eq_by_WF_inv_inj (bottom_to_top_perm n) n. +Qed. + +#[export] Hint Rewrite top_to_bottom_inv top_to_bottom_inv' + bottom_to_top_inv bottom_to_top_inv' : perm_inv_db. + +Lemma top_to_bottom_perm_eq_rotr n : + top_to_bottom_perm n = rotr n 1. +Proof. + apply functional_extensionality; intros k. + unfold top_to_bottom_perm, rotr. + bdestructΩ'. + - subst. + replace (n - 1 + 1) with n by lia. + rewrite Nat.Div0.mod_same; lia. + - rewrite Nat.mod_small; lia. +Qed. + +#[export] Hint Rewrite top_to_bottom_perm_eq_rotr : perm_cleanup_db. + +Lemma bottom_to_top_perm_eq_rotl n : + bottom_to_top_perm n = rotl n 1. +Proof. + permutation_eq_by_WF_inv_inj (top_to_bottom_perm n) n. +Qed. + +#[export] Hint Rewrite bottom_to_top_perm_eq_rotl : perm_cleanup_db. (* Section on specific ZXperms *) Lemma top_to_bottom_helper_zxperm n : @@ -147,7 +310,13 @@ Qed. #[export] Hint Resolve a_swap_zxperm : zxperm_db. +Lemma n_swap_zxperm n : + ZXperm n (n_swap n). +Proof. + induction n; simpl; auto with zxperm_db. +Qed. +#[export] Hint Resolve n_swap_zxperm : zxperm_db. @@ -159,7 +328,7 @@ Lemma perm_of_zx_WF {n} {zx} (H : ZXperm n zx) : Proof. induction H; intros k Hk; try easy. - simpl. - destruct k; [|destruct k]; cbn; lia. + destruct k; [|destruct k]; cbv; lia. - simpl. rewrite stack_perms_high; easy. - simpl. @@ -212,8 +381,9 @@ Lemma perm_of_zx_transpose {n} {zx} (Hzx : ZXperm n zx) : Proof. induction Hzx; [simpl; cleanup_perm_inv..| |]; simpl; - cleanup_perm_inv; - now f_equal. + cleanup_perm_inv; [| now f_equal]. + rewrite IHHzx1, IHHzx2. + now cleanup_perm_inv. Qed. #[export] Hint Rewrite @perm_of_zx_transpose @@ -253,14 +423,14 @@ Qed. Lemma perm_of_adjoint_eq_transpose {n} {zx} (H : ZXperm n zx) : perm_of_zx (zx †) = perm_of_zx (zx ⊤). Proof. - unfold adjoint. + unfold "†". cleanup_perm_of_zx. Qed. Lemma perm_of_adjoint {n} {zx} (H : ZXperm n zx) : perm_of_zx (zx †) = perm_inv' n (perm_of_zx zx). Proof. - unfold adjoint. + unfold "†". cleanup_perm_of_zx. Qed. @@ -324,9 +494,10 @@ Proof. [eq_by_WF_perm_eq 1; intros []; easy |]. simpl. cleanup_perm_of_zx. - rewrite stack_perms_idn_zx by auto with zxperm_db. unfold swap_2_perm. + rewrite stack_perms_idn_zx by auto with zxperm_db. rewrite IHn. + rewrite top_to_bottom_perm_eq_rotr. solve_modular_permutation_equalities. Qed. @@ -412,11 +583,29 @@ Lemma perm_of_a_swap n : Proof. destruct n; [cleanup_perm; easy|]. simpl. + cleanup_perm_of_zx. solve_modular_permutation_equalities. Qed. #[export] Hint Rewrite perm_of_a_swap : perm_of_zx_cleanup_db. +Lemma perm_of_n_swap n : + perm_of_zx (n_swap n) = reflect_perm n. +Proof. + induction n; [easy|]. + simpl. + rewrite IHn. + cleanup_perm_of_zx. + eq_by_WF_perm_eq (1 + n). + intros i Hi. + unfold reflect_perm. + autounfold with perm_unfold_db. + bdestructΩ'; solve_simple_mod_eqns. +Qed. + +#[export] Hint Rewrite perm_of_n_swap : perm_of_zx_cleanup_db. + + Lemma zx_to_bot_zxperm a n : ZXperm n (zx_to_bot a n). Proof. @@ -845,6 +1034,8 @@ Definition zx_comm p q : (ZX (p + q) (q + p)) := cast (p+q) (q + p) eq_refl (Nat.add_comm q p) (zx_of_perm (p + q) (rotr (p + q) p)). +Arguments zx_comm : simpl never. + Lemma zx_comm_semantics p q : ⟦ zx_comm p q ⟧ = kron_comm (2^q) (2^p). Proof. @@ -932,6 +1123,14 @@ Proof. intros [| []]; easy. Qed. +Lemma perm_of_swap : + perm_of_zx ⨉ = swap_perm 0 1 2. +Proof. + easy. +Qed. + +#[export] Hint Rewrite perm_of_swap : perm_of_zx_cleanup_db. + Lemma swap_pullthrough_l {n m} (zx0 : ZX n 1) (zx1 : ZX m 1) : (zx0 ↕ zx1) ⟷ ⨉ ∝ zx_comm n m ⟷ (zx1 ↕ zx0). @@ -964,8 +1163,6 @@ Proof. now rewrite (Peano_dec.UIP_nat _ _ Hm' eq_refl). Qed. -#[export] Hint Rewrite cast_compose_eq_mid_join : cast_simpl_db. - Lemma zx_of_perm_compose_cast_r n n' m' Hn Hm f g (Hf : permutation n f) (Hg : permutation n' g) : zx_of_perm n f ⟷ cast n m' Hn Hm (zx_of_perm n' g) ∝ @@ -1058,6 +1255,8 @@ Definition zx_gap_comm p m q : (ZX (p + m + q) (q + m + p)) := cast _ _ eq_refl (eq_sym (Nat.add_assoc _ _ _)) (zx_comm (p + m) q ⟷ (n_wire q ↕ zx_comm p m)). +Arguments zx_gap_comm : simpl never. + Lemma zx_gap_comm_pf p m q : p + m + q = q + m + p. Proof. lia. Qed. @@ -1069,7 +1268,7 @@ Lemma zx_gap_comm_defn p m q : Proof. unfold zx_gap_comm, zx_comm. rewrite <- zx_of_perm_idn. - clean_eqns rewrite cast_stack_r. + auto_cast_eqn rewrite cast_stack_r. rewrite stack_zx_of_perm by auto with perm_db. rewrite cast_compose_l, !cast_cast_eq. rewrite cast_zx_of_perm_natural_l. @@ -1087,15 +1286,7 @@ Proof. rewrite <- cast_transpose, cast_zx_of_perm. by_perm_eq. replace (q + m + p) with (p + m + q) by lia. - pose proof (fun f => proj2 (permutation_change_dims - (p + m + q) (q + (p + m)) ltac:(lia) f)). - pose proof (fun f => proj2 (permutation_change_dims - (p + m + q) (p + (q + m)) ltac:(lia) f)). - rewrite 2!perm_of_zx_of_perm_eq_WF; auto with perm_db; - [|apply compose_WF_Perm; [auto with WF_Perm_db|]..]; - [|replace (p+m+q) with (p+(q+m)) by lia - | replace (p+m+q) with (q+(p+m)) by lia]; - [|auto with WF_Perm_db..]. + rewrite perm_of_zx_of_perm_eq_WF by cleanup_perm_inv. perm_eq_by_inv_inj (rotr (p + m + q) (p + m) ∘ stack_perms q (p + m) idn (rotr (p + m) p)) (p + m + q). replace (p + m + q) with ((q + m) + p) by lia. @@ -1103,13 +1294,14 @@ Proof. replace (q + m + p) with (p + m + q) by lia. rewrite <- stack_perms_rotr_natural by cleanup_perm. cleanup_perm. - rewrite 3!rotr_add_l_eq. + rewrite 3!rotr_add_l. + (* rewrite 3!rotr_add_l_eq. *) replace (p + m + q) with (q + m + p) by lia. - rewrite rotr_add_l_eq. + rewrite rotr_add_l. rewrite <- !compose_assoc. intros k Hk. unfold compose at 1. - simplify_bools_lia_one_kernel. + unfold big_swap_perm. repeat (bdestructΩ'; unfold compose at 1). Qed. @@ -1139,7 +1331,7 @@ Proof. rewrite cast_compose_r, cast_id, <- stack_compose_distr. rewrite zx_comm_commutes_r, nwire_removal_r. rewrite <- (nwire_removal_l zx2) at 1. - clean_eqns rewrite stack_compose_distr, stack_assoc_back. + auto_cast_eqn rewrite stack_compose_distr, stack_assoc_back. rewrite (cast_compose_r _ _ (_ ↕ _)). simpl_casts. rewrite <- compose_assoc. @@ -1167,12 +1359,10 @@ Proof. rewrite zx_gap_comm_defn, cast_id. by_perm_eq. rewrite Nat.add_sub. - rewrite perm_of_zx_of_perm_eq_WF - by (rewrite (Nat.add_comm 1 m), Nat.add_comm; cleanup_perm_inv). + rewrite 2!rotr_add_l. rewrite stack_perms_idn_f. - rewrite 2!rotr_add_l_eq. intros k Hk; unfold compose. - unfold swap_perm. + unfold big_swap_perm, swap_perm. rewrite (Nat.add_comm 1 m). bdestructΩ'. Qed. @@ -1517,227 +1707,3 @@ Proof. <- compose_assoc, <- !stack_compose_distr. now rewrite ?nwire_removal_l, ?nwire_removal_r. Qed. - -(* Section on X / Z absorbtion *) - -Import SwapRules ZXRules. - -Lemma X_cast_r_to_refl n m α {m' o' o} (zx : ZX m' o') Hm Ho : - X n m α ⟷ cast m o Hm Ho zx = - X n m' α ⟷ cast m' o eq_refl Ho zx. -Proof. - now subst. -Qed. - -Lemma X_cast_r_contract n m α {m' o' o} (zx : ZX m' o') Hm Ho : - X n m α ⟷ cast m o Hm Ho zx = - cast n o eq_refl Ho (X n m' α ⟷ zx). -Proof. - now subst. -Qed. - -Lemma Z_cast_r_to_refl n m α {m' o' o} (zx : ZX m' o') Hm Ho : - Z n m α ⟷ cast m o Hm Ho zx = - Z n m' α ⟷ cast m' o eq_refl Ho zx. -Proof. - now subst. -Qed. - -Lemma Z_cast_r_contract n m α {m' o' o} (zx : ZX m' o') Hm Ho : - Z n m α ⟷ cast m o Hm Ho zx = - cast n o eq_refl Ho (Z n m' α ⟷ zx). -Proof. - now subst. -Qed. - -Lemma X_stacked_a_swap_absorbtion_right n m0 m1 m2 α : - X n (m0 + m1 + m2) α ⟷ (n_wire m0 ↕ a_swap m1 ↕ n_wire m2) ∝ - X n (m0 + m1 + m2) α. -Proof. - (* rewrite grow_X_bot_right. *) - rewrite 2!X_add_r_base_rot, compose_assoc. - rewrite <- (nwire_removal_l (X 1 m2 0)). - rewrite stack_compose_distr, compose_assoc. - rewrite <- stack_compose_distr. - rewrite <- (stack_compose_distr (X 1 m0 0)). - rewrite 2!nwire_removal_r. - now rewrite X_a_swap_absorbtion_right_base. -Qed. - -Lemma Z_stacked_a_swap_absorbtion_right n m0 m1 m2 α : - Z n (m0 + m1 + m2) α ⟷ (n_wire m0 ↕ a_swap m1 ↕ n_wire m2) ∝ - Z n (m0 + m1 + m2) α. -Proof. - colorswap_of (X_stacked_a_swap_absorbtion_right n m0 m1 m2 α). -Qed. - -Lemma X_zx_to_bot_absorbtion_right n m α a : - X n m α ⟷ zx_to_bot a m ∝ - X n m α. -Proof. - unfold zx_to_bot. - rewrite X_cast_r_contract. - rewrite grow_X_bot_right, compose_assoc, <- stack_compose_distr. - rewrite X_a_swap_absorbtion_right_base, nwire_removal_l. - rewrite <- grow_X_bot_right. - now simpl_casts. -Qed. - -Lemma Z_zx_to_bot_absorbtion_right n m α a : - Z n m α ⟷ zx_to_bot a m ∝ - Z n m α. -Proof. - colorswap_of (X_zx_to_bot_absorbtion_right n m α a). -Qed. - -Lemma X_zx_of_swap_list_absorbtion_right n α l : - X n (length l) α ⟷ zx_of_swap_list l ∝ - X n (length l) α. -Proof. - revert n α; - induction l; intros n α. - - simpl. - now cleanup_zx. - - simpl. - rewrite <- compose_assoc. - rewrite X_zx_to_bot_absorbtion_right. - rewrite X_cast_r_contract. - rewrite X_add_r_base_rot, compose_assoc. - rewrite <- (stack_compose_distr (X 1 (length l) 0)). - rewrite wire_removal_r, IHl. - rewrite <- X_add_r_base_rot. - now simpl_casts. -Qed. - -Lemma Z_zx_of_swap_list_absorbtion_right n α l : - Z n (length l) α ⟷ zx_of_swap_list l ∝ - Z n (length l) α. -Proof. - colorswap_of (X_zx_of_swap_list_absorbtion_right n α l). -Qed. - -Section Absorbtion. -(* This is a section only to localize the following hint, - which may be too costly to want to use globally *) - -Local Hint Rewrite @zxperm_colorswap_eq using auto with zxperm_db : - colorswap_db. - -Lemma X_zx_of_perm_absorbtion_right n m α f : - X n m α ⟷ zx_of_perm m f ∝ - X n m α. -Proof. - unfold zx_of_perm. - rewrite X_cast_r_contract. - unfold zx_of_perm_uncast. - rewrite X_zx_of_swap_list_absorbtion_right. - now simpl_casts. -Qed. - -Lemma Z_zx_of_perm_absorbtion_right n m α f : - Z n m α ⟷ zx_of_perm m f ∝ - Z n m α. -Proof. - colorswap_of (X_zx_of_perm_absorbtion_right n m α f). -Qed. - -Lemma X_zxperm_absorbtion_right n m α - (zx : ZX m m) (Hzx : ZXperm m zx) : - X n m α ⟷ zx ∝ - X n m α. -Proof. - rewrite <- (zx_of_perm_of_zx Hzx). - apply X_zx_of_perm_absorbtion_right. -Qed. - -Lemma Z_zxperm_absorbtion_right n m α - (zx : ZX m m) (Hzx : ZXperm m zx) : - Z n m α ⟷ zx ∝ - Z n m α. -Proof. - colorswap_of (X_zxperm_absorbtion_right n m α zx Hzx). -Qed. - -Lemma X_zxperm_absorbtion_left n m α - (zx : ZX n n) (Hzx : ZXperm n zx) : - zx ⟷ X n m α ∝ - X n m α. -Proof. - transpose_of (X_zxperm_absorbtion_right m n α - (zx⊤) (transpose_zxperm Hzx)). -Qed. - -Lemma Z_zxperm_absorbtion_left n m α - (zx : ZX n n) (Hzx : ZXperm n zx) : - zx ⟷ Z n m α ∝ - Z n m α. -Proof. - transpose_of (Z_zxperm_absorbtion_right m n α - (zx⊤) (transpose_zxperm Hzx)). -Qed. - -End Absorbtion. - -Lemma X_zx_comm_absorbtion_right n p q α : - X n (p + q) α ⟷ zx_comm p q ∝ - X n (q + p) α. -Proof. - unfold zx_comm. - rewrite X_cast_r_contract, X_zx_of_perm_absorbtion_right. - now simpl_casts. -Qed. - -Lemma Z_zx_comm_absorbtion_right n p q α : - Z n (p + q) α ⟷ zx_comm p q ∝ - Z n (q + p) α. -Proof. - colorswap_of (X_zx_comm_absorbtion_right n p q α). -Qed. - -Lemma X_zx_comm_absorbtion_left p q m α : - zx_comm p q ⟷ X (q + p) m α ∝ - X (p + q) m α. -Proof. - transpose_of (X_zx_comm_absorbtion_right m q p α). -Qed. - -Lemma Z_zx_comm_absorbtion_left p q m α : - zx_comm p q ⟷ Z (q + p) m α ∝ - Z (p + q) m α. -Proof. - colorswap_of (X_zx_comm_absorbtion_left p q m α). -Qed. - -Lemma X_zx_gap_comm_absorbtion_right n p m q α : - X n (p + m + q) α ⟷ zx_gap_comm p m q ∝ - X n (q + m + p) α. -Proof. - unfold zx_gap_comm. - rewrite X_cast_r_contract. - rewrite <- compose_assoc, X_zx_comm_absorbtion_right. - rewrite grow_X_bot_right, compose_assoc, <- stack_nwire_distribute_l. - rewrite X_zx_comm_absorbtion_right. - rewrite <- grow_X_bot_right. - now simpl_casts. -Qed. - -Lemma Z_zx_gap_comm_absorbtion_right n p m q α : - Z n (p + m + q) α ⟷ zx_gap_comm p m q ∝ - Z n (q + m + p) α. -Proof. - colorswap_of (X_zx_gap_comm_absorbtion_right n p m q α). -Qed. - -Lemma X_zx_gap_comm_absorbtion_left p n q m α : - zx_gap_comm p n q ⟷ X (q + n + p) m α ∝ - X (p + n + q) m α. -Proof. - transpose_of (X_zx_gap_comm_absorbtion_right m q n p α). -Qed. - -Lemma Z_zx_gap_comm_absorbtion_left p n q m α : - zx_gap_comm p n q ⟷ Z (q + n + p) m α ∝ - Z (p + n + q) m α. -Proof. - colorswap_of (X_zx_gap_comm_absorbtion_left p n q m α). -Qed. diff --git a/src/Permutations/ZXpermSemantics.v b/src/Permutations/ZXpermSemantics.v index 3618838..68be0e5 100644 --- a/src/Permutations/ZXpermSemantics.v +++ b/src/Permutations/ZXpermSemantics.v @@ -1,13 +1,9 @@ Require Import ZXCore. Require Import CastRules. -Require Import PermutationFacts. -Require Import PermutationInstances. -Require Import ZXperm. -Require Import PermutationAuxiliary. -Require Import PermutationAutomation. -Require Import PermMatrixFacts. -Require Import PermutationSemantics. -Require Import CoreData.Proportional. +Require Export ZXperm. +Require Import ZXpermAutomation. +Require Import QuantumLib.Permutations QuantumLib.Modulus. +Import CoreData.Proportional. Local Open Scope nat. @@ -89,7 +85,7 @@ Lemma compose_permutation_semantics {n m o} {zx0 : ZX n m} {zx1 : ZX m o} Proof. simpl. subst. - rewrite perm_to_matrix_compose by easy. + rewrite perm_to_matrix_compose by auto with perm_db. now rewrite Hzx0, Hzx1. Qed. @@ -127,7 +123,7 @@ Qed. Lemma proportional_of_perm_eq {n} {zx0 zx1 : ZX n n} (Hzx0 : ZXperm n zx0) (Hzx1 : ZXperm n zx1) - (Hperm : forall k, k < n -> perm_of_zx zx0 k = perm_of_zx zx1 k) : + (Hperm : perm_eq n (perm_of_zx zx0) (perm_of_zx zx1)) : zx0 ∝ zx1. Proof. prop_exists_nonzero (RtoC 1). @@ -135,7 +131,7 @@ Proof. rewrite (perm_of_zx_permutation_semantics Hzx0), (perm_of_zx_permutation_semantics Hzx1). apply mat_equiv_eq; auto with wf_db. - apply perm_to_matrix_perm_eq, Hperm. + apply perm_to_matrix_perm_eq; cleanup_perm. Qed. (* TODO: split intro prop_perm_eq and prop_perm_eqΩ *) @@ -177,10 +173,19 @@ Ltac by_perm_eq := (* Goal: zx0 ∝ zx1 *) apply proportional_of_perm_eq; [ (* New goals: *) - (*1: ZXperm _ zx0 *) auto 10 with zxperm_db | - (*2: ZXperm _ zx1*) auto 10 with zxperm_db | + (*1: ZXperm _ zx0 *) auto 100 with zxperm_db | + (*2: ZXperm _ zx1*) auto 100 with zxperm_db | (*3: forall k, k < n -> perm_of_zx zx0 k = perm_of_zx zx1 k *) cleanup_perm_of_zx; try easy; try lia ]. - +Ltac by_perm_eq_nosimpl := + intros; + autounfold with zxperm_db; + (* Goal: zx0 ∝ zx1 *) + apply proportional_of_perm_eq; [ + (* New goals: *) + (*1: ZXperm _ zx0 *) auto 100 with zxperm_db | + (*2: ZXperm _ zx1*) auto 100 with zxperm_db | + + ]. diff --git a/src/Quarantine.v b/src/Quarantine.v index 2747cf3..23f0f6f 100644 --- a/src/Quarantine.v +++ b/src/Quarantine.v @@ -81,7 +81,10 @@ Qed. Theorem trivial_cap_cup : ⊂ ⟷ ⊃ ∝ ⦰. -Proof. solve_prop 2. Qed. +Proof. + prop_exists_nonzero 2. + lma'. +Qed. Lemma cap_passthrough : forall (zx : ZX 1 1), (⊂ ⟷ (zx ↕ —)) ∝ (⊂ ⟷ (— ↕ zx⊤)). @@ -120,19 +123,9 @@ Proof. transpose_of cap_passthrough. Qed. Lemma swap_passthrough_1_1 : forall (zx0 : ZX 1 1) (zx1 : ZX 1 1), (zx0 ↕ zx1) ⟷ ⨉ ∝ ⨉ ⟷ (zx1 ↕ zx0). Proof. - intros. - prop_exists_nonzero 1. - Msimpl; simpl. - solve_matrix. - all: rewrite WF_ZX; try lca. - 1-4: left; auto. - 5,7,9,11: right; auto. - 1-4: left. - 5-8: right. - all: simpl; - apply le_n_S; - apply le_n_S; - apply Nat.le_0_l. + intros. + rewrite <- ZXpermFacts.zx_comm_1_1_swap. + apply (ZXpermFacts.zx_comm_commutes_r zx0 zx1). Qed. Lemma Z_commutes_through_swap_t : forall α, From 7b7f3fc96dba0c806e8af5078a9d29949f29f5b3 Mon Sep 17 00:00:00 2001 From: William Spencer Date: Wed, 28 Aug 2024 13:31:25 -0700 Subject: [PATCH 08/10] Fix compilation issue --- src/CoreData/SemanticCore.v | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/src/CoreData/SemanticCore.v b/src/CoreData/SemanticCore.v index fb00ac2..cdcb150 100644 --- a/src/CoreData/SemanticCore.v +++ b/src/CoreData/SemanticCore.v @@ -533,19 +533,15 @@ Proof. cbn [kron_n]. Msimpl. prep_matrix_equivalence. - rewrite make_WF_equiv. restore_dims. - rewrite Mscale_list2D_to_matrix. - cbn [map]. - restore_dims. compute_matrix (hadamard × Z_semantics 2 1 α × (hadamard ⊗ hadamard)). group_radicals. - rewrite Copp_involutive. replace (/ √ 2 * / C2 + / √ 2 * Cexp α * / C2) with (/ √ 2 * / C2 * (C1 + Cexp α)) by lca. replace (/ √ 2 * / C2 + - (/ √ 2 * Cexp α * / C2)) with (/ √ 2 * / C2 * (C1 - Cexp α)) by lca. - apply make_WF_equiv. + rewrite 2!make_WF_equiv. + by_cell; lca. Qed. Lemma X_2_1_0_semantics : X_semantics 2 1 0 = @@ -554,12 +550,12 @@ Lemma X_2_1_0_semantics : X_semantics 2 1 0 = Proof. rewrite X_2_1_semantics. prep_matrix_equivalence. + match goal with + |- ?A ≡ _ => compute_matrix A + end. rewrite 2!make_WF_equiv. - restore_dims. - rewrite Mscale_list2D_to_matrix. rewrite Cexp_0. rewrite <- Cdouble, Cmult_1_r, Cminus_diag by reflexivity. - cbn [map]. rewrite <- Cmult_assoc. now autorewrite with C_db. Qed. @@ -570,15 +566,14 @@ Lemma X_2_1_PI_semantics : X_semantics 2 1 PI = Proof. rewrite X_2_1_semantics. prep_matrix_equivalence. - rewrite 2!make_WF_equiv. - restore_dims. - rewrite Mscale_list2D_to_matrix. + match goal with + |- ?A ≡ _ => compute_matrix A + end. rewrite Cexp_PI. change (-1 : R) with (Ropp 1). rewrite RtoC_opp. autorewrite with C_db. - cbn [map]. - rewrite <- 2!Cmult_assoc. + rewrite <- Cmult_assoc. now autorewrite with C_db. Qed. From 2646ba9091bad3460b6384fba2913b2ddfc96bed Mon Sep 17 00:00:00 2001 From: William Spencer Date: Fri, 30 Aug 2024 23:32:30 -0700 Subject: [PATCH 09/10] Make ZXperm not definitionally square. --- src/CoreRules/XRules.v | 21 +- src/CoreRules/ZRules.v | 51 +- src/Gates/GateRules.v | 22 +- src/Permutations/ZXperm.v | 26 +- src/Permutations/ZXpermAutomation.v | 55 +- src/Permutations/ZXpermFacts.v | 770 +++++++++++++++++++--------- src/Permutations/ZXpermSemantics.v | 101 ++-- 7 files changed, 677 insertions(+), 369 deletions(-) diff --git a/src/CoreRules/XRules.v b/src/CoreRules/XRules.v index 1b4cbc8..9a32713 100644 --- a/src/CoreRules/XRules.v +++ b/src/CoreRules/XRules.v @@ -201,16 +201,17 @@ Lemma X_zx_of_perm_absorbtion_right n m α f : X n m α ⟷ zx_of_perm m f ∝ X n m α. Proof. colorswap_of (Z_zx_of_perm_absorbtion_right n m α f). Qed. -Lemma X_zxperm_absorbtion_right n m α (zx : ZX m m) (Hzx : ZXperm m zx) : - X n m α ⟷ zx ∝ X n m α. -Proof. colorswap_of (Z_zxperm_absorbtion_right n m α zx Hzx). Qed. - -Lemma X_zxperm_absorbtion_left n m α (zx : ZX n n) (Hzx : ZXperm n zx) : - zx ⟷ X n m α ∝ X n m α. -Proof. - transpose_of (X_zxperm_absorbtion_right m n α - (zx⊤) (transpose_zxperm Hzx)). -Qed. +Lemma X_zx_of_perm_cast_absorbtion_right n m o α f H : + X n m α ⟷ zx_of_perm_cast m o f H ∝ X n o α. +Proof. colorswap_of (Z_zx_of_perm_cast_absorbtion_right n m o α f H). Qed. + +Lemma X_zxperm_absorbtion_right n m o α (zx : ZX m o) (Hzx : ZXperm zx) : + X n m α ⟷ zx ∝ X n o α. +Proof. colorswap_of (Z_zxperm_absorbtion_right n m o α zx Hzx). Qed. + +Lemma X_zxperm_absorbtion_left n m o α (zx : ZX n m) (Hzx : ZXperm zx) : + zx ⟷ X m o α ∝ X n o α. +Proof. colorswap_of (Z_zxperm_absorbtion_left n m o α (zx) (Hzx)). Qed. End Absorbtion. diff --git a/src/CoreRules/ZRules.v b/src/CoreRules/ZRules.v index c7f6517..fc869a6 100644 --- a/src/CoreRules/ZRules.v +++ b/src/CoreRules/ZRules.v @@ -732,21 +732,29 @@ Proof. now simpl_casts. Qed. -Lemma Z_zxperm_absorbtion_right n m α - (zx : ZX m m) (Hzx : ZXperm m zx) : - Z n m α ⟷ zx ∝ - Z n m α. +Lemma Z_zx_of_perm_cast_absorbtion_right n m o α f H : + Z n m α ⟷ zx_of_perm_cast m o f H ∝ + Z n o α. Proof. - rewrite <- (zx_of_perm_of_zx Hzx). + subst. apply Z_zx_of_perm_absorbtion_right. Qed. -Lemma Z_zxperm_absorbtion_left n m α - (zx : ZX n n) (Hzx : ZXperm n zx) : - zx ⟷ Z n m α ∝ - Z n m α. +Lemma Z_zxperm_absorbtion_right n m o α + (zx : ZX m o) (Hzx : ZXperm zx) : + Z n m α ⟷ zx ∝ + Z n o α. Proof. - transpose_of (Z_zxperm_absorbtion_right m n α + rewrite (zxperm_to_zx_of_perm_cast zx Hzx). + apply Z_zx_of_perm_cast_absorbtion_right. +Qed. + +Lemma Z_zxperm_absorbtion_left n m o α + (zx : ZX n m) (Hzx : ZXperm zx) : + zx ⟷ Z m o α ∝ + Z n o α. +Proof. + transpose_of (Z_zxperm_absorbtion_right o m n α (zx⊤) (transpose_zxperm Hzx)). Qed. @@ -754,9 +762,7 @@ Lemma Z_zx_comm_absorbtion_right n p q α : Z n (p + q) α ⟷ zx_comm p q ∝ Z n (q + p) α. Proof. - unfold zx_comm. - rewrite cast_Z_contract_r, Z_zx_of_perm_absorbtion_right. - now simpl_casts. + apply Z_zxperm_absorbtion_right; auto_zxperm. Qed. Lemma Z_zx_comm_absorbtion_left p q m α : @@ -768,13 +774,7 @@ Lemma Z_zx_gap_comm_absorbtion_right n p m q α : Z n (p + m + q) α ⟷ zx_gap_comm p m q ∝ Z n (q + m + p) α. Proof. - unfold zx_gap_comm. - rewrite cast_Z_contract_r. - rewrite <- compose_assoc, Z_zx_comm_absorbtion_right. - rewrite grow_Z_bot_right, compose_assoc, <- stack_nwire_distribute_l. - rewrite Z_zx_comm_absorbtion_right. - rewrite <- grow_Z_bot_right. - now simpl_casts. + apply Z_zxperm_absorbtion_right; auto_zxperm. Qed. Lemma Z_zx_gap_comm_absorbtion_left p n q m α : @@ -801,22 +801,21 @@ Proof. rewrite <- stack_wire_distribute_l. rewrite Z_zxperm_absorbtion_left by auto with zxperm_db. apply compose_simplify; [|easy]. - unfold zx_comm. + unfold zx_comm, zx_of_perm_cast. simpl_casts. by_perm_eq_nosimpl. rewrite perm_of_bottom_to_top_eq. change (S (1 + n)) with (1 + (1 + n))%nat. rewrite (Nat.add_comm 1 (1 + n)). - cleanup_perm_of_zx. - rewrite rotl_eq_rotr_sub. - rewrite Nat.mod_small by lia. - now rewrite Nat.add_sub. + rewrite perm_of_zx_of_perm_eq, + bottom_to_top_perm_eq_rotl by auto_perm. + now rewrite rotl_add_r. Qed. Lemma Z_n_swap_absorbtion_right_base : forall n m α, Z n m α ⟷ n_swap m ∝ Z n m α. Proof. intros. - apply Z_zxperm_absorbtion_right; auto with zxperm_db. + apply Z_zxperm_absorbtion_right; auto_zxperm. Qed. Lemma Z_n_wrap_under_r_base_unswapped : forall n m α, Z (n + m) 0 α ∝ (Z n m α ↕ n_wire m) ⟷ n_cup_unswapped m. diff --git a/src/Gates/GateRules.v b/src/Gates/GateRules.v index d9ac509..cc69887 100644 --- a/src/Gates/GateRules.v +++ b/src/Gates/GateRules.v @@ -208,14 +208,15 @@ Proof. rewrite !compose_assoc. rewrite (swap_pullthrough_l — (X 2 1 0)). rewrite <- (compose_assoc (zx_comm 1 2)). - unfold zx_comm. + unfold zx_comm, zx_of_perm_cast. simpl_casts. rewrite compose_zx_of_perm by auto with perm_db. - assert (H : perm_eq (1 + 2) (rotr (1 + 2) 1 ∘ rotr (1 + 2) 1)%prg + assert (H : perm_eq (1 + 2) + (big_swap_perm 2 1 ∘ big_swap_perm 2 1)%prg (big_swap_perm 1 2)) - by (rewrite rotr_add_l; - intros [|[|[|]]]; [reflexivity..|lia]). + by (by_perm_cell; reflexivity). rewrite H. + clear H. rewrite <- (compose_assoc _ _ (2 ↑ □)). rewrite <- colorswap_is_bihadamard. simpl. @@ -281,13 +282,13 @@ Proof. rewrite !compose_assoc. rewrite (swap_pullthrough_l — (X 2 1 0)). rewrite <- (compose_assoc (zx_comm 1 2)). - unfold zx_comm. + unfold zx_comm, zx_of_perm_cast. simpl_casts. rewrite compose_zx_of_perm by auto with perm_db. - assert (H : perm_eq (1 + 2) (rotr (1 + 2) 1 ∘ rotr (1 + 2) 1)%prg + assert (H : perm_eq (1 + 2) + (big_swap_perm 2 1 ∘ big_swap_perm 2 1)%prg (big_swap_perm 1 2)) - by (rewrite rotr_add_l; - intros [|[|[|]]]; [reflexivity..|lia]). + by (by_perm_cell; reflexivity). rewrite H. clear H. assert (H : zx_of_perm (1 + 2) (big_swap_perm 1 2) ∝ — ↕ ⨉ ⟷ (⨉ ↕ —)). 1: { @@ -310,10 +311,11 @@ Proof. rewrite !compose_assoc. rewrite (swap_pullthrough_l (Z 2 1 0) —). rewrite <- (compose_assoc (zx_comm 2 1)). - unfold zx_comm. + unfold zx_comm, zx_of_perm_cast. simpl_casts. rewrite compose_zx_of_perm by auto with perm_db. - assert (H : perm_eq (2 + 1) (rotr (2 + 1) 2 ∘ rotr (2 + 1) 2)%prg + assert (H : perm_eq (2 + 1) + (big_swap_perm 1 2 ∘ big_swap_perm 1 2)%prg (big_swap_perm 2 1)) by (by_perm_cell; reflexivity). rewrite H. diff --git a/src/Permutations/ZXperm.v b/src/Permutations/ZXperm.v index b40e238..c366040 100644 --- a/src/Permutations/ZXperm.v +++ b/src/Permutations/ZXperm.v @@ -5,14 +5,16 @@ Open Scope ZX_scope. (* @nocheck name *) (* Allowing combination of Z and X; will check before push *) -Inductive ZXperm : forall n, ZX n n -> Prop := - | PermEmpty : ZXperm 0 Empty - | PermWire : ZXperm 1 Wire - | PermSwap : ZXperm 2 ⨉ - | PermStack {n0 n1 zx0 zx1} : - (ZXperm n0 zx0) -> (ZXperm n1 zx1) -> ZXperm _ (zx0 ↕ zx1) - | PermComp {n zx0 zx1} : - (ZXperm n zx0) -> (ZXperm n zx1) -> ZXperm _ (zx0 ⟷ zx1). +Inductive ZXperm : forall {n m}, ZX n m -> Prop := + | PermEmpty : ZXperm Empty + | PermWire : ZXperm Wire + | PermSwap : ZXperm ⨉ + | PermStack {n0 m0 n1 m1} (zx0 : ZX n0 m0) (zx1 : ZX n1 m1) : + ZXperm zx0 -> ZXperm zx1 -> + ZXperm (zx0 ↕ zx1) + | PermComp {n m o} (zx0 : ZX n m) (zx1 : ZX m o) : + ZXperm zx0 -> ZXperm zx1 -> + ZXperm (zx0 ⟷ zx1). @@ -50,20 +52,20 @@ Definition top_to_bottom_perm (n : nat) : nat -> nat := Definition a_perm (n : nat) : nat -> nat := swap_perm 0 (n-1) n. -Lemma zx_to_bot_helper : forall a n, +Lemma zx_to_bot_pf : forall a n, n = (n - a + Init.Nat.min a n)%nat. Proof. intros a n; lia. Qed. Definition zx_to_bot (a n : nat) : ZX n n := - cast _ _ (zx_to_bot_helper (n-a) n) (zx_to_bot_helper (n-a) n) + cast _ _ (zx_to_bot_pf (n-a) n) (zx_to_bot_pf (n-a) n) ((n_wire (n - (n-a))) ↕ a_swap (min (n-a) n)). -Lemma zx_to_bot'_helper a n (H : (a < n)%nat) : +Lemma zx_to_bot'_pf a n (H : (a < n)%nat) : n = (a + (n - a))%nat. Proof. lia. Qed. Definition zx_to_bot' (a n : nat) (H : (a < n)%nat) : ZX n n := - cast _ _ (zx_to_bot'_helper a n H) (zx_to_bot'_helper a n H) + cast _ _ (zx_to_bot'_pf a n H) (zx_to_bot'_pf a n H) (n_wire a ↕ a_swap (n-a)). Fixpoint zx_of_swap_list (l : list nat) : ZX (length l) (length l) := diff --git a/src/Permutations/ZXpermAutomation.v b/src/Permutations/ZXpermAutomation.v index 281d58f..08a5881 100644 --- a/src/Permutations/ZXpermAutomation.v +++ b/src/Permutations/ZXpermAutomation.v @@ -22,11 +22,11 @@ Ltac __cleanup_stack_perm zx0 zx1 := apply (PermStack (n0:=n0) (n1:=n1)) end end. -#[export] Hint Extern 0 (ZXperm _ (?zx0 ↕ ?zx1)) => +#[export] Hint Extern 0 (ZXperm (?zx0 ↕ ?zx1)) => __cleanup_stack_perm zx0 zx1 : zxperm_db. -#[export] Hint Extern 0 (ZXperm _ (@Stack ?n _ ?m _ ?zx0 ?zx1)) => - apply (@PermStack n m zx0 zx1) : zxperm_db. +#[export] Hint Extern 0 (ZXperm (@Stack ?n0 ?m0 ?n1 ?m1 ?zx0 ?zx1)) => + apply (@PermStack n0 m0 n1 m1 zx0 zx1) : zxperm_db. (* Making proportional_of_eq_perm usable, mostly through a series of tactics to @@ -41,7 +41,7 @@ Proof. reflexivity. Qed. -Ltac __cast_prop_sides_to_square := +(* Ltac __cast_prop_sides_to_square := match goal with | |- Proportional.proportional ?zx0 ?zx1 => match type of zx0 with @@ -51,7 +51,7 @@ Ltac __cast_prop_sides_to_square := assert (Hm0n : n = m) by lia; rewrite (prop_iff_double_cast n n zx0 zx1 (eq_refl) (Hm0n)) end - end. + end. *) Lemma cast_compose_eq : forall n0 n1 m o0 o1 (zx0 : ZX n0 m) (zx1 : ZX m o0) Hn0n1 Ho0o1, cast n1 o1 Hn0n1 Ho0o1 (zx0 ⟷ zx1) = @@ -81,12 +81,12 @@ Proof. reflexivity. Qed. -Lemma zxperm_iff_cast' : forall n0 n1 zx (H H' : n1 = n0), - ZXperm n1 (cast n1 n1 H H' zx) <-> ZXperm n0 zx. +Lemma zxperm_iff_cast' n m n' m' + (zx : ZX n m) (Hn : n' = n) (Hm : m' = m) : + ZXperm (cast n' m' Hn Hm zx) <-> ZXperm zx. Proof. intros. - subst; rewrite cast_id_eq. - reflexivity. + now subst. Qed. #[export] Hint Resolve <- zxperm_iff_cast' : zxperm_db. @@ -140,9 +140,9 @@ Ltac __one_round_cleanup_zxperm_of_cast := end end end. -#[export] Hint Extern 3 (ZXperm _ (cast _ _ _ _ _)) => __one_round_cleanup_zxperm_of_cast : zxperm_db. +(* #[export] Hint Extern 3 (ZXperm (cast _ _ _ _ _)) => __one_round_cleanup_zxperm_of_cast : zxperm_db. *) -Lemma perm_of_cast_compose_each_square : forall n m a b c d +(* Lemma perm_of_cast_compose_each_square : forall n m a b c d (zx0 : ZX n n) (zx1 : ZX m m) prfa0 prfb0 prfb1 prfc1 prfd1 prfd2, ZXperm n zx0 -> ZXperm m zx1 -> ZXperm d (cast d d prfd1 prfd2 @@ -153,10 +153,10 @@ Proof. auto with zxperm_db. Qed. -#[export] Hint Resolve perm_of_cast_compose_each_square : zxperm_db. +#[export] Hint Resolve perm_of_cast_compose_each_square : zxperm_db. *) (* I don't know if these actually ever help: *) -Lemma perm_of_cast_compose_each_square_l : forall n m c d +(* Lemma perm_of_cast_compose_each_square_l : forall n m c d (zx0 : ZX n n) (zx1 : ZX m m) prfb1 prfc1 prfd1 prfd2, ZXperm n zx0 -> ZXperm m zx1 -> ZXperm d (cast d d prfd1 prfd2 @@ -176,7 +176,7 @@ Proof. intros. subst. auto with zxperm_db. -Qed. +Qed. *) (* #[export] Hint Resolve perm_of_cast_compose_each_square_l @@ -228,4 +228,29 @@ Ltac by_perm_cell := (destruct i as [| i]; [ | apply <- Nat.succ_lt_mono in Hi ]; try solve_end). -Arguments Nat.leb !_ !_ /. \ No newline at end of file +Arguments Nat.leb !_ !_ /. + +(* FIXME: Move to Qlib *) +Ltac auto_perm_to n := + auto n with perm_db perm_bounded_db WF_Perm_db perm_inv_db. + +Ltac auto_perm := + auto 6 with perm_db perm_bounded_db WF_Perm_db perm_inv_db. + +Tactic Notation "auto_perm" int_or_var(n) := + auto_perm_to n. + +Tactic Notation "auto_perm" := + auto_perm 6. + +Ltac auto_zxperm_to n := + auto n with zxperm_db perm_db perm_bounded_db WF_Perm_db perm_inv_db. + +Ltac auto_zxperm n := + auto 6 with zxperm_db perm_db perm_bounded_db WF_Perm_db perm_inv_db. + +Tactic Notation "auto_zxperm" int_or_var(n) := + auto_zxperm_to n. + +Tactic Notation "auto_zxperm" := + auto_zxperm 6. diff --git a/src/Permutations/ZXpermFacts.v b/src/Permutations/ZXpermFacts.v index 63cff49..b70c932 100644 --- a/src/Permutations/ZXpermFacts.v +++ b/src/Permutations/ZXpermFacts.v @@ -1,10 +1,10 @@ Require Import ZXCore CoreAutomation. -Require Import StackComposeRules. Require Import CastRules. Require Export ZXperm. Require Export ZXpermAutomation. Require Import QuantumLib.Permutations QuantumLib.Modulus. Require Import QuantumLib.Kronecker. +Require Import StackComposeRules. Require Export ZXpermSemantics. (* In this file, we develop some tools for showing things are ZXperms and @@ -18,57 +18,52 @@ Definition zx_of_perm n f := (eq_sym (length_insertion_sort_list n (perm_inv n f))) (zx_of_perm_uncast n f). +(* Though redundant with cast, this makes for much better + proof statements, e.g. with compose_zx_of_perm_cast. + Since many of our ZXperms are non-square, this is + a common application. *) +Definition zx_of_perm_cast n m f (H : n = m) : ZX n m := + cast n m eq_refl (eq_sym H) (zx_of_perm n f). + +Arguments zx_of_perm_cast : simpl never. + +Notation "'zx_of_perm_cast' n m f '$'" := + (zx_of_perm_cast n m f _) + (at level 10, n at level 9, m at level 9, f at level 9, + only printing) : ZX_scope. + (* Section on very general ZXperm facts *) Local Open Scope nat. Local Open Scope ZX_scope. Local Open Scope prg. -Lemma zxperm_iff_cast {n0 n1} {zx} (Hn Hn' : n1 = n0) : - ZXperm n1 (cast _ _ Hn Hn' zx) <-> ZXperm n0 zx. -Proof. - split; intros; subst; - rewrite cast_id_eq in *; easy. -Qed. - -#[export] Hint Resolve <- zxperm_iff_cast : zxperm_db. - -Lemma cast_stack_zxperm {n0 n1 o} {zx0} {zx1} - (H0 : ZXperm n0 zx0) (H1 : ZXperm n1 zx1) - (Hn Hn' : o = n0 + n1) : - ZXperm o (cast _ _ Hn Hn' (zx0 ↕ zx1)). -Proof. - auto with zxperm_db. -Qed. - -#[export] Hint Resolve cast_stack_zxperm : zxperm_db. - -Lemma conjugate_zxperm {n} {zx} (H : ZXperm n zx) : - ZXperm n (zx ⊼). +Lemma conjugate_zxperm {n m} {zx : ZX n m} (H : ZXperm zx) : + ZXperm (zx ⊼). Proof. induction H; simpl; constructor; easy. Qed. #[export] Hint Resolve conjugate_zxperm : zxperm_db. -Lemma transpose_zxperm {n} {zx} (H : ZXperm n zx) : - ZXperm n (zx ⊤). +Lemma transpose_zxperm {n m} {zx : ZX n m} (H : ZXperm zx) : + ZXperm (zx ⊤). Proof. induction H; simpl; constructor; easy. Qed. #[export] Hint Resolve transpose_zxperm : zxperm_db. -Lemma adjoint_zxperm {n} {zx} (H : ZXperm n zx) : - ZXperm n (zx †). +Lemma adjoint_zxperm {n m} {zx : ZX n m} (H : ZXperm zx) : + ZXperm (zx †). Proof. induction H; simpl; constructor; easy. Qed. #[export] Hint Resolve adjoint_zxperm : zxperm_db. -Lemma colorswap_zxperm {n} {zx} (H : ZXperm n zx) : - ZXperm n (⊙ zx). +Lemma colorswap_zxperm {n m} {zx : ZX n m} (H : ZXperm zx) : + ZXperm (⊙ zx). Proof. induction H; simpl; constructor; easy. Qed. @@ -76,8 +71,8 @@ Qed. #[export] Hint Resolve colorswap_zxperm : zxperm_db. (* Section on core ZXperms *) -Lemma n_wire_zxperm {n} : - ZXperm n (n_wire n). +Lemma n_wire_zxperm n : + ZXperm (n_wire n). Proof. induction n; simpl; auto with zxperm_db. Qed. @@ -92,7 +87,6 @@ Qed. #[export] Hint Resolve n_compose_zxperm : zxperm_db. *) - (* Showing our permutations are permutations *) (* Section on top_to_bottom and bottom_to_top *) Lemma bottom_to_top_perm_bounded {n} k : @@ -113,7 +107,8 @@ Proof. bdestruct (k =? n - 1); lia. Qed. -Global Hint Resolve bottom_to_top_perm_bounded top_to_bottom_perm_bounded : perm_bounded_db. +#[export] Hint Resolve bottom_to_top_perm_bounded + top_to_bottom_perm_bounded : perm_bounded_db. Lemma bottom_to_top_WF_perm n : WF_Perm n (bottom_to_top_perm n). @@ -133,7 +128,8 @@ Proof. easy. Qed. -Global Hint Resolve bottom_to_top_WF_perm top_to_bottom_WF_perm : WF_Perm_db. +#[export] Hint Resolve bottom_to_top_WF_perm + top_to_bottom_WF_perm : WF_Perm_db. Lemma bottom_to_top_to_bottom_inv n : bottom_to_top_perm n ∘ top_to_bottom_perm n = idn. @@ -206,7 +202,8 @@ Proof. perm_by_inverse (top_to_bottom_perm n). Qed. -Global Hint Resolve top_to_bottom_permutation bottom_to_top_permutation : perm_db. +#[export] Hint Resolve top_to_bottom_permutation + bottom_to_top_permutation : perm_db. Lemma top_to_bottom_inv n : perm_eq n (perm_inv n (top_to_bottom_perm n)) (bottom_to_top_perm n). @@ -259,32 +256,28 @@ Qed. (* Section on specific ZXperms *) Lemma top_to_bottom_helper_zxperm n : - ZXperm (S n) (top_to_bottom_helper n). + ZXperm (top_to_bottom_helper n). Proof. - induction n. - - constructor. - - simpl. - constructor. - + apply (PermStack PermSwap n_wire_zxperm). - + apply (PermStack PermWire IHn). + induction n; cbn; auto with zxperm_db. Qed. #[export] Hint Resolve top_to_bottom_helper_zxperm : zxperm_db. Lemma top_to_bottom_zxperm {n} : - ZXperm n (top_to_bottom n). + ZXperm (top_to_bottom n). Proof. destruct n; simpl; auto with zxperm_db. Qed. Lemma bottom_to_top_zxperm {n} : - ZXperm n (bottom_to_top n). + ZXperm (bottom_to_top n). Proof. apply transpose_zxperm. apply top_to_bottom_zxperm. Qed. -#[export] Hint Resolve top_to_bottom_zxperm bottom_to_top_zxperm : zxperm_db. +#[export] Hint Resolve top_to_bottom_zxperm + bottom_to_top_zxperm : zxperm_db. (* Lemma n_top_to_bottom_zxperm : forall n m, ZXperm _ (n_top_to_bottom n m). @@ -303,7 +296,7 @@ Qed. #[export] Hint Resolve n_top_to_bottom_zxperm n_bottom_to_top_zxperm : zxperm_db. *) Lemma a_swap_zxperm n : - ZXperm n (a_swap n). + ZXperm (a_swap n). Proof. induction n; simpl; auto with zxperm_db. Qed. @@ -311,7 +304,7 @@ Qed. #[export] Hint Resolve a_swap_zxperm : zxperm_db. Lemma n_swap_zxperm n : - ZXperm n (n_swap n). + ZXperm (n_swap n). Proof. induction n; simpl; auto with zxperm_db. Qed. @@ -323,22 +316,25 @@ Qed. (* Section on rules for perm_of_zx *) -Lemma perm_of_zx_WF {n} {zx} (H : ZXperm n zx) : +Lemma perm_of_zx_WF {n m} {zx : ZX n m} (H : ZXperm zx) : WF_Perm n (perm_of_zx zx). Proof. - induction H; intros k Hk; try easy. - - simpl. - destruct k; [|destruct k]; cbv; lia. - - simpl. - rewrite stack_perms_high; easy. - - simpl. - unfold compose. - rewrite IHZXperm1; rewrite IHZXperm2; lia. + induction H using zxperm_square_induction; + cbn; auto with WF_Perm_db. +Qed. + +Lemma perm_of_zx_WF_alt {n m} {zx : ZX n m} (H : ZXperm zx) : + WF_Perm m (perm_of_zx zx). +Proof. + induction H using zxperm_square_induction; + cbn; auto with WF_Perm_db. Qed. #[export] Hint Resolve perm_of_zx_WF : WF_Perm_db. +#[export] Hint Resolve perm_of_zx_WF_alt | 10 : WF_Perm_db. -Lemma stack_perms_zx_idn {n0 n1} {zx} (H : ZXperm n0 zx) : + +Lemma stack_perms_zx_idn {n0 m0 n1} {zx : ZX n0 m0} (H : ZXperm zx) : stack_perms n0 n1 (perm_of_zx zx) idn = perm_of_zx zx. Proof. @@ -346,14 +342,18 @@ Proof. auto with WF_Perm_db. Qed. -#[export] Hint Rewrite @stack_perms_zx_idn using (auto with zxperm_db) : perm_of_zx_cleanup_db. +#[export] Hint Rewrite @stack_perms_zx_idn using + solve [auto with zxperm_db] + : perm_of_zx_cleanup_db. -Lemma stack_perms_idn_zx {n0 n1} {zx} (H : ZXperm n1 zx) : +Lemma stack_perms_idn_zx {n0 n1 m1} {zx : ZX n1 m1} (H : ZXperm zx) : stack_perms n0 n1 idn (perm_of_zx zx) = fun k => if k + solve [auto with zxperm_db] : WF_Perm_db. + +Lemma perm_of_zx_transpose {n m} {zx : ZX n m} (Hzx : ZXperm zx) : perm_of_zx (zx ⊤) = perm_inv' n (perm_of_zx zx). Proof. - induction Hzx; [simpl; cleanup_perm_inv..| |]; - simpl; - cleanup_perm_inv; [| now f_equal]. - rewrite IHHzx1, IHHzx2. - now cleanup_perm_inv. + eq_by_WF_perm_eq n. + induction Hzx using zxperm_square_induction; + cbn [ZXCore.transpose perm_of_zx]; + [by_perm_cell; reflexivity.. | |]; + rewrite IHHzx1, IHHzx2. + - now rewrite perm_inv'_stack_perms by auto_perm. + - now rewrite perm_inv'_compose by auto_perm. Qed. #[export] Hint Rewrite @perm_of_zx_transpose - using auto with zxperm_db : perm_of_zx_cleanup_db. + using solve [auto with zxperm_db] : perm_of_zx_cleanup_db. -Lemma perm_of_zx_transpose_is_rinv {n} {zx} (H : ZXperm n zx) : +Lemma perm_of_zx_transpose_is_rinv {n m} {zx : ZX n m} (H : ZXperm zx) : (perm_of_zx zx ∘ perm_of_zx zx⊤)%prg = idn. Proof. cleanup_perm_of_zx. Qed. -Lemma perm_of_zx_transpose_is_linv {n} {zx} (H : ZXperm n zx) : +Lemma perm_of_zx_transpose_is_linv {n m} {zx : ZX n m} (H : ZXperm zx) : (perm_of_zx zx⊤ ∘ perm_of_zx zx)%prg = idn. Proof. cleanup_perm_of_zx. @@ -408,36 +414,38 @@ Qed. #[export] Hint Rewrite @perm_of_zx_transpose_is_rinv @perm_of_zx_transpose_is_linv - using (auto with zxperm_db) : perm_of_zx_cleanup_db. + using solve [auto with zxperm_db] : perm_of_zx_cleanup_db. + + + + Lemma perm_of_conjugate {n m} (zx : ZX n m) : perm_of_zx (zx ⊼) = perm_of_zx zx. Proof. - induction zx; simpl; try easy. - - rewrite IHzx1, IHzx2; easy. - - rewrite IHzx1, IHzx2; easy. + induction zx; simpl; now f_equal. Qed. #[export] Hint Rewrite @perm_of_conjugate : perm_of_zx_cleanup_db. -Lemma perm_of_adjoint_eq_transpose {n} {zx} (H : ZXperm n zx) : +Lemma perm_of_adjoint_eq_transpose {n m} {zx : ZX n m} (H : ZXperm zx) : perm_of_zx (zx †) = perm_of_zx (zx ⊤). Proof. unfold "†". cleanup_perm_of_zx. Qed. -Lemma perm_of_adjoint {n} {zx} (H : ZXperm n zx) : +Lemma perm_of_adjoint {n m} {zx : ZX n m} (H : ZXperm zx) : perm_of_zx (zx †) = perm_inv' n (perm_of_zx zx). Proof. unfold "†". - cleanup_perm_of_zx. + now rewrite perm_of_zx_transpose, perm_of_conjugate by auto_zxperm. Qed. #[export] Hint Rewrite @perm_of_adjoint - using (auto with zxperm_db) : perm_of_zx_cleanup_db. + using solve [auto with zxperm_db] : perm_of_zx_cleanup_db. -Lemma zxperm_colorswap_eq {n} (zx : ZX n n) (Hzx : ZXperm n zx) : +Lemma zxperm_colorswap_eq {n m} (zx : ZX n m) (Hzx : ZXperm zx) : ⊙ zx = zx. Proof. induction Hzx; simpl; now f_equal. @@ -455,19 +463,68 @@ Qed. #[export] Hint Rewrite perm_of_n_wire : perm_of_zx_cleanup_db. -Lemma zxperm_transpose_right_inverse {n zx} (H : ZXperm n zx) : +Lemma zxperm_transpose_right_inverse {n m} (zx : ZX n m) (H : ZXperm zx) : zx ⟷ zx ⊤ ∝ n_wire n. Proof. by_perm_eq. Qed. -Lemma zxperm_transpose_left_inverse {n zx} (H : ZXperm n zx) : - zx ⊤ ⟷ zx ∝ n_wire n. +Lemma zxperm_transpose_left_inverse {n m} (zx : ZX n m) (H : ZXperm zx) : + zx ⊤ ⟷ zx ∝ n_wire m. Proof. by_perm_eq. Qed. -Lemma perm_of_zx_stack_n_wire_alt {n0} {zx} (H : ZXperm n0 zx) {n1} : +Open Scope ZX_scope. + +Lemma compose_zxperm_l {n m o} (zxp : ZX n m) (zx0 : ZX m o) + zx1 (H : ZXperm zxp) : + zxp ⟷ zx0 ∝ zx1 <-> zx0 ∝ zxp ⊤ ⟷ zx1. +Proof. + split; [intros <- | intros ->]; + rewrite <- compose_assoc, + ?zxperm_transpose_left_inverse, ?zxperm_transpose_right_inverse + by auto; + now cleanup_zx. +Qed. + +Lemma compose_zxperm_l' {n m o} (zxp : ZX n m) (zx0 : ZX m o) + zx1 (H : ZXperm zxp) : + zxp ⊤ ⟷ zx1 ∝ zx0 <-> zx1 ∝ zxp ⟷ zx0. +Proof. + split; [intros <- | intros ->]; + rewrite <- compose_assoc, + ?zxperm_transpose_left_inverse, ?zxperm_transpose_right_inverse + by auto; + now cleanup_zx. +Qed. + +Lemma compose_zxperm_r {n m o} (zxp : ZX m o) (zx0 : ZX n m) + zx1 (H : ZXperm zxp) : + zx0 ⟷ zxp ∝ zx1 <-> zx0 ∝ zx1 ⟷ zxp ⊤. +Proof. + split; [intros <- | intros ->]; + rewrite compose_assoc, + ?zxperm_transpose_left_inverse, ?zxperm_transpose_right_inverse + by auto; + now cleanup_zx. +Qed. + +Lemma compose_zxperm_r' {n m o} (zxp : ZX m o) (zx0 : ZX n m) + zx1 (H : ZXperm zxp) : + zx1 ⟷ zxp ⊤ ∝ zx0 <-> zx1 ∝ zx0 ⟷ zxp. +Proof. + split; [intros <- | intros ->]; + rewrite compose_assoc, + ?zxperm_transpose_left_inverse, ?zxperm_transpose_right_inverse + by auto; + now cleanup_zx. +Qed. + + + +Lemma perm_of_zx_stack_n_wire_alt {n0 m0} {zx : ZX n0 m0} + (H : ZXperm zx) n1 : perm_of_zx (zx ↕ (n_wire n1)) = perm_of_zx zx. Proof. simpl. @@ -476,7 +533,8 @@ Proof. easy. Qed. -Lemma perm_of_zx_stack_n_wire {n0} {zx} (H : ZXperm n0 zx) {n1} : +Lemma perm_of_zx_stack_n_wire {n0 m0} {zx : ZX n0 m0} + (H : ZXperm zx) n1 : perm_of_zx (zx ↕ (n_wire n1)) = stack_perms n0 n1 (perm_of_zx zx) (idn). Proof. @@ -485,23 +543,47 @@ Proof. Qed. #[export] Hint Rewrite @perm_of_zx_stack_n_wire - using (auto with zxperm_db) : perm_of_zx_cleanup_db. + using solve [auto with zxperm_db] : perm_of_zx_cleanup_db. + +(* FIXME: Move these two to Qlib.PermutationInstances *) +Lemma big_swap_perm_defn n m : + perm_eq (n + m) (big_swap_perm n m) + (fun k => if k if k perm_eq n (perm_of_zx (zx_of_perm_uncast n f)) f. Proof. @@ -718,7 +838,7 @@ Proof. Qed. #[export] Hint Rewrite perm_of_zx_uncast_of_perm_eq_WF - using (solve [auto with perm_db WF_Perm_db]) : perm_of_zx_cleanup_db. + using (solve [auto_perm]) : perm_of_zx_cleanup_db. Lemma perm_of_zx_of_perm_eq n f : permutation n f -> perm_eq n (perm_of_zx (zx_of_perm n f)) f. @@ -729,6 +849,26 @@ Proof. Qed. #[export] Hint Resolve perm_of_zx_of_perm_eq : perm_inv_db. +#[export] Hint Rewrite perm_of_zx_of_perm_eq + using solve [auto_perm]: perm_of_zx_cleanup_db. + +Lemma perm_of_zx_of_perm_cast_eq n m f H : permutation n f -> + perm_eq n (perm_of_zx (zx_of_perm_cast n m f H)) f. +Proof. + intros Hperm. + unfold zx_of_perm_cast. + cleanup_perm_of_zx. +Qed. + +Lemma perm_of_zx_of_perm_cast_eq_alt n m f H : permutation m f -> + perm_eq m (perm_of_zx (zx_of_perm_cast n m f H)) f. +Proof. + subst. + apply perm_of_zx_of_perm_cast_eq. +Qed. + +#[export] Hint Rewrite perm_of_zx_of_perm_cast_eq + using solve [auto_perm]: perm_of_zx_cleanup_db. Lemma perm_of_zx_of_perm_eq_WF n f : permutation n f -> WF_Perm n f -> @@ -742,39 +882,72 @@ Qed. #[export] Hint Rewrite perm_of_zx_of_perm_eq_WF using (solve [auto with perm_db WF_Perm_db]) : perm_of_zx_cleanup_db. -Lemma zx_of_perm_zxperm n f : - ZXperm n (zx_of_perm n f). +Lemma perm_of_zx_of_perm_cast_eq_WF n m f H : + permutation n f -> WF_Perm n f -> + (perm_of_zx (zx_of_perm_cast n m f H)) = f. Proof. - unfold zx_of_perm. - auto with zxperm_db. + intros Hperm HWF. + eq_by_WF_perm_eq n. + unfold zx_of_perm_cast. + cleanup_perm_of_zx. Qed. -#[export] Hint Resolve zx_of_perm_zxperm : zxperm_db. -Lemma zx_of_perm_of_zx {n zx} (H : ZXperm n zx) : + + +Lemma zx_of_perm_of_zx_square {n} (zx : ZX n n) (H : ZXperm zx) : zx_of_perm n (perm_of_zx zx) ∝ zx. Proof. by_perm_eq. Qed. -#[export] Hint Rewrite @zx_of_perm_of_zx - using auto with zxperm_db : perm_of_zx_cleanup_db. -Lemma perm_of_zx_perm_eq_of_proportional {n} {zx0 zx1 : ZX n n} - (Hzx0 : ZXperm n zx0) (Hzx1 : ZXperm n zx1) : +Lemma zx_of_perm_of_zx_cast {n m} (zx : ZX n m) (H : ZXperm zx) + prfn prfm : + cast n m prfn prfm (zx_of_perm n (perm_of_zx zx)) ∝ zx. +Proof. + by_perm_eq. +Qed. + +#[export] Hint Rewrite @zx_of_perm_of_zx_square + @zx_of_perm_of_zx_cast + using solve [auto_zxperm] : perm_of_zx_cleanup_db. + +Lemma zx_of_perm_of_zx_to_cast {n m} (zx : ZX n m) (H : ZXperm zx) : + zx_of_perm n (perm_of_zx zx) ∝ + cast n n eq_refl (zxperm_square zx H) zx. +Proof. + by_perm_eq. +Qed. + +Lemma zx_of_perm_cast_of_zx {n m} (zx : ZX n m) (H : ZXperm zx) prf : + zx_of_perm_cast n m (perm_of_zx zx) prf ∝ zx. +Proof. + subst. + rewrite zx_of_perm_cast_id. + now apply zx_of_perm_of_zx_square. +Qed. + +Lemma zxperm_to_zx_of_perm_cast {n m} (zx : ZX n m) (H : ZXperm zx) : + zx ∝ zx_of_perm_cast n m (perm_of_zx zx) (zxperm_square zx H). +Proof. + symmetry; now apply zx_of_perm_cast_of_zx. +Qed. + +Lemma perm_of_zx_perm_eq_of_proportional {n m} {zx0 zx1 : ZX n m} + (Hzx0 : ZXperm zx0) (Hzx1 : ZXperm zx1) : zx0 ∝ zx1 -> perm_eq n (perm_of_zx zx0) (perm_of_zx zx1). Proof. unfold proportional, proportional_general. - rewrite (perm_of_zx_permutation_semantics Hzx0). - rewrite (perm_of_zx_permutation_semantics Hzx1). + rewrite (perm_of_zx_permutation_semantics zx0 Hzx0). + rewrite (perm_of_zx_permutation_semantics zx1 Hzx1). intros H. - apply perm_to_matrix_perm_eq_of_proportional; - cleanup_perm_inv. + apply perm_to_matrix_perm_eq_of_proportional; auto_perm. Qed. -Lemma perm_of_zx_proper {n} {zx0 zx1 : ZX n n} - (Hzx0 : ZXperm n zx0) (Hzx1 : ZXperm n zx1) : +Lemma perm_of_zx_proper {n m} {zx0 zx1 : ZX n m} + (Hzx0 : ZXperm zx0) (Hzx1 : ZXperm zx1) : zx0 ∝ zx1 -> perm_of_zx zx0 = perm_of_zx zx1. Proof. @@ -783,26 +956,28 @@ Proof. now apply perm_of_zx_perm_eq_of_proportional. Qed. -Lemma perm_of_zx_prop_rw {n} {zx0 zx1} : +Lemma perm_of_zx_prop_rw {n m} {zx0 zx1 : ZX n m} : zx0 ∝ zx1 -> - ZXperm n zx0 -> ZXperm n zx1 -> + ZXperm zx0 -> ZXperm zx1 -> perm_of_zx zx0 = perm_of_zx zx1. Proof. intros; now apply perm_of_zx_proper. Qed. -(* Import Setoid. +(* +(* This doesn't work: *) -Add Parametric Morphism n : (@perm_of_zx n n) - with signature - (fun zx0 zx1 => zx0 ∝ zx1 /\ ZXperm n zx0 /\ ZXperm n zx1) ==> +Add Parametric Morphism n m : (@perm_of_zx n m) + with signature + on_predicate_relation_l ZXperm + proportional + (* (on_predicate_relation_l ZXperm + proportional) *) + ==> eq as perm_of_zx_proper_instance. Proof. intros zx0 zx1 (? & ? & ?); now apply perm_of_zx_proper. -Qed. - -#[export] Hint Extern 0 (_ ∝ _ /\ ZXperm _ _ /\ ZXperm _ _) => - split; [split|]; [|auto with zxperm_db..] : typeclasses_db. *) +Qed. *) (* Section on combining zx_of_perm *) @@ -812,10 +987,9 @@ Lemma compose_zx_of_perm n f g zx_of_perm n f ⟷ zx_of_perm n g ∝ zx_of_perm n (f ∘ g). Proof. (* unfold zx_of_perm. *) - by_perm_eq. - apply (fun H => perm_eq_trans H (perm_eq_sym - (perm_of_zx_of_perm_eq n (f ∘ g) ltac:(auto with perm_db)))). - apply perm_eq_compose_proper; cleanup_perm_of_zx. + by_perm_eq_nosimpl. + cbn. + now rewrite 3!perm_of_zx_of_perm_eq by auto_perm. Qed. Lemma stack_zx_of_perm n m f g @@ -829,7 +1003,47 @@ Qed. #[export] Hint Rewrite compose_zx_of_perm stack_zx_of_perm - using auto with perm_db zxperm_db : perm_of_zx_cleanup_db. + using solve [auto with perm_db zxperm_db] + : perm_of_zx_cleanup_db. + + +Lemma compose_zx_of_perm_cast n m o f g prf1 prf2 + (Hf : permutation n f) (Hg : permutation m g) : + zx_of_perm_cast n m f prf1 ⟷ zx_of_perm_cast m o g prf2 ∝ + zx_of_perm_cast n o (f ∘ g) (eq_trans prf1 prf2). +Proof. + subst; rewrite !zx_of_perm_cast_id. + now apply compose_zx_of_perm. +Qed. + +Lemma stack_zx_of_perm_cast n0 m0 n1 m1 f g prf1 prf2 + (Hf : permutation n0 f) (Hg : permutation n1 g) : + zx_of_perm_cast n0 m0 f prf1 ↕ zx_of_perm_cast n1 m1 g prf2 ∝ + zx_of_perm_cast (n0 + n1) (m0 + m1) + (stack_perms n0 n1 f g) (f_equal2 Nat.add prf1 prf2). +Proof. + subst; rewrite !zx_of_perm_cast_id. + now apply stack_zx_of_perm. +Qed. + +Lemma compose_zx_of_perm_cast_l n m f g prf + (Hf : permutation n f) (Hg : permutation m g) : + zx_of_perm_cast n m f prf ⟷ zx_of_perm m g ∝ + zx_of_perm_cast n m (f ∘ g) prf. +Proof. + subst; rewrite !zx_of_perm_cast_id. + now apply compose_zx_of_perm. +Qed. + +Lemma compose_zx_of_perm_cast_r n m f g prf + (Hf : permutation n f) (Hg : permutation n g) : + zx_of_perm n f ⟷ zx_of_perm_cast n m g prf ∝ + zx_of_perm_cast n m (f ∘ g) prf. +Proof. + subst; rewrite !zx_of_perm_cast_id. + now apply compose_zx_of_perm. +Qed. + (* TODO: Put somewhere proper *) Lemma perm_inv_le_bounded_total n f : @@ -903,6 +1117,46 @@ Qed. #[export] Hint Resolve zx_of_perm_eq_of_perm_eq zx_of_perm_prop_of_perm_eq : perm_inv_db. +Import Setoid. + +Add Parametric Morphism n : (zx_of_perm n) + with signature + perm_eq n ==> eq as zx_of_perm_perm_eq_to_eq_proper. +Proof. + intros f g Hfg. + now apply zx_of_perm_eq_of_perm_eq. +Qed. + +(* FIXME: Move *) +Definition true_rel {A} : relation A := + fun _ _ => True. + +Add Parametric Relation A : A true_rel + reflexivity proved by ltac:(easy) + symmetry proved by ltac:(easy) + transitivity proved by ltac:(easy) + as true_rel_equivalence. + +#[export] Hint Unfold true_rel : typeclass_instances. + +Add Parametric Morphism n m : (zx_of_perm_cast n m) + with signature perm_eq n ==> true_rel ==> eq + as zx_of_perm_cast_perm_eq_to_eq_proper. +Proof. + intros f g Hfg H H' ?. + unfold zx_of_perm_cast. + rewrite Hfg. + subst; now rewrite !cast_id_eq. +Qed. + +Lemma zx_of_perm_cast_prop_of_perm_eq n m f g H H' : + perm_eq n f g -> + zx_of_perm_cast n m f H ∝ zx_of_perm_cast n m g H'. +Proof. + intros ->. + now rewrite (Peano_dec.UIP_nat _ _ H H'). +Qed. + Lemma zx_of_perm_idn n : zx_of_perm n idn ∝ n_wire n. Proof. @@ -911,14 +1165,6 @@ Qed. #[export] Hint Rewrite zx_of_perm_idn : perm_of_zx_cleanup_db. -#[export] Hint Extern 0 (perm_eq _ (perm_of_zx (zx_of_perm ?n ?f)) _) => - apply (perm_eq_trans (perm_of_zx_of_perm_eq n f - ltac:(auto with perm_db zxperm_db zarith))) : perm_inv_db. - -#[export] Hint Extern 0 (perm_eq _ _ (perm_of_zx (zx_of_perm ?n ?f))) => - apply (fun G => perm_eq_trans G (perm_eq_sym (perm_of_zx_of_perm_eq n f - ltac:(auto with perm_db zxperm_db zarith)))) : perm_inv_db. - Lemma zx_of_perm_eq_idn n f : perm_eq n f idn -> zx_of_perm n f = zx_of_perm n idn. @@ -927,15 +1173,14 @@ Proof. cleanup_perm_inv. Qed. -#[export] Hint Rewrite zx_of_perm_eq_idn - using (solve [cleanup_perm_inv]): perm_of_zx_cleanup_db. +(* #[export] Hint Rewrite zx_of_perm_eq_idn + using (solve [cleanup_perm_inv]): perm_of_zx_cleanup_db. *) Lemma zx_of_perm_eq_idn_prop n f : perm_eq n f idn -> zx_of_perm n f ∝ zx_of_perm n idn. Proof. - intros H. - now cleanup_perm_of_zx. + now intros ->. Qed. Lemma cast_zx_of_perm n n' f (H H' : n = n') : @@ -948,6 +1193,23 @@ Qed. #[export] Hint Rewrite cast_zx_of_perm : cast_simpl_db perm_of_zx_cleanup_db. +Lemma cast_zx_of_perm_nonsquare n' m' n f + H H' : + cast n' m' H H' (zx_of_perm n f) = + zx_of_perm_cast n' m' f (eq_trans H (eq_sym H')). +Proof. + now subst. +Qed. + +Lemma cast_zx_of_perm_cast n' m' n m f H H' prf : + cast n' m' H H' (zx_of_perm_cast n m f prf) = + zx_of_perm_cast n' m' f (eq_trans H (eq_trans prf (eq_sym H'))). +Proof. + now subst. +Qed. + +#[export] Hint Rewrite cast_zx_of_perm_cast : perm_of_zx_cleanup_db. + Lemma cast_zx_of_perm_natural_l n n' m' f H H' : cast n' m' H H' (zx_of_perm n f) = cast n' m' eq_refl (eq_trans H' (eq_sym H)) (zx_of_perm n' f). @@ -968,7 +1230,7 @@ Lemma zx_of_perm_perm_eq_idn_removal_l {n m} f (zx : ZX n m) : perm_eq n f idn -> zx_of_perm n f ⟷ zx ∝ zx. Proof. - intros H. + intros ->. cleanup_perm_of_zx. now cleanup_zx. Qed. @@ -977,15 +1239,15 @@ Lemma zx_of_perm_perm_eq_idn_removal_r {n m} f (zx : ZX n m) : perm_eq m f idn -> zx ⟷ zx_of_perm m f ∝ zx. Proof. - intros H. + intros ->. cleanup_perm_of_zx. now cleanup_zx. Qed. -#[export] Hint Rewrite +(* #[export] Hint Rewrite @zx_of_perm_perm_eq_idn_removal_l @zx_of_perm_perm_eq_idn_removal_r - using (solve [cleanup_perm_inv]) : perm_of_zx_cleanup_db. + using (solve [cleanup_perm_inv]) : perm_of_zx_cleanup_db. *) Lemma zx_of_perm_semantics n f : permutation n f -> @@ -998,7 +1260,7 @@ Proof. Qed. #[export] Hint Rewrite zx_of_perm_semantics - using auto with perm_db : perm_of_zx_cleanup_db. + using solve [auto_perm] : perm_of_zx_cleanup_db. Lemma zx_of_perm_casted_semantics f n n' m' (H : n' = n) (H' : m' = n) : @@ -1013,7 +1275,19 @@ Proof. Qed. #[export] Hint Rewrite zx_of_perm_casted_semantics - using auto with perm_db : perm_of_zx_cleanup_db. + using solve [auto_perm] : perm_of_zx_cleanup_db. + +Lemma zx_of_perm_cast_semantics f n m H + (Hf : permutation n f) : + ⟦ zx_of_perm_cast n m f H ⟧ = + perm_to_matrix n f. +Proof. + subst. + now apply zx_of_perm_semantics. +Qed. + +#[export] Hint Rewrite zx_of_perm_cast_semantics + using solve [auto_perm] : perm_of_zx_cleanup_db. Ltac simpl_zx_of_perm_semantics := match goal with @@ -1031,58 +1305,51 @@ Ltac simpl_zx_of_perm_semantics := Definition zx_comm p q : (ZX (p + q) (q + p)) := - cast (p+q) (q + p) eq_refl (Nat.add_comm q p) - (zx_of_perm (p + q) (rotr (p + q) p)). + zx_of_perm_cast (p + q) (q + p) (big_swap_perm q p) (Nat.add_comm p q). Arguments zx_comm : simpl never. -Lemma zx_comm_semantics p q : - ⟦ zx_comm p q ⟧ = kron_comm (2^q) (2^p). +Lemma zx_comm_zxperm p q : ZXperm (zx_comm p q). Proof. - unfold zx_comm. - cleanup_perm_of_zx. + unfold zx_comm; auto_zxperm. Qed. -#[export] Hint Rewrite zx_comm_semantics : perm_of_zx_cleanup_db. +#[export] Hint Resolve zx_comm_zxperm : zxperm_db. -Lemma zx_comm_cancel p q : - zx_comm p q ⟷ zx_comm q p ∝ n_wire _. +Lemma zx_comm_semantics p q : + ⟦ zx_comm p q ⟧ = kron_comm (2^q) (2^p). Proof. - prop_exists_nonzero R1. - rewrite Mscale_1_l. - simpl. - cleanup_perm_of_zx. - rewrite n_wire_semantics. - restore_dims. - rewrite kron_comm_mul_inv. - now unify_pows_two. + unfold zx_comm, zx_of_perm_cast. + simpl_cast_semantics. + rewrite zx_of_perm_semantics by auto_perm. + now rewrite kron_comm_pows2_eq_perm_to_matrix_big_swap. Qed. -#[export] Hint Rewrite zx_comm_cancel : perm_of_zx_cleanup_db. +#[export] Hint Rewrite zx_comm_semantics : perm_of_zx_cleanup_db. Lemma zx_comm_transpose p q : (zx_comm p q) ⊤ ∝ zx_comm q p. Proof. - unfold zx_comm. + unfold zx_comm, zx_of_perm_cast. simpl_casts. rewrite <- cast_transpose, cast_zx_of_perm. by_perm_eq. - rewrite Nat.add_comm. - rewrite perm_of_zx_of_perm_eq_WF by cleanup_perm. - cleanup_perm. - perm_eq_by_inv_inj (rotr (p + q) p) (p + q). - cleanup_perm. - rewrite Nat.add_comm. - cleanup_perm. Qed. #[export] Hint Rewrite zx_comm_transpose : transpose_db. +Lemma zx_comm_cancel p q : + zx_comm p q ⟷ zx_comm q p ∝ n_wire _. +Proof. + rewrite <- zx_comm_transpose. + apply zxperm_transpose_left_inverse; auto_zxperm. +Qed. + +#[export] Hint Rewrite zx_comm_cancel : perm_of_zx_cleanup_db. + Lemma zx_comm_colorswap p q : ⊙ (zx_comm p q) ∝ zx_comm p q. Proof. - unfold zx_comm. - simpl_casts. now rewrite zxperm_colorswap_eq by auto with zxperm_db. Qed. @@ -1095,10 +1362,10 @@ Proof. prop_exists_nonzero R1. rewrite Mscale_1_l. simpl. - cleanup_perm_of_zx. + rewrite 2!zx_comm_semantics. restore_dims. apply (kron_comm_commutes_r _ _ _ _ (⟦zx0⟧) (⟦zx1⟧)); - auto with wf_db. + auto_wf. Qed. Lemma zx_comm_commutes_r {n m p q} (zx0 : ZX n m) (zx1 : ZX p q) : @@ -1108,19 +1375,18 @@ Proof. prop_exists_nonzero R1. rewrite Mscale_1_l. simpl. - cleanup_perm_of_zx. + rewrite 2!zx_comm_semantics. restore_dims. apply (kron_comm_commutes_l _ _ _ _ (⟦zx0⟧) (⟦zx1⟧)); - auto with wf_db. + auto_wf. Qed. Lemma zx_comm_1_1_swap : zx_comm 1 1 ∝ ⨉. Proof. unfold zx_comm. - simpl_permlike_zx. by_perm_eq. - intros [| []]; easy. + by_perm_cell; reflexivity. Qed. Lemma perm_of_swap : @@ -1192,12 +1458,12 @@ Proof. cleanup_perm_of_zx. Qed. -#[export] Hint Rewrite zx_of_perm_compose_cast_r +(* #[export] Hint Rewrite zx_of_perm_compose_cast_r zx_of_perm_compose_cast_l zx_of_perm_compose_cast_cast using (first [auto with perm_db zxperm_db | erewrite permutation_change_dims; auto with perm_db zarith ]) : - perm_of_zx_cleanup_db. + perm_of_zx_cleanup_db. *) Lemma zx_comm_twice_add_r_join n m o H : zx_comm n (m + o) ⟷ cast _ _ H eq_refl (zx_comm m (o + n)) ∝ @@ -1205,13 +1471,11 @@ Lemma zx_comm_twice_add_r_join n m o H : (zx_comm _ _). Proof. unfold zx_comm. - simpl_casts. - rewrite zx_of_perm_compose_cast_cast by auto with perm_db. - simpl_casts. - apply zx_of_perm_prop_of_perm_eq. - replace (n + m + o) with (n + (m + o)) by lia. - replace (m + (o + n)) with (n + (m + o)) by lia. - cleanup_perm. + rewrite 2!cast_zx_of_perm_cast, compose_zx_of_perm_cast by auto_perm. + apply zx_of_perm_cast_prop_of_perm_eq. + intros k Hk. + unfold compose, big_swap_perm. + bdestructΩ'_with idtac; lia. Qed. @@ -1221,18 +1485,14 @@ Lemma zx_comm_twice_add_l_join n m o H : (zx_comm n (m + o)). Proof. unfold zx_comm. - simpl_casts. - rewrite zx_of_perm_compose_cast_cast by auto with perm_db. - simpl_casts. - apply zx_of_perm_prop_of_perm_eq. - replace (n + m + o) with (n + (m + o)) by lia. - replace (o + n + m) with (n + (m + o)) by lia. - cleanup_perm. - replace (n + m + (o + n)) with (n + (m + o) + n) by lia. - cleanup_perm. + rewrite 2!cast_zx_of_perm_cast, compose_zx_of_perm_cast by auto_perm. + apply zx_of_perm_cast_prop_of_perm_eq. + intros k Hk. + unfold compose, big_swap_perm. + bdestructΩ'_with idtac; lia. Qed. -Lemma zx_of_perm_rotr_to_zx_comm n m : +(* Lemma zx_of_perm_rotr_to_zx_comm n m : zx_of_perm (n + m) (rotr (n + m) n) ∝ cast _ _ eq_refl (Nat.add_comm _ _) (zx_comm n m). @@ -1249,7 +1509,7 @@ Proof. unfold zx_comm. simpl_casts. now rewrite (Nat.add_comm m n). -Qed. +Qed. *) Definition zx_gap_comm p m q : (ZX (p + m + q) (q + m + p)) := cast _ _ eq_refl (eq_sym (Nat.add_assoc _ _ _)) @@ -1257,52 +1517,59 @@ Definition zx_gap_comm p m q : (ZX (p + m + q) (q + m + p)) := Arguments zx_gap_comm : simpl never. +Lemma zx_gap_comm_zxperm p m q : ZXperm (zx_gap_comm p m q). +Proof. + unfold zx_gap_comm; auto_zxperm. +Qed. + +#[export] Hint Resolve zx_gap_comm_zxperm : zxperm_db. + Lemma zx_gap_comm_pf p m q : p + m + q = q + m + p. Proof. lia. Qed. Lemma zx_gap_comm_defn p m q : zx_gap_comm p m q ∝ - cast _ _ eq_refl (zx_gap_comm_pf _ _ _) - (zx_of_perm (p + m + q) (rotr (p + m + q) (p + m) ∘ - stack_perms q (p + m) idn (rotr (p + m) p))). + zx_of_perm_cast _ _ + (big_swap_perm q (p + m) ∘ + stack_perms q (p + m) idn (big_swap_perm m p)) + (zx_gap_comm_pf _ _ _). Proof. unfold zx_gap_comm, zx_comm. - rewrite <- zx_of_perm_idn. - auto_cast_eqn rewrite cast_stack_r. - rewrite stack_zx_of_perm by auto with perm_db. - rewrite cast_compose_l, !cast_cast_eq. - rewrite cast_zx_of_perm_natural_l. - rewrite cast_compose_r, cast_id, compose_zx_of_perm by - (erewrite permutation_change_dims; auto with perm_db zarith). - rewrite cast_cast_eq. - now apply cast_simplify. + rewrite cast_compose_distribute, cast_zx_of_perm_cast. + by_perm_eq_nosimpl. + cbn [perm_of_zx]. + now rewrite perm_of_zx_cast, perm_of_zx_of_perm_cast_eq_WF, + perm_of_zx_stack_spec, perm_of_n_wire, + 2!perm_of_zx_of_perm_cast_eq_WF by auto_perm. +Qed. + +Lemma perm_of_zx_gap_comm p m q : + perm_of_zx (zx_gap_comm p m q) = + big_swap_perm q (p + m) ∘ + stack_perms q (p + m) idn (big_swap_perm m p). +Proof. + rewrite (perm_of_zx_prop_rw (zx_gap_comm_defn p m q)) by auto_zxperm. + now rewrite perm_of_zx_of_perm_cast_eq_WF by auto_perm. Qed. +#[export] Hint Rewrite perm_of_zx_gap_comm : perm_of_zx_cleanup_db. + Lemma zx_gap_comm_transpose p m q : (zx_gap_comm p m q) ⊤ ∝ zx_gap_comm q m p. Proof. rewrite 2!zx_gap_comm_defn. - simpl_casts. - rewrite <- cast_transpose, cast_zx_of_perm. - by_perm_eq. - replace (q + m + p) with (p + m + q) by lia. - rewrite perm_of_zx_of_perm_eq_WF by cleanup_perm_inv. - perm_eq_by_inv_inj (rotr (p + m + q) (p + m) - ∘ stack_perms q (p + m) idn (rotr (p + m) p)) (p + m + q). - replace (p + m + q) with ((q + m) + p) by lia. - rewrite <- stack_perms_rotr_natural by cleanup_perm. - replace (q + m + p) with (p + m + q) by lia. - rewrite <- stack_perms_rotr_natural by cleanup_perm. - cleanup_perm. - rewrite 3!rotr_add_l. - (* rewrite 3!rotr_add_l_eq. *) - replace (p + m + q) with (q + m + p) by lia. - rewrite rotr_add_l. - rewrite <- !compose_assoc. + by_perm_eq_nosimpl. + rewrite perm_of_zx_transpose, 2!perm_of_zx_of_perm_cast_eq_WF by auto_perm. + rewrite perm_inv'_compose, big_swap_perm_inv'_change_dims by lia + auto_perm. + rewrite (Nat.add_comm (p + m) q). + rewrite perm_inv'_stack_perms, idn_inv', big_swap_perm_inv'_change_dims + by lia + auto_perm. + rewrite big_swap_perm_defn, 2!stack_perms_idn_f. + unfold compose. intros k Hk. - unfold compose at 1. unfold big_swap_perm. - repeat (bdestructΩ'; unfold compose at 1). + do 2 simplify_bools_lia_one_kernel. + bdestructΩ'_with idtac; lia. Qed. #[export] Hint Rewrite zx_gap_comm_transpose : transpose_db. @@ -1310,10 +1577,7 @@ Qed. Lemma zx_gap_comm_colorswap p m q : ⊙ (zx_gap_comm p m q) ∝ zx_gap_comm p m q. Proof. - unfold zx_gap_comm. - simpl_casts. - simpl. - now autorewrite with colorswap_db. + now rewrite zxperm_colorswap_eq by auto_zxperm. Qed. #[export] Hint Rewrite zx_gap_comm_colorswap : colorswap_db. @@ -1333,7 +1597,7 @@ Proof. rewrite <- (nwire_removal_l zx2) at 1. auto_cast_eqn rewrite stack_compose_distr, stack_assoc_back. rewrite (cast_compose_r _ _ (_ ↕ _)). - simpl_casts. + auto_cast_eqn rewrite !cast_contract, cast_id. rewrite <- compose_assoc. unfold zx_gap_comm. rewrite cast_compose_distribute, cast_id. @@ -1356,14 +1620,12 @@ Notation zx_gap_comm_commutes_r := zx_gap_comm_pullthrough_l. Lemma zx_gap_comm_1_m_1_a_swap m : zx_gap_comm 1 m 1 ∝ a_swap (1 + m + 1). Proof. - rewrite zx_gap_comm_defn, cast_id. - by_perm_eq. - rewrite Nat.add_sub. - rewrite 2!rotr_add_l. - rewrite stack_perms_idn_f. + by_perm_eq_nosimpl. + rewrite perm_of_a_swap, perm_of_zx_gap_comm. + rewrite 2!big_swap_perm_defn_alt, stack_perms_idn_f, swap_perm_defn + by lia. intros k Hk; unfold compose. - unfold big_swap_perm, swap_perm. - rewrite (Nat.add_comm 1 m). + simplify_bools_lia_one_kernel. bdestructΩ'. Qed. diff --git a/src/Permutations/ZXpermSemantics.v b/src/Permutations/ZXpermSemantics.v index 68be0e5..375aa87 100644 --- a/src/Permutations/ZXpermSemantics.v +++ b/src/Permutations/ZXpermSemantics.v @@ -8,11 +8,48 @@ Import CoreData.Proportional. Local Open Scope nat. -Lemma perm_of_zx_permutation n zx : - ZXperm n zx -> permutation n (perm_of_zx zx). -Proof. +Lemma zxperm_square {n m} (zx : ZX n m) : + ZXperm zx -> n = m. +Proof. + intros H; induction H; lia. +Qed. + +Lemma zxperm_square_induction + (P : forall {n m : nat}, ZX n m -> Prop) + (Pempty : P Empty) + (Pwire : P Wire) + (Pswap : P Swap) + (Pstack : forall n m (zx0 : ZX n n) (zx1 : ZX m m), + ZXperm zx0 -> ZXperm zx1 -> + P zx0 -> P zx1 -> P (zx0 ↕ zx1)) + (Pcompose : forall n (zx0 zx1 : ZX n n), + ZXperm zx0 -> ZXperm zx1 -> + P zx0 -> P zx1 -> P (zx0 ⟷ zx1)) : + forall {n m} (zx : ZX n m), ZXperm zx -> P zx. +Proof. + intros n m zx Hzx. + induction Hzx; + [assumption..| |]. + - pose proof (zxperm_square zx0 ltac:(auto)) as H0eq. + pose proof (zxperm_square zx1 ltac:(auto)) as H1eq. + gen zx0 zx1. + revert H0eq H1eq. + intros [] []. + auto. + - pose proof (zxperm_square zx0 ltac:(auto)) as H0eq. + pose proof (zxperm_square zx1 ltac:(auto)) as H1eq. + gen zx0 zx1. + revert H0eq H1eq. + intros [] []. + auto. +Qed. + +Lemma perm_of_zx_permutation {n m} (zx : ZX n m) : + ZXperm zx -> permutation n (perm_of_zx zx). +Proof. intros H. - induction H; show_permutation. + induction H using zxperm_square_induction; + show_permutation. Qed. #[export] Hint Resolve perm_of_zx_permutation : perm_db. @@ -22,26 +59,6 @@ Qed. #[export] Hint Constructors ZXperm : zxperm_db. -(* TODO: Decide whether this goes here (it does) or somewhere else (it doesn't) *) -Lemma stack_perms_matrix_helper {n0 n1 i j} {f g} - (Hi : i < 2 ^ (n0 + n1)) (Hj: j < 2 ^ (n0 + n1)) : - permutation n0 f -> permutation n1 g -> - i =? qubit_perm_to_nat_perm (n0 + n1) (stack_perms n0 n1 f g) j = - (i / 2 ^ n1 =? qubit_perm_to_nat_perm n0 f (j / 2 ^ n1)) && - (i mod 2 ^ n1 =? qubit_perm_to_nat_perm n1 g (j mod 2 ^ n1)). -Proof. - intros Hfperm Hgperm. - rewrite qubit_perm_to_nat_perm_stack_perms by auto with perm_bounded_db. - rewrite (eqb_iff_div_mod_eqb (2^n1)), andb_comm. - do 2 f_equal; - unfold tensor_perms; - simplify_bools_moddy_lia_one_kernel. - - rewrite Nat.div_add_l by show_nonzero. - rewrite (Nat.div_small (_ _)) by auto with perm_bounded_db. - lia. - - now rewrite mod_add_l, Nat.mod_small by auto with perm_bounded_db. -Qed. - Lemma empty_permutation_semantics : ⟦ Empty ⟧ = zxperm_to_matrix 0 Empty. Proof. lma'. Qed. @@ -95,11 +112,11 @@ Lemma cast_permutations_semantics {n0 n1} {zx : ZX n0 n0} ⟦ cast _ _ Hn Hn zx ⟧ = zxperm_to_matrix n1 (cast _ _ Hn Hn zx). Proof. subst; easy. Qed. -Lemma perm_of_zx_permutation_semantics {n zx} : - ZXperm n zx -> ⟦ zx ⟧ = zxperm_to_matrix n zx. +Lemma perm_of_zx_permutation_semantics {n m} (zx : ZX n m) : + ZXperm zx -> ⟦ zx ⟧ = zxperm_to_matrix n zx. Proof. intros H. - induction H. + induction H using zxperm_square_induction. - apply empty_permutation_semantics. - apply wire_permutation_semantics. - apply swap_2_perm_semantics. @@ -109,38 +126,38 @@ Qed. (* ... which enables the main result: *) -Lemma proportional_of_equal_perm {n} {zx0 zx1 : ZX n n} - (Hzx0 : ZXperm n zx0) (Hzx1 : ZXperm n zx1) +Lemma proportional_of_equal_perm {n m} {zx0 zx1 : ZX n m} + (Hzx0 : ZXperm zx0) (Hzx1 : ZXperm zx1) (Hperm : perm_of_zx zx0 = perm_of_zx zx1) : zx0 ∝ zx1. Proof. prop_exists_nonzero (RtoC 1). rewrite Mscale_1_l. - rewrite (perm_of_zx_permutation_semantics Hzx0), - (perm_of_zx_permutation_semantics Hzx1). + rewrite (perm_of_zx_permutation_semantics zx0 Hzx0), + (perm_of_zx_permutation_semantics zx1 Hzx1). f_equal; easy. Qed. -Lemma proportional_of_perm_eq {n} {zx0 zx1 : ZX n n} - (Hzx0 : ZXperm n zx0) (Hzx1 : ZXperm n zx1) +Lemma proportional_of_perm_eq {n m} {zx0 zx1 : ZX n m} + (Hzx0 : ZXperm zx0) (Hzx1 : ZXperm zx1) (Hperm : perm_eq n (perm_of_zx zx0) (perm_of_zx zx1)) : zx0 ∝ zx1. Proof. + pose proof (zxperm_square zx0 Hzx0); subst. prop_exists_nonzero (RtoC 1). rewrite Mscale_1_l. - rewrite (perm_of_zx_permutation_semantics Hzx0), - (perm_of_zx_permutation_semantics Hzx1). - apply mat_equiv_eq; auto with wf_db. - apply perm_to_matrix_perm_eq; cleanup_perm. + rewrite (perm_of_zx_permutation_semantics zx0 Hzx0), + (perm_of_zx_permutation_semantics zx1 Hzx1). + now apply perm_to_matrix_eq_of_perm_eq. Qed. (* TODO: split intro prop_perm_eq and prop_perm_eqΩ *) Ltac prop_perm_eq_nosimpl := intros; - simpl_casts; - simpl_permlike_zx; - __cast_prop_sides_to_square; + (* simpl_casts; *) + (* simpl_permlike_zx; *) + (* __cast_prop_sides_to_square; *) (* Goal: zx0 ∝ zx1 *) apply proportional_of_equal_perm; [ (* New goals: *) @@ -154,7 +171,7 @@ Ltac prop_perm_eq := autounfold with zxperm_db; simpl_casts; simpl_permlike_zx; - __cast_prop_sides_to_square; + (* __cast_prop_sides_to_square; *) (* Goal: zx0 ∝ zx1 *) apply proportional_of_equal_perm; [ (* New goals: *) @@ -169,7 +186,7 @@ Ltac by_perm_eq := autounfold with zxperm_db; simpl_casts; simpl_permlike_zx; - __cast_prop_sides_to_square; + (* __cast_prop_sides_to_square; *) (* Goal: zx0 ∝ zx1 *) apply proportional_of_perm_eq; [ (* New goals: *) From fa71671c48ae921221a1e883148ed528f7109f83 Mon Sep 17 00:00:00 2001 From: William Spencer Date: Sat, 31 Aug 2024 08:55:14 -0700 Subject: [PATCH 10/10] Add n_cup/n_cap pullthrough lemmas. Uses f_to_vec semantics together with ZXperm. --- src/CoreData/QlibTemp.v | 48 +++ src/CoreData/SemanticCore.v | 3 +- src/CoreRules/CapCupRules.v | 524 +++++++++++++++++++++++++++- src/CoreRules/StackComposeRules.v | 24 +- src/CoreRules/SwapRules.v | 81 ++--- src/CoreRules/XRules.v | 8 + src/CoreRules/ZRules.v | 166 ++------- src/Permutations/ZXpermAutomation.v | 3 + src/Permutations/ZXpermFacts.v | 6 +- 9 files changed, 652 insertions(+), 211 deletions(-) create mode 100644 src/CoreData/QlibTemp.v diff --git a/src/CoreData/QlibTemp.v b/src/CoreData/QlibTemp.v new file mode 100644 index 0000000..d415a25 --- /dev/null +++ b/src/CoreData/QlibTemp.v @@ -0,0 +1,48 @@ +Require Import QuantumLib.VectorStates. +Require Import QuantumLib.Permutations. + +Local Open Scope nat_scope. + +Lemma kron_f_to_vec_eq {n m p q : nat} (A : Matrix (2^n) (2^m)) + (B : Matrix (2^p) (2^q)) (f : nat -> bool) : WF_Matrix A -> WF_Matrix B -> + A ⊗ B × f_to_vec (m + q) f + = A × f_to_vec m f ⊗ (B × f_to_vec q (fun k : nat => f (m + k))). +Proof. + intros. + prep_matrix_equivalence. + apply kron_f_to_vec. +Qed. + +Lemma equal_on_basis_states_implies_equal' : (* FIXME: Replace + equal_on_basis_states_implies_equal with this *) + forall {m dim : nat} (A B : Matrix m (2 ^ dim)), + WF_Matrix A -> WF_Matrix B -> + (forall f : nat -> bool, A × f_to_vec dim f = B × f_to_vec dim f) -> + A = B. +Proof. + intros m dim A B HA HB HAB. + prep_matrix_equivalence. + intros i j Hi Hj. + rewrite 2!(get_entry_with_e_i _ i j) by lia. + rewrite 2!Mmult_assoc. + rewrite <- (basis_vector_eq_e_i _ j) by assumption. + rewrite basis_f_to_vec_alt by assumption. + now rewrite HAB. +Qed. + +Lemma equal_on_conj_basis_states_implies_equal {n m} + (A B : Matrix (2 ^ n) (2 ^ m)) : WF_Matrix A -> WF_Matrix B -> + (forall f g, (f_to_vec n g) ⊤%M × (A × f_to_vec m f) = + (f_to_vec n g) ⊤%M × (B × f_to_vec m f)) -> A = B. +Proof. + intros HA HB HAB. + apply equal_on_basis_states_implies_equal'; [auto..|]. + intros f. + apply transpose_matrices. + apply equal_on_basis_states_implies_equal'; [auto_wf..|]. + intros g. + apply transpose_matrices. + rewrite Mmult_transpose, transpose_involutive, HAB. + rewrite Mmult_transpose, transpose_involutive. + reflexivity. +Qed. \ No newline at end of file diff --git a/src/CoreData/SemanticCore.v b/src/CoreData/SemanticCore.v index cdcb150..a1a2144 100644 --- a/src/CoreData/SemanticCore.v +++ b/src/CoreData/SemanticCore.v @@ -3,10 +3,11 @@ Contains the definitions for Z and X spider semantics, their equivalence, and well formedness *) +Require Export QuantumLib.Modulus. Require Export QuantumLib.Quantum. Require Import QuantumLib.Proportional. Require Export QuantumLib.VectorStates. - +Require Export QlibTemp. (* Sparse Matrix Definition *) diff --git a/src/CoreRules/CapCupRules.v b/src/CoreRules/CapCupRules.v index 42ca8c7..49a4a64 100644 --- a/src/CoreRules/CapCupRules.v +++ b/src/CoreRules/CapCupRules.v @@ -4,7 +4,9 @@ Require Import CastRules. Require Import WireRules. Require Import StackRules. Require Import SwapRules. +Require Import ZXpermFacts. Require Import CoreAutomation. +Require Import StackComposeRules. Lemma cup_Z : ⊃ ∝ Z 2 0 0. Proof. @@ -46,24 +48,519 @@ Proof. now rewrite wire_to_n_wire, n_wire_stack, 2!nwire_removal_l. Qed. -Opaque n_cup. - Lemma n_cap_0_empty : n_cap 0 ∝ ⦰. Proof. - apply transpose_diagrams. - simpl. + unfold n_cap. rewrite n_cup_0_empty. easy. Qed. Lemma n_cap_1_cap : n_cap 1 ∝ ⊂. Proof. + unfold n_cap. + rewrite n_cup_1_cup. + easy. +Qed. + +Local Open Scope nat_scope. + +Lemma cap_f_to_vec f : + ⟦ ⊃ ⟧ × f_to_vec 2 f = + b2R (eqb (f 0) ((f 1))) .* I (2 ^ 0). +Proof. + prep_matrix_equivalence. + unfold scale, kron. + by_cell; + destruct (f 0), (f 1); cbv; lca. +Qed. + +Lemma n_cup_unswapped_f_to_vec n f : + ⟦ n_cup_unswapped n ⟧ × f_to_vec (n + n) f = + b2R (forallb (fun k => eqb (f k) ( f (n + n - S k))) (seq 0 n)) .* I (2 ^ 0). +Proof. + revert f; + induction n; intros f. + - cbn. Csimpl. now Msimpl_light. + - cbn [n_cup_unswapped]. + rewrite zx_compose_spec. + simpl_cast_semantics. + rewrite 2!zx_stack_spec. + replace (S n + S n) with (1 + (n + n) + 1) by lia. + rewrite Mmult_assoc. + restore_dims. + rewrite (@kron_f_to_vec_eq (1 + 0) (1 + (n + n)) 1 1) by auto_wf. + rewrite (@kron_f_to_vec_eq 1 1 0 (n + n)) by auto_wf. + rewrite IHn. + cbn -[f_to_vec seq]. + rewrite Mmult_1_l, Mmult_1_comm by apply (f_to_vec_WF 1). + rewrite (kron_split_diag (f_to_vec 1 f)) by auto_wf. + rewrite <- kron_mixed_product, kron_1_r. + restore_dims. + rewrite f_to_vec_merge. + rewrite <- Mmult_assoc. + rewrite cap_f_to_vec. + cbn [Nat.ltb Nat.leb]. + rewrite Nat.sub_diag, Nat.add_0_r. + rewrite kron_1_l, kron_1_r by auto_wf. + cbn -[seq]. + restore_dims. + distribute_scale. + Msimpl_light. + f_equal. + unfold b2R. + rewrite !(if_dist _ _ _ RtoC). + rewrite Cmult_if_if_1_l. + apply f_equal_if; [|easy..]. + cbn. + f_equal; [repeat f_equal; lia|]. + apply eq_iff_eq_true. + rewrite forallb_seq0, forallb_seq. + setoid_rewrite eqb_true_iff. + apply forall_iff. + intros s. + apply impl_iff; intros Hs. + rewrite 2!(Nat.add_comm _ 1). + cbn. + replace (S (n + n - S s)) with (n + n - s) by lia. + reflexivity. +Qed. + +Lemma n_cup_f_to_vec n f : + ⟦ n_cup n ⟧ × f_to_vec (n + n) f = + b2R (forallb (fun k => eqb (f k) ( f (n + k))) (seq 0 n)) .* I (2 ^ 0). +Proof. + unfold n_cup. + rewrite zx_compose_spec, zx_stack_spec. + rewrite n_wire_semantics. + rewrite perm_of_zx_permutation_semantics by auto with zxperm_db. + rewrite perm_of_n_swap. + rewrite Mmult_assoc. + restore_dims. + rewrite kron_f_to_vec_eq by auto_wf. + rewrite perm_to_matrix_permutes_qubits by cleanup_perm. + rewrite Mmult_1_l by auto_wf. + rewrite f_to_vec_merge. + rewrite n_cup_unswapped_f_to_vec. + f_equal. + f_equal. + f_equal. + apply eq_iff_eq_true. + rewrite 2!forallb_seq0. + setoid_rewrite eqb_true_iff. + split. + - intros Hf. + intros s Hs. + generalize (Hf (n - S s) ltac:(lia)). + do 2 simplify_bools_lia_one_kernel. + rewrite reflect_perm_defn by lia. + rewrite sub_S_sub_S by lia. + intros ->. + f_equal; lia. + - intros Hf. + intros s Hs. + generalize (Hf (n - S s) ltac:(lia)). + do 2 simplify_bools_lia_one_kernel. + rewrite reflect_perm_defn by lia. + intros ->. + f_equal; lia. +Qed. + +Lemma f_to_vec_transpose_f_to_vec n f g : + transpose (f_to_vec n f) × f_to_vec n g = + b2R (forallb (fun k => eqb (f k) (g k)) (seq 0 n)) .* I 1. +Proof. + prep_matrix_equivalence. + intros [] []; [|lia..]; intros _ _. + rewrite 2!basis_f_to_vec. + rewrite basis_trans_basis. + simplify_bools_moddy_lia_one_kernel. + unfold scale. + cbn. + rewrite Cmult_1_r. + unfold b2R. + rewrite (if_dist _ _ _ RtoC). + apply f_equal_if; [|easy..]. + apply eq_iff_eq_true. + rewrite Nat.eqb_eq, forallb_seq0, <- funbool_to_nat_eq_iff. + now setoid_rewrite eqb_true_iff. +Qed. + +Lemma f_to_vec_transpose_f_to_vec' n f g : + transpose (f_to_vec n f) × f_to_vec n g = + (if funbool_to_nat n f =? funbool_to_nat n g then + C1 else C0) .* I 1. +Proof. + rewrite f_to_vec_transpose_f_to_vec. + f_equal. + unfold b2R. + rewrite (if_dist R C). + apply f_equal_if; [|easy..]. + apply eq_iff_eq_true. + rewrite forallb_seq0, Nat.eqb_eq. + setoid_rewrite eqb_true_iff. + apply funbool_to_nat_eq_iff. +Qed. + +Lemma f_to_vec_transpose_self n f : + transpose (f_to_vec n f) × f_to_vec n f = + I 1. +Proof. + rewrite f_to_vec_transpose_f_to_vec', Nat.eqb_refl. + now Msimpl_light. +Qed. + + +Lemma n_cup_f_to_vec_pullthrough_bot n f : + @Mmult _ (2^(n + n)) (2^n) (⟦ n_cup n ⟧) (I (2 ^ n) ⊗ f_to_vec n f) = + (f_to_vec n f) ⊤%M. +Proof. + unify_pows_two. + apply equal_on_basis_states_implies_equal'; + [auto_wf.. |]. + intros g. + rewrite <- (kron_1_r _ _ (f_to_vec n g)) at 1. + rewrite Mmult_assoc. + restore_dims. + rewrite kron_mixed_product, Mmult_1_l, Mmult_1_r by auto_wf. + rewrite f_to_vec_transpose_f_to_vec. + rewrite f_to_vec_merge. + rewrite n_cup_f_to_vec. + do 3 f_equal. + apply eq_iff_eq_true. + rewrite 2!forallb_seq0. + apply forall_iff; intros s. + apply impl_iff; intros Hs. + do 2 simplify_bools_lia_one_kernel. + rewrite add_sub'. + rewrite 2!eqb_true_iff. + easy. +Qed. + +Lemma n_cup_f_to_vec_pullthrough_top n f : + @Mmult _ (2^(n + n)) (2^n) (⟦ n_cup n ⟧) (f_to_vec n f ⊗ I (2 ^ n)) = + (f_to_vec n f) ⊤%M. +Proof. + unify_pows_two. + apply equal_on_basis_states_implies_equal'; + [auto_wf.. |]. + intros g. + rewrite <- (kron_1_l _ _ (f_to_vec n g)) at 1 by auto_wf. + rewrite Mmult_assoc. + restore_dims. + rewrite kron_mixed_product, Mmult_1_l, Mmult_1_r by auto_wf. + rewrite f_to_vec_transpose_f_to_vec. + rewrite f_to_vec_merge. + rewrite n_cup_f_to_vec. + do 3 f_equal. + apply eq_iff_eq_true. + rewrite 2!forallb_seq0. + apply forall_iff; intros s. + apply impl_iff; intros Hs. + do 2 simplify_bools_lia_one_kernel. + now rewrite add_sub'. +Qed. + +Lemma n_cap_f_to_vec_pullthrough_bot n f : + @Mmult (2^n) (2^(n + n)) _ (I (2 ^ n) ⊗ (f_to_vec n f) ⊤%M) (⟦ n_cap n ⟧) = + f_to_vec n f. +Proof. + apply transpose_matrices. + rewrite Mmult_transpose. + restore_dims. + rewrite Nat.pow_add_r. + change (@transpose (2 ^ n)) with (@transpose (2^n * 2^0)). + rewrite (kron_transpose). + unfold n_cap. + rewrite semantics_transpose_comm. + change (transpose (transpose ?x)) with x. + rewrite id_transpose_eq. + unify_pows_two. + apply n_cup_f_to_vec_pullthrough_bot. +Qed. + +Lemma n_cap_f_to_vec_pullthrough_top n f : + @Mmult (2^n) (2^(n + n)) _ ((f_to_vec n f) ⊤%M ⊗ I (2 ^ n)) (⟦ n_cap n ⟧) = + f_to_vec n f. +Proof. + apply transpose_matrices. + rewrite Mmult_transpose. + restore_dims. + rewrite Nat.pow_add_r. + change (@transpose (2 ^ n)) with (@transpose (2^0 * 2^n)). + rewrite (kron_transpose). + unfold n_cap. + rewrite semantics_transpose_comm. + change (transpose (transpose ?x)) with x. + rewrite id_transpose_eq. + unify_pows_two. + apply n_cup_f_to_vec_pullthrough_top. +Qed. + +Lemma Mmult_vec_comm {n} (v u : Vector n) : WF_Matrix u -> WF_Matrix v -> + v ⊤%M × u = u ⊤%M × v. +Proof. + intros Hu Hv. + prep_matrix_equivalence. + by_cell. + apply big_sum_eq_bounded. + intros k Hk. + unfold transpose. + lca. +Qed. + +Lemma n_cup_matrix_pullthrough_top n m (A : Matrix (2 ^ n) (2 ^ m)) + (HA : WF_Matrix A) : + @Mmult _ (2^(n + n)) (2^(m + n)) (⟦ n_cup n ⟧) (A ⊗ I (2 ^ n)) = + @Mmult _ (2^(m + m)) (2^(m + n)) (⟦ n_cup m ⟧) (I (2 ^ m) ⊗ A ⊤%M). +Proof. + unify_pows_two. + apply equal_on_basis_states_implies_equal'; + [auto_wf..|]. + intros f. + rewrite 2!Mmult_assoc. + restore_dims. + rewrite 2!kron_f_to_vec_eq by auto_wf. + rewrite 2!Mmult_1_l, kron_split_antidiag by auto_wf. + restore_dims. + unify_pows_two. + rewrite <- Mmult_assoc. + rewrite n_cup_f_to_vec_pullthrough_bot. + symmetry. + rewrite kron_split_diag by auto_wf. + unify_pows_two. + rewrite <- Mmult_assoc. + rewrite n_cup_f_to_vec_pullthrough_top. + rewrite kron_1_l, kron_1_r by auto_wf. + rewrite <- Mmult_assoc. + rewrite Mmult_vec_comm, Mmult_transpose by auto_wf. + easy. +Qed. + +Lemma n_cup_matrix_pullthrough_bot n m (A : Matrix (2 ^ n) (2 ^ m)) + (HA : WF_Matrix A) : + @Mmult _ (2^(n + n)) (2^(n + m)) (⟦ n_cup n ⟧) (I (2 ^ n) ⊗ A) = + @Mmult _ (2^(m + m)) (2^(n + m)) (⟦ n_cup m ⟧) (A ⊤%M ⊗ I (2 ^ m)). +Proof. + now rewrite n_cup_matrix_pullthrough_top, + transpose_involutive by auto_wf. +Qed. + +Open Scope ZX_scope. + +Lemma n_cup_pullthrough_top {n m} (zx : ZX n m) : + zx ↕ n_wire m ⟷ n_cup m ∝ + n_wire n ↕ zx ⊤ ⟷ n_cup n. +Proof. + prop_exists_nonzero 1%R. + rewrite Mscale_1_l. + cbn [ZX_semantics]. + rewrite semantics_transpose_comm, 2!n_wire_semantics. + apply n_cup_matrix_pullthrough_top. + auto_wf. +Qed. + +Lemma n_cup_pullthrough_bot {n m} (zx : ZX n m) : + n_wire m ↕ zx ⟷ n_cup m ∝ + zx ⊤ ↕ n_wire n ⟷ n_cup n. +Proof. + rewrite n_cup_pullthrough_top, Proportional.transpose_involutive. + easy. +Qed. + +Lemma n_cap_pullthrough_top {n m} (zx : ZX n m) : + n_cap n ⟷ (zx ↕ n_wire n) ∝ + n_cap m ⟷ (n_wire m ↕ zx ⊤). +Proof. apply transpose_diagrams. - simpl. - rewrite <- n_cup_1_cup. + cbn -[n_cup]. + unfold n_cap. + rewrite !Proportional.transpose_involutive, !n_wire_transpose. + now rewrite n_cup_pullthrough_bot. +Qed. + +Lemma n_cap_pullthrough_bot {n m} (zx : ZX n m) : + n_cap n ⟷ (n_wire n ↕ zx) ∝ + n_cap m ⟷ (zx ⊤ ↕ n_wire m). +Proof. + now rewrite n_cap_pullthrough_top, Proportional.transpose_involutive. +Qed. + +Lemma n_cup_inv_n_swap_n_wire : forall n, n_cup n ∝ n_wire n ↕ n_swap n ⟷ n_cup_unswapped n. +Proof. + intros n. + rewrite compose_zxperm_l' by auto_zxperm. + cbn. + rewrite n_wire_transpose. + rewrite n_cup_pullthrough_bot, n_swap_transpose. + rewrite compose_zxperm_l by auto_zxperm. + cbn. + rewrite n_wire_transpose. + now rewrite 2!n_swap_transpose. +Qed. + +Lemma n_cup_unswapped_to_n_cup_n_swap_top n : + n_cup_unswapped n ∝ + n_swap n ↕ n_wire n ⟷ n_cup n. +Proof. + rewrite compose_zxperm_l' by auto_zxperm. + now rewrite stack_transpose, n_swap_transpose, n_wire_transpose. +Qed. + +Lemma n_cup_unswapped_pullthrough_top {n m} (zx : ZX n m) : + zx ↕ n_wire m ⟷ n_cup_unswapped m ∝ + n_wire n ↕ (n_swap m ⟷ zx ⊤ ⟷ n_swap n) ⟷ n_cup_unswapped n. +Proof. + rewrite n_cup_unswapped_to_n_cup_n_swap_top. + rewrite n_cup_pullthrough_top. + rewrite <- compose_assoc, <- stack_compose_distr, + nwire_removal_l, nwire_removal_r, n_swap_transpose. + rewrite stack_split_antidiag, compose_assoc, n_cup_pullthrough_top. + rewrite n_cup_inv_n_swap_n_wire. + now rewrite !stack_nwire_distribute_l, !compose_assoc. +Qed. + +Lemma n_cup_unswapped_pullthrough_bot {n m} (zx : ZX n m) : + n_wire m ↕ zx ⟷ n_cup_unswapped m ∝ + (n_swap m ⟷ zx ⊤ ⟷ n_swap n) ↕ n_wire n ⟷ n_cup_unswapped n. +Proof. + rewrite n_cup_unswapped_to_n_cup_n_swap_top. + (* rewrite n_cup_pullthrough_top. *) + rewrite <- compose_assoc, <- stack_compose_distr, + nwire_removal_l, nwire_removal_r. + rewrite stack_split_diag, compose_assoc, n_cup_pullthrough_bot. + now rewrite !stack_nwire_distribute_r, !compose_assoc. +Qed. + +Lemma big_yank_l n prf0 prf1 : + (n_cap n ↕ n_wire n) ⟷ + cast _ _ prf0 prf1 + (n_wire n ↕ n_cup n) ∝ n_wire n. +Proof. + prop_exists_nonzero 1%R. + cbn -[n_cup n_cap]. + simpl_cast_semantics. + cbn -[n_cup n_cap]. + rewrite Mscale_1_l, n_wire_semantics. + apply equal_on_basis_states_implies_equal; [auto_wf..|]. + intros f. + rewrite Mmult_1_l by auto_wf. + rewrite Mmult_assoc. + rewrite <- (kron_1_l _ _ (f_to_vec n f)) by auto_wf. + restore_dims. + rewrite kron_mixed_product, Mmult_1_l, Mmult_1_r by auto_wf. + rewrite (kron_split_antidiag _ (f_to_vec n f)) by auto_wf. + rewrite Nat.pow_add_r, <- id_kron. + rewrite kron_assoc by auto_wf. + restore_dims. + unify_pows_two. + rewrite <- Mmult_assoc. + restore_dims. + rewrite kron_mixed_product' by unify_pows_two. + unify_pows_two. + rewrite n_cup_f_to_vec_pullthrough_bot. + rewrite Mmult_1_l, kron_1_r by auto_wf. + rewrite n_cap_f_to_vec_pullthrough_bot. + now rewrite kron_1_l by auto_wf. +Qed. + +Lemma big_yank_r n prf0 prf1 prf2 : + (n_wire n ↕ n_cap n) ⟷ + cast _ _ prf0 prf1 + (n_cup n ↕ n_wire n) ∝ cast _ _ prf2 eq_refl (n_wire n). +Proof. + apply transpose_diagrams. + cbn [ZXCore.transpose]. + rewrite 2!cast_transpose. + cbn [ZXCore.transpose]. unfold n_cap. rewrite Proportional.transpose_involutive. - easy. + fold (n_cap n). + rewrite n_wire_transpose. + rewrite cast_compose_l. + clean_eqns eapply (cast_diagrams n n). + clean_eqns rewrite cast_contract, + cast_compose_distribute, cast_contract, cast_id. + rewrite (big_yank_l n). + now clean_eqns rewrite cast_contract, cast_id. +Qed. + +Lemma n_cap_n_cup_matrix_pullthrough n m (A : Matrix (2 ^ n) (2 ^ m)) + (HA : WF_Matrix A) : + I (2 ^ m) ⊗ (⟦ n_cup n ⟧) × (I (2 ^ m) ⊗ A ⊗ I (2 ^ n)) × + (⟦ n_cap m ⟧ ⊗ I (2 ^ n)) = + A ⊤%M. +Proof. + apply equal_on_basis_states_implies_equal'; + [auto_wf..|]. + intros f. + rewrite <- (kron_1_l _ _ (f_to_vec n f)) at 1 by auto_wf. + rewrite Mmult_assoc; + restore_dims. + rewrite Mmult_assoc, kron_mixed_product' by unify_pows_two. + restore_dims. + rewrite kron_mixed_product. + rewrite !Mmult_1_l, Mmult_1_r by auto_wf. + rewrite (kron_split_antidiag (_ × _)), <- id_kron, kron_assoc by auto_wf. + rewrite kron_1_r. + restore_dims. + unify_pows_two. + + rewrite <- Mmult_assoc. + restore_dims. + rewrite kron_mixed_product' by unify_pows_two. + rewrite Mmult_1_r by auto_wf. + unify_pows_two. + rewrite n_cup_f_to_vec_pullthrough_bot, <- Mmult_assoc. + restore_dims. + rewrite kron_mixed_product, Mmult_1_r by auto_wf. + apply transpose_matrices. + rewrite !Mmult_transpose. + change (transpose (?A ⊗ ?B)) with ((transpose A) ⊗ (transpose B)). + rewrite Mmult_transpose, transpose_involutive. + unfold n_cap. + rewrite semantics_transpose_comm. + change (transpose (transpose ?x)) with x. + rewrite id_transpose_eq. + unify_pows_two. + apply equal_on_basis_states_implies_equal'; + [auto_wf..|]. + intros g. + rewrite Mmult_assoc. + rewrite <- (kron_1_r _ _ (f_to_vec m g)). + restore_dims. + rewrite kron_mixed_product. + rewrite kron_1_r. + rewrite Mmult_1_l, Mmult_1_r by auto_wf. + rewrite (kron_split_diag (f_to_vec _ _)) by auto_wf. + unify_pows_two. + rewrite <- Mmult_assoc. + rewrite n_cup_f_to_vec_pullthrough_top. + rewrite kron_1_l by auto_wf. + now rewrite Mmult_vec_comm by auto_wf. +Qed. + +Lemma n_cap_n_cup_pullthrough n m (A : ZX m n) prf1 prf2 : + (n_cap m ↕ n_wire n) ⟷ + (n_wire m ↕ A ↕ n_wire n) ⟷ + cast _ _ prf1 prf2 (n_wire m ↕ n_cup n) ∝ + A ⊤. +Proof. + rewrite <- stack_nwire_distribute_r. + rewrite n_cap_pullthrough_bot. + rewrite stack_nwire_distribute_r, compose_assoc. + clean_eqns rewrite stack_assoc. + clean_eqns rewrite cast_compose_l, cast_contract. + rewrite (cast_compose_r _ _ (A ⊤ ↕ _)), cast_id. + rewrite <- stack_compose_distr. + rewrite n_wire_stack, nwire_removal_l, nwire_removal_r. + rewrite (stack_split_antidiag (A ⊤)). + clean_eqns rewrite stack_empty_r, + (cast_compose_r _ _ (n_wire n ↕ _)), !cast_contract. + clean_eqns rewrite cast_compose_distribute, + cast_contract, cast_id. + rewrite <- compose_assoc. + rewrite big_yank_l. + now cleanup_zx. Qed. Global Open Scope ZX_scope. @@ -81,12 +578,11 @@ Proof. - simpl. simpl in IHn. rewrite IHn at 1. - simpl_casts. rewrite stack_wire_distribute_l. rewrite stack_wire_distribute_r. change (— ↕ n_wire n) with (n_wire (1 + n)). rewrite <- (@cast_n_wire (n + 1) (1 + n)). - rewrite <- ComposeRules.compose_assoc. + rewrite <- compose_assoc. apply compose_simplify; [ | easy]. rewrite (cast_compose_mid (S (n + S n))). rewrite cast_compose_distribute. @@ -108,15 +604,6 @@ Unshelve. all: lia. Qed. -Lemma n_cup_inv_n_swap_n_wire : forall n, n_cup n ∝ n_wire n ↕ n_swap n ⟷ n_cup_unswapped n. -Proof. - intros. - strong induction n. - destruct n; [ | destruct n]. - - simpl. rewrite n_cup_0_empty. cleanup_zx. simpl_casts. easy. - - simpl. rewrite n_cup_1_cup. cleanup_zx. simpl_casts. bundle_wires. cleanup_zx. easy. -Admitted. (*TODO*) - Lemma n_cup_unswapped_colorswap : forall n, ⊙ (n_cup_unswapped n) ∝ n_cup_unswapped n. Proof. intros. @@ -132,7 +619,6 @@ Qed. Lemma n_cup_colorswap : forall n, ⊙ (n_cup n) ∝ n_cup n. Proof. intros. -Local Transparent n_cup. unfold n_cup. simpl. rewrite n_wire_colorswap. diff --git a/src/CoreRules/StackComposeRules.v b/src/CoreRules/StackComposeRules.v index d1bbb4c..f3286b4 100644 --- a/src/CoreRules/StackComposeRules.v +++ b/src/CoreRules/StackComposeRules.v @@ -12,11 +12,7 @@ Lemma nwire_stack_compose_topleft : forall {topIn botIn topOut botOut} (zx1 ↕ zx0). Proof. intros. - prop_exists_nonzero 1. - simpl. - repeat rewrite n_wire_semantics. - Msimpl. - easy. + now rewrite <- stack_compose_distr, nwire_removal_l, nwire_removal_r. Qed. Lemma nwire_stack_compose_botleft : forall {topIn botIn topOut botOut} @@ -25,11 +21,19 @@ Lemma nwire_stack_compose_botleft : forall {topIn botIn topOut botOut} (zx0 ↕ zx1). Proof. intros. - prop_exists_nonzero 1. - simpl. - repeat rewrite n_wire_semantics. - Msimpl. - easy. + now rewrite <- stack_compose_distr, nwire_removal_l, nwire_removal_r. +Qed. + +Lemma stack_split_diag {n m o p} (zx0 : ZX n m) (zx1 : ZX o p) : + zx0 ↕ zx1 ∝ zx0 ↕ n_wire o ⟷ (n_wire m ↕ zx1). +Proof. + now rewrite <- stack_compose_distr, nwire_removal_l, nwire_removal_r. +Qed. + +Lemma stack_split_antidiag {n m o p} (zx0 : ZX n m) (zx1 : ZX o p) : + zx0 ↕ zx1 ∝ (n_wire n ↕ zx1) ⟷ (zx0 ↕ n_wire p). +Proof. + now rewrite <- stack_compose_distr, nwire_removal_l, nwire_removal_r. Qed. Lemma push_out_top : forall {nIn nOut nOutAppendix} (appendix : ZX 0 nOutAppendix) (zx : ZX nIn nOut), diff --git a/src/CoreRules/SwapRules.v b/src/CoreRules/SwapRules.v index f168597..3a72ef0 100644 --- a/src/CoreRules/SwapRules.v +++ b/src/CoreRules/SwapRules.v @@ -226,58 +226,37 @@ Qed. Lemma a_swap_semantics_ind : forall n, a_swap_semantics (S (S (S n))) = swap ⊗ (I (2 ^ (S n))) × (I 2 ⊗ a_swap_semantics (S (S n))) × (swap ⊗ (I (2 ^ (S n)))). Proof. - intros. - rewrite <- 2 a_swap_correct. - simpl. - repeat rewrite kron_id_dist_l by shelve. - restore_dims. - rewrite <- 2 (kron_assoc (I 2) (I 2) (_)) by shelve. - repeat rewrite id_kron. - replace ((2 ^ n + (2 ^ n + 0)))%nat with (2 ^ (S n))%nat by (simpl; lia). - restore_dims. - repeat rewrite <- Mmult_assoc. - restore_dims. - rewrite (kron_mixed_product swap (I _) (I (2 * 2)) (_)). - Msimpl. - repeat rewrite Mmult_assoc. - restore_dims. - repeat rewrite Mmult_assoc. - remember (⟦ (top_to_bottom_helper n) ⊤%ZX ⟧) as ZX_tb_t. - remember (⟦ top_to_bottom_helper n ⟧) as ZX_tb. - restore_dims. - rewrite (kron_mixed_product (I (2 * 2)) ZX_tb_t swap (I (2 ^ (S n)))) . - Msimpl; [ | shelve]. - rewrite <- (Mmult_1_r _ _ (swap ⊗ ZX_tb)) by shelve. - rewrite n_wire_transpose. - rewrite n_wire_semantics. - rewrite <- 2 kron_assoc by shelve. - restore_dims. - repeat rewrite <- Mmult_assoc by shelve. - rewrite <- 2 kron_id_dist_r by shelve. - rewrite a_swap_3_order_indep. - rewrite 2 kron_id_dist_r by shelve. - repeat rewrite <- Mmult_assoc by shelve. - restore_dims. - rewrite (kron_assoc _ (I 2) (I (2 ^ n))) by shelve. - rewrite id_kron. - replace (2 * (2 ^ n))%nat with (2 ^ (S n))%nat by (simpl; lia). - restore_dims. - repeat rewrite <- Mmult_assoc by shelve. - rewrite kron_mixed_product. - Msimpl. - 2,3: shelve. - restore_dims. - repeat rewrite Mmult_assoc by shelve. + intros n. + rewrite <- a_swap_correct. + rewrite <- n_wire_semantics. + change (I 2) with (⟦ — ⟧). + rewrite <- a_swap_correct. + change (swap ⊗ ⟦n_wire (S n)⟧) with + (⟦ ⨉ ↕ n_wire (S n)⟧). restore_dims. - rewrite kron_mixed_product. - Msimpl; [ | shelve]. - easy. -Unshelve. -all: subst; auto with wf_db. -all: try (apply WF_kron; try lia; replace (2 ^ n + (2 ^ n + 0))%nat with (2 ^ (S n))%nat by (simpl; lia); auto with wf_db). - apply WF_mult. - auto with wf_db. - apply WF_kron; try lia; replace (2 ^ n + (2 ^ n + 0))%nat with (2 ^ (S n))%nat by (simpl; lia); auto with wf_db. + change (⟦ a_swap (S (S (S n))) ⟧ = ⟦ + (⨉ ↕ n_wire (S n)) ⟷ ((— ↕ a_swap (S (S n))) + ⟷ (⨉ ↕ n_wire (S n))) ⟧). + rewrite 2!perm_of_zx_permutation_semantics by auto_zxperm. + apply perm_to_matrix_eq_of_perm_eq. + cbn [perm_of_zx]. + rewrite perm_of_n_wire, 2!perm_of_a_swap. + rewrite swap_perm_defn by lia. + rewrite stack_perms_idn_f, stack_perms_WF_idn by auto_perm. + unfold swap_2_perm. + intros k Hk. + rewrite <- Combinators.compose_assoc. + unfold compose at 1. + bdestruct (k =? 0); + [unfold swap_perm; bdestructΩ'; + unfold compose; bdestructΩ'|]. + bdestruct (k =? 1); + [unfold swap_perm; bdestructΩ'; + unfold compose; bdestructΩ'|]. + unfold swap_perm. + simplify_bools_lia_one_kernel. + unfold compose. + bdestructΩ'. Qed. Lemma a_swap_transpose : forall n, diff --git a/src/CoreRules/XRules.v b/src/CoreRules/XRules.v index 9a32713..b36d19d 100644 --- a/src/CoreRules/XRules.v +++ b/src/CoreRules/XRules.v @@ -81,6 +81,14 @@ Lemma X_absolute_fusion : forall {n m o} α β, X n o (α + β). Proof. intros. colorswap_of (@Z_absolute_fusion n m o). Qed. +Lemma X_split_left : forall n m α, + X n m α ∝ X n 1 α ⟷ X 1 m 0. +Proof. intros n m α. colorswap_of (Z_split_left n m α). Qed. + +Lemma X_split_right : forall n m α, + X n m α ∝ X n 1 0 ⟷ X 1 m α. +Proof. intros n m α. colorswap_of (Z_split_right n m α). Qed. + Lemma dominated_X_spider_fusion_top_right : forall n m0 m1 o α β, (X n (S m0) α ↕ n_wire m1 ⟷ X (S m0 + m1) o β) ∝ X (n + m1) o (α + β). diff --git a/src/CoreRules/ZRules.v b/src/CoreRules/ZRules.v index fc869a6..31a1be6 100644 --- a/src/CoreRules/ZRules.v +++ b/src/CoreRules/ZRules.v @@ -316,6 +316,22 @@ Proof. apply IHm. Qed. +Lemma Z_split_left : forall n m α, + Z n m α ∝ Z n 1 α ⟷ Z 1 m 0. +Proof. + intros n m α. + rewrite Z_absolute_fusion. + now rewrite Rplus_0_r. +Qed. + +Lemma Z_split_right : forall n m α, + Z n m α ∝ Z n 1 0 ⟷ Z 1 m α. +Proof. + intros n m α. + rewrite Z_absolute_fusion. + now rewrite Rplus_0_l. +Qed. + Lemma dominated_Z_spider_fusion_top_right : forall n m0 m1 o α β, (Z n (S m0) α ↕ n_wire m1 ⟷ Z (S m0 + m1) o β) ∝ Z (n + m1) o (α + β). @@ -434,16 +450,11 @@ Qed. Lemma Z_self_cap_absorbtion_base : forall {n} α, Z n 2%nat α ⟷ ⊃ ∝ Z n 0%nat α. Proof. intros. + rewrite (Z_split_left n 0 α), Z_split_left. + rewrite compose_assoc. + apply compose_simplify; [easy|]. prop_exists_nonzero 1. - Msimpl. - prep_matrix_equivalence. - intros i j Hi Hj. - destruct i as [|[]]; [..|cbn in Hi; lia]; - cbn; [|lca]. - destruct j; [destruct n; cbn -[Nat.eqb]; - [cbn|pose proof (Modulus.pow2_nonzero n); - Modulus.bdestructΩ']; lca|]. - Modulus.bdestructΩ'; lca. + lma'. Qed. Lemma Z_self_cap_absorbtion_top : forall {n m α}, (Z) n (S (S m)) α ⟷ (⊃ ↕ n_wire m) ∝ Z n m α. @@ -820,72 +831,18 @@ Qed. Lemma Z_n_wrap_under_r_base_unswapped : forall n m α, Z (n + m) 0 α ∝ (Z n m α ↕ n_wire m) ⟷ n_cup_unswapped m. Proof. - intros. - generalize dependent n. - generalize dependent α. - induction m; intros; [simpl; cleanup_zx; simpl_casts; subst; easy | ]. - remember (Z (n + (S m)) _ _) as LHS. - rewrite n_cup_unswapped_grow_l. - rewrite <- (@cast_Z n _ (m + 1)). - rewrite Z_add_r_base_rot. - simpl_casts. - rewrite <- compose_assoc. - simpl. - rewrite cast_compose_r. - simpl_casts. - rewrite (cast_compose_l _ _ (Z n 2 α ⟷ (Z 1 m 0 ↕ Z 1 1 0) ↕ n_wire S m)). - simpl_casts. - rewrite stack_assoc. - rewrite stack_nwire_distribute_r. - rewrite (stack_assoc (Z 1 m 0) _ (n_wire (S m))). - simpl_casts. - rewrite compose_assoc. - simpl. - rewrite (stack_assoc_back (Z 1 1 0) — (n_wire m)). - simpl_casts. - erewrite <- cast_compose_mid_contract. - simpl_casts. - erewrite <- (@cast_id (2 + m) (2 + m) _ _ (Z 1 1 0 ↕ — ↕ (n_wire m))). - rewrite <- (stack_compose_distr (Z 1 m 0) (n_wire m) _ (⊃ ↕ n_wire m)). - simpl_casts. - cleanup_zx. - rewrite <- (stack_compose_distr (— ↕ —) ⊃ (n_wire m) (n_wire m)). - bundle_wires. - cleanup_zx. - rewrite cast_compose_r. - simpl_casts. - simpl. - rewrite (stack_assoc_back _ —). - rewrite (stack_assoc_back _ ⊃ (n_wire m)). - rewrite <- cast_compose_mid_contract. - rewrite <- stack_nwire_distribute_r. - rewrite <- (nwire_stack_compose_botleft (Z 1 m 0) ⊃). - simpl. - cleanup_zx; simpl_casts. - rewrite <- compose_assoc. - rewrite stack_assoc_back. - simpl_casts. - rewrite cast_compose_r. - simpl_casts. - rewrite <- stack_wire_distribute_r. - rewrite <- Z_0_is_wire at 1. - rewrite <- Z_add_r_base_rot. - erewrite (cast_compose_l _ _ (Z _ _ _ ↕ —)). - erewrite (cast_compose_partial_contract_r _ _ _ m _ _ _ _ _ _ _ (n_wire m ↕ ⊃)). - rewrite <- (@Z_wrap_under_bot_right n m α). - simpl_casts. - eapply (cast_diagrams (n + 1 + m) 0). - erewrite <- (@cast_Z (n + 1) _ (m) (m + 0)). - rewrite cast_stack_l. - rewrite (cast_compose_mid (m + m)). - rewrite 2 cast_contract. - rewrite <- cast_compose_mid_contract. - rewrite <- IHm. - rewrite HeqLHS. - simpl_casts. - easy. -Unshelve. - all: lia. + intros n m α. + rewrite (Z_split_left n m), stack_nwire_distribute_r. + rewrite compose_assoc, n_cup_unswapped_pullthrough_top. + cbn [ZXCore.transpose]. + rewrite Z_zxperm_absorbtion_left, Z_zxperm_absorbtion_right by auto_zxperm. + rewrite <- compose_assoc, <- stack_compose_distr. + rewrite nwire_removal_l, nwire_removal_r. + unfold n_cup_unswapped. + rewrite cup_Z. + rewrite Z_zxperm_absorbtion_left by auto_zxperm. + rewrite <- Z_add_l. + now rewrite 2!Rplus_0_r. Qed. Lemma Z_n_wrap_under_r_base : forall n m α, Z (n + m) 0 α ∝ (Z n m α ↕ n_wire m) ⟷ n_cup m. @@ -901,59 +858,12 @@ Qed. Lemma Z_n_wrap_over_r_base_unswapped : forall n m α, Z (m + n) 0 α ∝ (n_wire m ↕ Z n m α) ⟷ n_cup_unswapped m. Proof. - intros. - generalize dependent n. - generalize dependent α. - induction m; intros; [simpl; cleanup_zx; simpl_casts; subst; easy | ]. - remember (Z (S m + n) 0 α) as LHS. - rewrite n_cup_unswapped_grow_l. - rewrite <- (@cast_Z n _ (1 + m)). - rewrite Z_add_r_base_rot. - simpl_casts. - rewrite stack_nwire_distribute_l. (* TODO: rename *) - rewrite n_wire_grow_r at 2. - rewrite <- compose_assoc. - rewrite (compose_assoc (n_wire (S m) ↕ Z n 2 α)). - rewrite cast_stack_l. - rewrite 2 stack_assoc. - simpl_casts. - erewrite <- (cast_compose_mid_contract (S m + 2) (S m + S m) (m + m) _ _ _ _ _ _ (n_wire m ↕ (— ↕ (Z 1 1 0 ↕ Z 1 m 0))) (n_wire m ↕ (⊃ ↕ n_wire m))). - rewrite <- stack_nwire_distribute_l. - rewrite stack_assoc_back. - simpl_casts. - rewrite <- (stack_compose_distr (— ↕ (Z 1 1 0)) ⊃ (Z 1 m 0)). - rewrite (stack_empty_r_rev ⊃). - simpl_casts. - replace ⦰ with (n_wire 0) by easy. - rewrite <- (Z_wrap_over_top_left 1 0). - cleanup_zx. - rewrite Z_2_0_0_is_cap. - rewrite n_wire_grow_r. - rewrite cast_stack_l. - rewrite stack_assoc. - simpl_casts. - erewrite (cast_compose_mid (m + 3) _ _ (cast _ _ _ _ _) (cast _ _ _ _ (n_wire m ↕ (⊃ ↕ Z 1 m 0)))). - rewrite cast_contract. - rewrite cast_contract. - rewrite <- cast_compose_mid_contract. - rewrite <- stack_compose_distr. - cleanup_zx. - rewrite <- (nwire_stack_compose_botleft ⊃ (Z 1 m 0)). - rewrite <- compose_assoc. - rewrite <- (Z_wrap_over_top_left n 1). - simpl. - cleanup_zx. - rewrite Z_spider_1_1_fusion. - eapply (cast_diagrams (m + (S n)) 0). - rewrite cast_compose_l. - simpl_casts. - rewrite <- IHm. - replace (α + 0)%R with α by lra. - rewrite HeqLHS. - simpl_casts. - easy. -Unshelve. - all: lia. + intros n m α. + rewrite Z_n_wrap_under_r_base_unswapped. + rewrite n_cup_unswapped_pullthrough_top. + cbn [ZXCore.transpose]. + now rewrite Z_zxperm_absorbtion_left, + Z_zxperm_absorbtion_right by auto_zxperm. Qed. Lemma Z_n_wrap_over_r_base : forall n m α, Z (m + n) 0 α ∝ (n_wire m ↕ Z n m α) ⟷ n_cup m. diff --git a/src/Permutations/ZXpermAutomation.v b/src/Permutations/ZXpermAutomation.v index 08a5881..0090635 100644 --- a/src/Permutations/ZXpermAutomation.v +++ b/src/Permutations/ZXpermAutomation.v @@ -2,6 +2,9 @@ Require Import ZXCore. Require CastRules ComposeRules. Require Export ZXperm. +#[export] Hint Extern 100 (WF_Matrix _) => + apply WF_Matrix_dim_change : wf_db. + Create HintDb perm_of_zx_cleanup_db. Create HintDb zxperm_db. #[export] Hint Constructors ZXperm : zxperm_db. diff --git a/src/Permutations/ZXpermFacts.v b/src/Permutations/ZXpermFacts.v index b70c932..f726c11 100644 --- a/src/Permutations/ZXpermFacts.v +++ b/src/Permutations/ZXpermFacts.v @@ -490,8 +490,9 @@ Qed. Lemma compose_zxperm_l' {n m o} (zxp : ZX n m) (zx0 : ZX m o) zx1 (H : ZXperm zxp) : - zxp ⊤ ⟷ zx1 ∝ zx0 <-> zx1 ∝ zxp ⟷ zx0. + zx1 ∝ zxp ⟷ zx0 <-> zxp ⊤ ⟷ zx1 ∝ zx0. Proof. + symmetry. split; [intros <- | intros ->]; rewrite <- compose_assoc, ?zxperm_transpose_left_inverse, ?zxperm_transpose_right_inverse @@ -512,8 +513,9 @@ Qed. Lemma compose_zxperm_r' {n m o} (zxp : ZX m o) (zx0 : ZX n m) zx1 (H : ZXperm zxp) : - zx1 ⟷ zxp ⊤ ∝ zx0 <-> zx1 ∝ zx0 ⟷ zxp. + zx1 ∝ zx0 ⟷ zxp <-> zx1 ⟷ zxp ⊤ ∝ zx0. Proof. + symmetry. split; [intros <- | intros ->]; rewrite compose_assoc, ?zxperm_transpose_left_inverse, ?zxperm_transpose_right_inverse